diff --git a/Abstract.hs b/Abstract.hs deleted file mode 100644 --- a/Abstract.hs +++ /dev/null @@ -1,2213 +0,0 @@ --- Some optimizations (-O) destroy the expected behavior of unsafePerformIO --- So, special options are needed, plus NOINLINE for the affected functions. -{-# OPTIONS -fno-cse -fno-full-laziness #-} - -{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeSynonymInstances, - GeneralizedNewtypeDeriving, DeriveFunctor, DeriveFoldable, DeriveTraversable, - NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Abstract where - -import Prelude hiding (showList, map, concat, foldl, pi, null) - -import Control.Applicative hiding (empty) -import Control.Monad.Writer (Writer, tell, All(..)) -import Control.Monad.Trans - -import Data.Monoid hiding ((<>)) -import Data.Foldable (Foldable, foldMap) -import qualified Data.Foldable as Foldable -import Data.Traversable as Traversable -import Data.Unique - -import Data.List (map) -import qualified Data.List as List -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - -import Debug.Trace -import Data.IORef -import System.IO.Unsafe - -import Text.PrettyPrint as PP - -import Collection (Collection) -import qualified Collection as Coll -import Polarity as Pol -import TreeShapedOrder (TSO) -import qualified TreeShapedOrder as TSO -import Util hiding (parens, brackets) -import qualified Util -import {-# SOURCE #-} Value (TeleVal) - --- * Names carry a name suggestion and a unique identifier - --- | Each Name is classified as "User", "EtaAlias", or "Quote". -data WhatName - = UserName - | EtaAliasName -- ^ a name for the eta-expanded name of a definition - | QuoteName - deriving (Eq, Ord, Show) - -data Name = Name - { suggestion :: String -- ^ suggestion for printing the name. - , what :: WhatName - , uid :: Unique -- !Unique - } - --- | Names are compared according to their UID. -instance Eq Name where - x == x' = uid x == uid x' - -instance Ord Name where - compare x x' = compare (uid x) (uid x') - -instance Show Name where - show (Name n _ u) = n -- n ++ "`" ++ show (hashUnique u `mod` 13) - --- | @fresh s@ generates a new name with 'suggestion' @s@. --- --- To a void a monad here, we use imperative features (@unsafePerformIO@). -fresh :: String -> Name -fresh n = Name n UserName $ unsafePerformIO newUnique -{-# NOINLINE fresh #-} - -freshen :: Name -> Name -freshen n = fresh (suggestion n) - --- | A non-unique empty name. Use only inconstant functions! -noName :: Name -noName = fresh "" - --- | Check whether name is @""@. -emptyName :: Name -> Bool -emptyName n = null (suggestion n) - -nonEmptyName :: Name -> String -> Name -nonEmptyName n s | emptyName n = n { suggestion = s } - | otherwise = n - --- | Get the first non-empty name from a non-empty list of names. -bestName :: [Name] -> Name -bestName [n] = n -bestName (n:ns) - | emptyName n = bestName ns - | otherwise = n - --- temporary hack for reification - -iAmNotUnique :: Unique -iAmNotUnique = unsafePerformIO newUnique -{-# NOINLINE iAmNotUnique #-} - -unsafeName :: String -> Name -unsafeName s = Name s QuoteName iAmNotUnique - --- | External reference to recursive function (outside of the body). -mkExtName :: Name -> Name -mkExtName n = Name (suggestion n) EtaAliasName $ unsafePerformIO newUnique --- mkExtName n = "_" ++ n -{-# NOINLINE mkExtName #-} - -mkExtRef n = letdef (mkExtName n) - -isEtaAlias :: Name -> Bool -isEtaAlias n = what n == EtaAliasName - --- | Internal name for compiler-generated stuff. -internal :: Name -> Name -internal n = freshen n --- internal n = "__" ++ n --- internal names are prefixed by a double underscore (not legal concrete syntax) - --- | Convert a dot pattern into an identifier which should not look too confusing. -spaceToUnderscore = List.map (\ c -> if c==' ' then '_' else c) -{- -exprToName e = spaceToUnderscore $ show e -patToName p = spaceToUnderscore $ show p --} - --- | Qualified name. -data QName - = Qual { qual :: Name, name :: Name } - | QName { name :: Name } - deriving (Eq, Ord) - -instance Show QName where - show (Qual m n) = show m ++ "." ++ show n - show (QName n) = show n - --- | An unqualified name is an instance of a qualified name. -nameInstanceOf (QName n) (Qual _ n') = n == n' -nameInstanceOf n n' = n == n' - --- | Fails if qualified name. -unqual (QName n) = n -unqual n = error $ "Abstract.unqual: " ++ show n - -data Sized = Sized | NotSized - deriving (Eq,Ord,Show) - -data Co = Ind - | CoInd - deriving (Eq,Ord,Show) - -showFun :: Co -> String -showFun Ind = "fun" -showFun CoInd = "cofun" - -data LtLe = Lt | Le deriving (Eq,Ord) - -instance Show LtLe where - show Lt = "<" - show Le = "<=" - --- decoration of Pi-types -------------------------------------------- - --- 1. whether argument is irrelevant / its polarity --- further possibilities: --- 2. hidden - -data Decoration pos - = Dec { thePolarity :: pos } - | Hidden - deriving (Eq, Ord, Functor, Foldable, Traversable, Show) - -polarity :: Polarity pol => Decoration pol -> pol -polarity Hidden = hidden -polarity (Dec pol) = pol - -instance Polarity a => Polarity (Decoration a) where - erased = erased . polarity - compose p p' = Dec $ compose (polarity p) (polarity p') - neutral = Dec neutral - promote = Dec . promote . polarity - demote = Dec . demote . polarity - hidden = Hidden - -type Dec = Decoration Pol -type UDec = Decoration PProd - -class LensPol a where - getPol :: a -> Pol - setPol :: Pol -> a -> a - setPol = mapPol . const - mapPol :: (Pol -> Pol) -> a -> a - mapPol f a = setPol (f (getPol a)) a - -instance LensPol Dec where - getPol = polarity - setPol p Hidden = Hidden - setPol p dec = dec { thePolarity = p } - -udec :: Dec -> UDec -udec = fmap pprod - -irrelevantDec = Dec Pol.Const -paramDec = Dec Param -defaultDec = Dec defaultPol --- defaultDec = paramDec -- TODO: Dec { polarity = Rec } -defaultUpperDec = Dec $ pprod SPos - -- a variable may not be erased and its polarity must be below SPos --- notErased = Dec False --- resurrectDec d = d { erased = False } - --- | Composing with 'neutralDec' should do nothing. -neutralDec = Dec SPos - -coDomainDec :: Dec -> Dec -coDomainDec Hidden = Dec Param -- REDUNDANT -coDomainDec dec - | polarity dec == Pol.Const = Dec Param - | otherwise = Dec Rec - --- compDec dec dec' --- composition of decoration, used when type checking arguments --- of functions decorated with dec -compDec :: Dec -> UDec -> UDec -compDec dec udec = compose (fmap pprod dec) udec - -{- -instance Show pos => Show (Decoration pos) where - show p = - (if erased p then Util.brackets else Util.parens) $ show $ polarity p --} - - -{- OLD CODE -data Decoration pos = Dec { erased :: Bool, polarity :: pos } - deriving (Eq, Ord, Functor, Foldable, Traversable) - -type Dec = Decoration Pol -type UDec = Decoration PProd - -irrelevantDec = Dec { erased = True, polarity = Pol.Const } -defaultDec = Dec { erased = False, polarity = Rec } -defaultUpperDec = Dec { erased = False, polarity = pprod SPos } - -- a variable may not be erased and its polarity must be below SPos --- notErased = Dec False -resurrectDec d = d { erased = False } - -{- RETIRED --- invCompDec dec dec' --- inverse composition of decoration, used when type checking arguments --- of functions decorated with dec -invCompDec :: Dec -> Dec -> Dec -invCompDec (Dec er pol) (Dec er' pol') = Dec - (if er then False else er') - (invComp pol pol') --} - --- compDec dec dec' --- composition of decoration, used when type checking arguments --- of functions decorated with dec -compDec :: Dec -> UDec -> UDec -compDec (Dec er pol) (Dec er' pol') = Dec - (er || er') -- erasing once is sufficient - (polProd (pprod pol) pol') - -instance Show pos => Show (Decoration pos) where - show (Dec erased polarity) = - (if erased then Util.brackets else Util.parens) $ show polarity --} - --- size expressions -------------------------------------------------- - -class HasPred a where - predecessor :: a -> Maybe a - -instance HasPred Expr where - predecessor (Succ e) = Just e - predecessor _ = Nothing - -sizeSuccE :: Expr -> Expr -sizeSuccE Infty = Infty -sizeSuccE e = Succ e - -minSizeE :: Expr -> Expr -> Expr -minSizeE Infty e2 = e2 -minSizeE e1 Infty = e1 -minSizeE Zero e2 = Zero -minSizeE e1 Zero = Zero -minSizeE (Succ e1) (Succ e2) = Succ (minSizeE e1 e2) -minSizeE e1 e2 = error $ "minSizeE " ++ (Util.parens $ show e1) ++ " " ++ (Util.parens $ show e2) - -maxSizeE :: Expr -> Expr -> Expr -maxSizeE Infty e2 = Infty -maxSizeE e1 Infty = Infty -maxSizeE Zero e2 = e2 -maxSizeE e1 Zero = e1 -maxSizeE (Succ e1) (Succ e2) = Succ (maxSizeE e1 e2) -maxSizeE e1 e2 = Max [e1, e2] --- maxSizeE e1 e2 = error $ "maxSizeE " ++ (Util.parens $ show e1) ++ " " ++ (Util.parens $ show e2) - -flattenMax :: Expr -> [Expr] -> [Expr] -flattenMax Infty acc = [Infty] -flattenMax Zero acc = acc -flattenMax (Max []) acc = acc -flattenMax (Max (e : es)) acc = flattenMax e $ flattenMax (Max es) acc -flattenMax e acc = e : acc - --- smart constructor for MAX -maxE :: [Expr] -> Expr -maxE es = Max $ foldr flattenMax [] es - -sizeVarsToInfty :: Expr -> Expr -sizeVarsToInfty Zero = Zero -sizeVarsToInfty (Succ e) = sizeSuccE (sizeVarsToInfty e) -sizeVarsToInfty _ = Infty - -leqSizeE :: Expr -> Expr -> Bool -leqSizeE Zero e = True -leqSizeE e Zero = False -leqSizeE e Infty = True -leqSizeE (Succ e) (Succ e') = leqSizeE e e' -leqSizeE Infty e = False - --- plus :: Expr -> Expr -> Expr - --- sorts ------------------------------------------------------------- - -data Class - = Tm -- sort of terms, only needed for erasure --- | Ty -- use Set 0! -- sort of type(constructor)s, only needed for erasure --- | Ki -- sort of kinds -- use Set 0 ... for mor precision - | Size -- sort of sizes - | TSize -- sort of Size - -- | Type -- no longer used - deriving (Eq, Ord, Show) - -predClass :: Class -> Class --- predClass Ty = Tm -predClass TSize = Size -predClass Tm = Tm -predClass Size = Size - -data Sort a - = SortC Class -- sort constant (Size, TSize) - | Set a -- Set 0 = CoSet #, Set 1 = Type 1, Set 2 = Type 2, ... - | CoSet a -- sized version of Set - deriving (Eq, Ord, Functor, Foldable, Traversable) - -{- -instance Show a => Show (Sort a) where - show (SortC c) = show c - show (Set a) = "Set " ++ show a - show (CoSet a) = "CoSet " ++ show a --} - -instance Show (Sort Expr) where - show (SortC c) = show c - show (Set Zero) = "Set" - show (CoSet Infty) = "Set" - show (Set e) = Util.parens $ ("Set " ++ show e) - show (CoSet e) = Util.parens $ ("CoSet " ++ show e) - -topSort :: Sort Expr -topSort = Set Infty - --- | The expression representing the type Size. -tSize :: Expr -tSize = Sort (SortC Size) - --- | Checking whether an expression represents type Size. -isSize :: Expr -> Bool -isSize (Sort (SortC Size)) = True -isSize (Below Le Infty) = True -isSize _ = False - -predSort :: Sort Expr -> Sort Expr -predSort (SortC c) = SortC (predClass c) -predSort (CoSet e) = SortC Tm -predSort (Set Zero) = SortC Tm -predSort (Set (Succ e)) = Set e -predSort (Set Infty) = Set Infty -predSort s@(Set Var{}) = s -predSort s = error $ "internal error: predSort " ++ show s - --- only for sorts appearing in kinds: - -succSort :: Sort Expr -> Sort Expr -succSort (SortC Size) = SortC TSize -succSort (SortC Tm) = Set Zero -succSort (Set e) = Set (sizeSuccE e) - -minSort :: Sort Expr -> Sort Expr -> Sort Expr -minSort (SortC Tm) (Set e) = SortC Tm -minSort (Set e) (SortC Tm) = SortC Tm -minSort (Set e) (Set e') = Set (minSizeE e e') --- minSort (SortC c) (SortC c') | c == c' = SortC c -minSort (SortC c) (SortC c') = SortC $ minClass c c' -minSort s s' = error $ "minSort (" ++ show s ++ ") (" ++ show s' ++ ") not implemented" - --- 2012-01-21: that should not be necessary, but to move on... -minClass :: Class -> Class -> Class -minClass Tm c = Tm -minClass c Tm = Tm -minClass Size c = Size -minClass c Size = Size -minClass TSize TSize = TSize -maxClass :: Class -> Class -> Class - -maxClass Tm c = c -maxClass c Tm = c -maxClass Size c = c -maxClass c Size = c -maxClass TSize TSize = TSize - -maxSort :: Sort Expr -> Sort Expr -> Sort Expr -maxSort (SortC Tm) (Set e) = Set e -maxSort (Set e) (SortC Tm) = Set e -maxSort (Set e) (Set e') = Set (maxSizeE e e') --- maxSort (SortC c) (SortC c') | c == c' = SortC c -maxSort (SortC c) (SortC c') = SortC $ maxClass c c' -maxSort s s' = error $ "maxSort (" ++ show s ++ ") (" ++ show s' ++ ") not implemented" - -{- -leSort :: Sort -> Sort -> Bool -leSort _ Type = True -leSort Type _ = False -leSort s s' = s == s' --} - --- s `irrSortFor` s' if a variable of kind s cannot compuationally --- contribute to produce a value of kind s' -irrSortFor :: Sort Expr -> Sort Expr -> Bool -irrSortFor (SortC Tm) _ = False -- terms matter for terms and everything -irrSortFor _ (SortC Tm) = True -- nothing else can be eliminated into a term -irrSortFor (SortC Size) _ = False -- sizes matter for everything but terms -irrSortFor _ (SortC Size) = True -- nothing else can be eliminated into a size -irrSortFor (SortC TSize) _ = False -- sizes matter for everything but terms -irrSortFor _ (SortC TSize) = True -- nothing else can be eliminated into a size -irrSortFor (Set e) (Set e') = not $ leqSizeE e e' - --- kinds ------------------------------------------------------------- - --- kinds classify expressions into terms, types, universes, ... --- since the analysis is not precise, we give an interval of classes - -data Kind - = Kind { lowerKind :: Sort Expr , upperKind :: Sort Expr } - | NoKind -- absurd clauses, neutral wrt. union - | AnyKind -- not yet classified, neutral wrt. intersection - deriving (Eq, Ord) - ---defaultKind = Kind (SortC Tm) topSort -- no classification, could be anything -defaultKind = AnyKind - -preciseKind s = Kind s s -kSize = preciseKind (SortC Size) -kTSize = preciseKind (SortC TSize) -kTerm = preciseKind (SortC Tm) -kType = preciseKind (Set Zero) -kUniv e = preciseKind (Set (Succ (sizeVarsToInfty e))) -- used in TypeChecker - -instance Show Kind where - show NoKind = "()" - show AnyKind = "?" --- show k | k == defaultKind = "?" - show (Kind kl ku) | kl == ku = show kl - show (Kind kl ku) = show kl ++ ".." ++ show ku - --- print kind in four letters -prettyKind :: Kind -> String -prettyKind NoKind = "none" -prettyKind AnyKind = "anyk" --- prettyKind k | k == defaultKind = "anyk" -prettyKind (Kind _ (SortC Tm)) = "term" -prettyKind (Kind _ (SortC Size)) = "size" -prettyKind k | k == kType = "type" -prettyKind (Kind (Set (Succ Zero)) _) = "univ" -prettyKind (Kind (Set Zero) _) = "ty-u" -prettyKind (Kind (SortC Tm) (Set Zero)) = "tmty" -prettyKind k = "mixk" - --- if D : T and T has kind ki, then D has kind dataKind ki -dataKind :: Kind -> Kind -dataKind (Kind _ (Set (Succ e))) = Kind (Set Zero) (Set e) - --- in (x : A) -> B, if x : A and A has kind ki, then x has kind argKind ki -argKind :: Kind -> Kind -argKind NoKind = NoKind -argKind AnyKind = AnyKind -argKind (Kind s s') = Kind (predSort s) (predSort s') - --- if e : A and A has kind ki, then e has kind predKind ki -predKind :: Kind -> Kind -predKind NoKind = NoKind -predKind AnyKind = AnyKind --- predecessors in the kind hierarchy -predKind ki@(Kind _ (SortC Size)) = error $ "predKind " ++ show ki -predKind (Kind _ (SortC TSize)) = kSize --- proper types are only inhabited by terms -predKind (Kind _ (Set Zero)) = kTerm --- proper universes are inhabited by types and universes -predKind (Kind (Set (Succ e)) s) = Kind (Set Zero) (predSort s) --- something which is a type or a universe can be inhabited by a term -predKind (Kind _ s) = Kind (SortC Tm) (predSort s) - -succKind :: Kind -> Kind -succKind AnyKind = AnyKind -succKind (Kind _ (SortC Tm)) = kType -succKind (Kind _ (SortC Size)) = kTSize -succKind (Kind s _) = Kind (succSort s) (Set Infty) -- no upper bound - --- partial operation! -intersectKind :: Kind -> Kind -> Kind -intersectKind NoKind ki = ki -- NoKind means here "intersection is not happening" -intersectKind ki NoKind = ki -intersectKind AnyKind ki = ki -intersectKind ki AnyKind = ki -intersectKind (Kind x1 x2) (Kind y1 y2) = - Kind (maxSort x1 y1) (minSort x2 y2) - -unionKind :: Kind -> Kind -> Kind -unionKind ki1 ki2 = -- trace (show ki1 ++ " `unionKind` " ++ show ki2) $ - case (ki1,ki2) of - (NoKind, ki) -> ki - (ki, NoKind) -> ki - (AnyKind, ki) -> AnyKind - (ki, AnyKind) -> AnyKind - (Kind x1 x2, Kind y1 y2) -> - Kind (minSort x1 y1) (maxSort x2 y2) - --- ki `irrelevantFor` ki' if an argument of kind ki cannot --- computationally contribute to a result of kind ki' -irrelevantFor :: Kind -> Kind -> Bool -irrelevantFor NoKind _ = False -- do not make a statement if there is no info -irrelevantFor _ NoKind = False -irrelevantFor AnyKind _ = False -irrelevantFor _ AnyKind = False -irrelevantFor (Kind s _) (Kind _ s') = irrSortFor s s' --- worst case szenario: the least kind of the argument is still --- irrelevant for the biggest kind of the result - -data Kinded a = Kinded { kindOf :: Kind, valueOf :: a } - deriving (Eq, Ord, Functor, Foldable, Traversable) - -instance Show a => Show (Kinded a) where --- show (Kinded ki a) | ki == defaultKind = show a - show (Kinded ki a) = show a ++ "::" ++ show ki - --- function domains -------------------------------------------------- - -data Dom a = Domain { typ :: a, kind :: Kind, decor :: Dec } - deriving (Eq, Ord, Functor, Foldable, Traversable) - -instance Show a => Show (Dom a) where - show (Domain ty ki dec) = show dec ++ show ty ++ "::" ++ show ki - -defaultDomain a = Domain a defaultKind defaultDec -domFromKinded (Kinded ki t) = Domain t ki defaultDec -defaultIrrDom a = Domain a defaultKind irrelevantDec - -sizeDomain :: Dec -> Dom Expr -sizeDomain dec = Domain tSize kTSize dec - -belowDomain :: Dec -> LtLe -> Expr -> Dom Expr -belowDomain dec ltle e = Domain (Below ltle e) kTSize dec - -class LensDec a where - getDec :: a -> Dec - setDec :: Dec -> a -> a - setDec d = mapDec $ const d - mapDec :: (Dec -> Dec) -> a -> a - mapDec f a = setDec (f $ getDec a) a - -instance LensDec (Dom a) where - getDec = decor - setDec d dom = dom { decor = d } - -instance LensPol (Dom a) where - getPol = getPol . getDec - mapPol = mapDec . mapPol - -{- -instance Functor Dom where - fmap f dom = dom { typ = f (typ dom) } - --- traverse :: Applicative f => (a -> f b) -> t a -> f (t b) -instance Traversable Dom where - traverse f dom = (\ ty -> dom { typ = ty }) <$> f (typ dom) --} - --- identifiers ------------------------------------------------------- - --- | -data ConK - = Cons -- ^ a constructor - | CoCons -- ^ a coconstructor - | DefPat -- ^ a defined pattern - deriving (Eq, Ord, Show) - -data IdKind - = DatK -- ^ data/codata - | ConK ConK -- ^ constructor (ind/coind/defined) - | FunK -- ^ fun/cofun - | LetK -- ^ let definition - deriving (Eq, Ord) - -instance Show IdKind where - show DatK = "data" - show ConK{} = "con" - show FunK = "fun" - show LetK = "let" - -conKind (ConK _) = True -conKind _ = False - -coToConK Ind = Cons -coToConK CoInd = CoCons - -data DefId = DefId { idKind :: IdKind, idName :: QName } - deriving (Eq, Ord) - -instance Show DefId where - show d = show (idName d) -- ++ "@" ++ show (idKind d) - -type MVar = Int -- metavariables are numbered - --- typed bindings in Pi, LLet, Telescope ----------------------------- - -data TBinding a = TBind - { boundName :: Name -- ^ @emptyName@ if non-dependent. - , boundDom :: Dom a -- ^ @x : T@ or @i < j@. - } - | TMeasure (Measure Expr) -- ^ Measure @|m|@. - | TBound (Bound Expr) -- ^ Constraint @|m| <(=) |m'|@. - deriving (Eq,Ord,Show,Functor,Foldable,Traversable) - -type LBind = TBinding (Maybe Type) -type TBind = TBinding Type - -noBind :: Dom a -> TBinding a -noBind = TBind (fresh "") - -boundType :: TBind -> Type -boundType = typ . boundDom - -instance LensDec (TBinding a) where - getDec = getDec . boundDom - mapDec f (TBind x dom) = TBind x (dom { decor = f (decor dom) }) - mapDec f tb = tb - -mapDecM :: (Applicative m) => (Dec -> m Dec) -> TBind -> m TBind -mapDecM f tb@TBind{} = flip setDec tb <$> f (getDec tb) -mapDecM f tb = pure tb - --- measures ---------------------------------------------------------- - -newtype Measure a = Measure { measure :: [a] } -- mu - deriving (Eq,Ord,Functor,Foldable,Traversable) - -instance Show a => Show (Measure a) where - show (Measure l) = "|" ++ showList "," show l ++ "|" - -succMeasure :: (a -> a) -> Measure a -> Measure a -succMeasure succ mu = maybe (error "cannot take successor of empty measure") id $ applyLastM (Just . succ) mu - -{- -succMeasure succ (Measure mu) = Measure (succMeas mu) - where succMeas [] = error "cannot take successor of empty measure" - succMeas [e] = [succ e] - succMeas (e:es) = e : succMeas es --} - -applyLastM :: (a -> Maybe a) -> Measure a -> Maybe (Measure a) -applyLastM f (Measure mu) = Measure <$> loop mu - where loop [] = fail "empty measure" - loop [e] = (:[]) <$> f e - loop (e:es) = (e:) <$> loop es - -instance HasPred a => HasPred (Measure a) where - predecessor mu = applyLastM predecessor mu - -data Bound a = Bound { ltle :: LtLe, leftBound :: Measure a, rightBound :: Measure a } -- mu < mur of mu <= mu' - deriving (Eq,Ord,Functor,Foldable,Traversable) - -instance Show a => Show (Bound a) where - show (Bound Lt mu1 mu2) = show mu1 ++ " < " ++ show mu2 - show (Bound Le mu1 mu2) = show mu1 ++ " <= " ++ show mu2 - -{- -instance (HasPred a, Show a) => Show (Bound a) where - show (Bound mu1 mu2) = case predecessor mu2 of - Just mu2 -> show mu1 ++ " <= " ++ show mu2 - Nothing -> show mu1 ++ " < " ++ show mu2 --} - --- TODO: properly implement bounds mu <= mu' such that mu <= # is --- represented correctly - --- tagging expressions ----------------------------------------------- - -data Tag - = Erased -- ^ Expression will be erased. - | Cast -- ^ Expression will need to be casted. - deriving (Eq,Ord,Show) - -type Tags = [Tag] - -inTags :: Tag -> Tags -> Bool -inTags = elem - -noTags = [] - -data Tagged a = Tagged { tags :: Tags , unTag :: a } - deriving (Eq,Ord,Functor,Foldable,Traversable) - -instance Show a => Show (Tagged a) where - show (Tagged tags a) = - bracketsIf (Erased `inTags` tags) $ - showCast (Cast `inTags` tags) $ - show a - -showCast :: Bool -> String -> String -showCast True s = "'cast" ++ Util.parens s -showCast False s = s - -instance Pretty a => Pretty (Tagged a) where - prettyPrec k (Tagged [] a) = prettyPrec k a - prettyPrec _ (Tagged tags a) = - prettyErased (Erased `inTags` tags) $ - prettyCast (Cast `inTags` tags) $ - pretty a - -prettyErased True doc = brackets doc -prettyErased False doc = doc - -prettyCast True doc = text "'cast" <> PP.parens doc -prettyCast False doc = doc - --- expressions ------------------------------------------------------- - -data Expr - = Sort (Sort Expr) -- ^ @Size@ @Set@ @CoSet@ - -- sizes - | Zero - | Succ Expr - | Infty - | Max [Expr] -- ^ (list has at least 2 elements) - | Plus [Expr] -- ^ (list has at least 2 elements) - -- identifiers - | Meta MVar -- ^ meta-variable - | Var Name -- ^ variables are named - | Def DefId -- ^ identifiers in the signature -{- - | Con Co Name [Expr] -- constructors applied to arguments - | Def Name -- fun/cofun ? - | Let Name -- definition (non-recursive) --} - -- dependently typed lambda calculus - | Record RecInfo [(Name,Expr)] -- ^ record { p1 = e1; ...; pn = en } - | Proj PrePost Name -- ^ proj _ or _ .proj - | Pair Expr Expr - | Case Expr (Maybe Type) [Clause] - -- ^ Type is @Nothing@ in input, @Just@ after t.c. - | LLet LBind Telescope Expr Expr - -- ^ @let [x : A] = t in u@, @let [x] tel = t in u@ - -- after t.c. @Telescope@ is empty (fused into @LBind@) - | App Expr Expr - | Lam Dec Name Expr - | Quant PiSigma TBind Expr - | Sing Expr Expr -- 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 deleted file mode 100644 --- a/Abstract.hs-boot +++ /dev/null @@ -1,4 +0,0 @@ -module Abstract where - -data TBinding a - diff --git a/Collection.hs b/Collection.hs deleted file mode 100644 --- a/Collection.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} - -module Collection where - -import Data.List as List -import Data.Monoid - -import Data.Set (Set) -import qualified Data.Set as Set - -class Monoid c => Collection c e | c -> e where -{- - empty :: c - append :: c -> c -> c - concat :: [c] -> c --} - singleton :: e -> c - delete :: e -> c -> c - (\\) :: c -> c -> c - -instance Eq a => Collection [a] a where -{- - empty = [] - append = (++) - concat = List.concat --} - singleton = (:[]) - delete = List.delete - (\\) = (List.\\) - -instance Ord a => Collection (Set a) a where -{- - empty = Set.empty - append = Set.union - concat = Set.unions --} - singleton = Set.singleton - delete = Set.delete - (\\) = (Set.\\) diff --git a/Concrete.hs b/Concrete.hs deleted file mode 100644 --- a/Concrete.hs +++ /dev/null @@ -1,324 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} --- concrete syntax -module Concrete where - -import Prelude hiding (null) - -import Util -import Abstract (Co,Sized,PiSigma(..),Decoration(..),Dec,Override(..),Measure(..),Bound(..),HasPred(..),LtLe(..),polarity) -import qualified Abstract as A -import Polarity - --- | Concrete names. -data Name = Name { theName :: String } - deriving (Eq,Ord) - -instance Show Name where - show (Name n) = n - --- | Possibly qualified names. -data QName - = Qual { qual :: Name, name :: Name } -- ^ @X.x@ e.g. qualified constructor. - | QName { name :: Name } -- ^ @x@. - deriving (Eq,Ord) - -unqual (QName n) = n - -instance Show QName where - show (Qual m n) = show m ++ "." ++ show n - show (QName n) = show n - -set0 = Set Zero -ident n = Ident (QName n) - --- | Concrete expressions syntax. -data Expr - = Set Expr -- ^ Universe @Set e@; @Set@ for @Set 0@. - | CoSet Expr - | Size -- ^ @Size@ type of sizes. - | Succ Expr -- ^ @$e@. - | Zero -- ^ @0@. - | Infty -- ^ @#@. - | Max -- ^ @max@. - | Plus Expr Expr -- ^ @e + e'@. - | RApp Expr Expr -- ^ @e |> f@. - | App Expr [Expr] -- ^ @f e1 ... en@ or @f <| e@. - | Lam Name Expr -- ^ @\ x -> e@. - | Case Expr (Maybe Type) [Clause] -- ^ @case e : A { cls }@. - | LLet LetDef Expr -- ^ @let x = e in e'@ local let. - | Quant PiSigma Telescope Expr -- ^ @(x : A) -> B@, @[x : A] -> B@, @(x : A) & B@. - | Pair Expr Expr -- ^ @e , e'@. - | Record [([Name],Expr)] -- ^ @record { x = e, x' y = e' }@. - | Proj Name -- ^ @.x@. - | Ident QName -- ^ @x@ or @D.c@. - | Unknown -- ^ @_@. - | Sing Expr Expr -- ^ @@ 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 deleted file mode 100644 --- a/Eval.hs +++ /dev/null @@ -1,2359 +0,0 @@ -{-# LANGUAGE TupleSections, FlexibleInstances, FlexibleContexts, NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} - --- Activate this flag if i < $i should only hold for i < #. --- #define STRICTINFTY - -module Eval where - -import Prelude hiding (mapM, null, pi) - -import Control.Applicative -import Control.Monad.Identity hiding (mapM) -import Control.Monad.State hiding (mapM) -import Control.Monad.Except hiding (mapM) -import Control.Monad.Reader hiding (mapM) - -import qualified Data.Array as Array -import Data.Maybe -- fromMaybe -import Data.Monoid hiding ((<>)) -import Data.List as List hiding (null) -- find -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Foldable (foldMap) -import Data.Traversable (Traversable, mapM, traverse) -import qualified Data.Traversable as Traversable - -import Debug.Trace (trace) - -import Abstract -import Polarity as Pol -import Value -import TCM -import PrettyTCM -import Warshall -- positivity checking - -import TraceError -import Util - - -traceEta msg a = a -- trace msg a -traceEtaM msg = return () -- traceM msg -{- -traceEta msg a = trace msg a -traceEtaM msg = traceM msg --} - -traceRecord msg a = a -traceRecordM msg = return () - - -traceMatch msg a = a -- trace msg a -traceMatchM msg = return () -- traceM msg -{- -traceMatch msg a = trace msg a -traceMatchM msg = traceM msg --} - -traceLoop msg a = a -- trace msg a -traceLoopM msg = return () -- traceM msg -{- -traceLoop msg a = trace msg a -traceLoopM msg = traceM msg --} - -traceSize msg a = a -- trace msg a -traceSizeM msg = return () -- traceM msg -{- -traceSize msg a = trace msg a -traceSizeM msg = traceM msg --} - -failValInv :: (MonadError TraceError m) => Val -> m a -failValInv v = throwErrorMsg $ "internal error: value " ++ show v ++ " violates representation invariant" - --- evaluation with rewriting ------------------------------------- - -{- - -Rewriting rules have the form - - blocked --> pattern - -this means that at the root, at most one rewriting step is possible. -Rewriting rules are considered computational, since they trigger new -(symbolic) computations. At least they have to be applied in - -- pattern matching -- equality checking -When a new rule b --> p is added, b should be in --> normal form. -Otherwise there could be inconsistencies, like adding both rules - - b --> true - b --> false - -If after adding b --> true b is rewritten to nf, then the second rule -would be true --> false, which can be captured by MiniAgda. - -Also, after adding a new rule, it could be used to rewrite the old rules. - -Implementation: - -- add a set of local rewriting rules to the context (not to the state) -- keep values in --> weak head normal form -- untyped equality test between values - - -} - -class Reval a where - reval' :: Valuation -> a -> TypeCheck a - reval :: a -> TypeCheck a - reval = reval' emptyVal - -instance Reval a => Reval (Maybe a) where - reval' valu ma = Traversable.traverse (reval' valu) ma - -instance Reval b => Reval (a,b) where - reval' valu (x,v) = (x,) <$> reval' valu v - -instance Reval a => Reval [a] where - reval' valu vs = mapM (reval' valu) vs - -instance Reval Env where - reval' valu (Environ rho mmeas) = - flip Environ mmeas <$> reval' valu rho - -- no need to reevaluate mmeas, since only sizes - --- | When combining valuations, the old one takes priority. --- @[sigma][tau]v = [[sigma]tau]v@ -instance Reval Valuation where - reval' valu (Valuation valu') = Valuation . (++ valuation valu) <$> - reval' valu valu' - -instance Reval a => Reval (Measure a) where - reval' valu beta = Traversable.traverse (reval' valu) beta - -instance Reval a => Reval (Bound a) where - reval' valu beta = Traversable.traverse (reval' valu) beta - -instance Reval Val where - reval' valu u = traceLoop ("reval " ++ show u) $ do - let reval v = reval' valu v - reEnv rho = reval' valu rho - reFun fv = reval' valu fv - case u of - VSort (CoSet v) -> VSort . CoSet <$> reval v - VSort{} -> return u - VInfty -> return u - VZero -> return u - VSucc{} -> return u -- no rewriting in size expressions - VMax{} -> return u - VPlus{} -> return u - VProj{} -> return u -- cannot rewrite projection - VPair v1 v2 -> VPair <$> reval v1 <*> reval v2 - VRecord ri rho -> VRecord ri <$> mapAssocM reval rho - - VApp v vl -> do - v' <- reval v - vl' <- mapM reval vl - w <- foldM app v' vl' - reduce w -- since we only have rewrite rules at base types - -- we do not need to reduces prefixes of w - - VDef{} -> return $ VApp u [] -- restore invariant - -- CAN'T rewrite defined fun/data - VGen i -> reduce (valuateGen i valu) -- CAN rewrite variable - - VCase v tv env cl -> do - v' <- reval v - tv' <- reval tv - env' <- reEnv env - evalCase v' tv' env' cl - - VBelow ltle v -> VBelow ltle <$> reval v - VGuard beta v -> VGuard <$> reval beta <*> reval v - VQuant pisig x dom fv -> - VQuant pisig x - <$> Traversable.mapM reval dom - <*> reFun fv - {- - VQuant pisig x dom env b -> do - dom' <- Traversable.mapM reval dom - env' <- reEnv env - return $ VQuant pisig x dom' env' b - -} - VConst v -> VConst <$> reval' valu v - VLam x env e -> flip (VLam x) e <$> reval' valu env - VAbs x i v valu' -> VAbs x i v <$> reval' valu valu' - VUp v tv -> up False ==<< (reval' valu v, reval' valu tv) -- do not force at this point - - VClos env e -> do env' <- reEnv env - return $ VClos env' e - - VMeta i env k -> do env' <- reEnv env - return $ VMeta i env' k - - VSing v tv -> vSing ==<< (reval v, reval tv) - VIrr -> return u - v -> throwErrorMsg $ "NYI : reval " ++ show v - - --- TODO: singleton Sigma types --- = 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 - -- throwErrorMsg $ "panic: whnf " ++ show e ++ " : no measure in environment " ++ show env - Just muv' -> return $ VGuard (Bound Lt muv muv') bv - - Quant Pi (TBound (Bound ltle mu mu')) b -> do - muv <- whnfMeasure env mu - muv' <- whnfMeasure env mu' - bv <- whnf env b -- not adding measure constraint to context! - return $ VGuard (Bound ltle muv muv') bv - - Sing e t -> do tv <- whnf env t - sing env e tv - - Pair e1 e2 -> VPair <$> whnf env e1 <*> whnf env e2 - Proj fx n -> return $ VProj fx n - - Record ri@(NamedRec Cons _ _ _) rs -> VRecord ri <$> mapAssocM (whnf env) rs - - -- coinductive and anonymous records are treated lazily: - Record ri rs -> return $ VRecord ri $ mapAssoc (mkClos env) rs - -{- --- ALT: filter out all erased arguments from application - App e1 el -> do v1 <- whnf env e1 - vl <- liftM (filter (/= VIrr)) $ mapM (whnf env) el - app v1 vl --} - App f e -> do vf <- whnf env f - let ve = mkClos env e - app vf ve -{- - App e1 el -> do v1 <- whnf env e1 - vl <- mapM (whnf env) el - app v1 vl --} - - Case e (Just t) cs -> do - v <- whnf env e - vt <- whnf env t - evalCase v vt env cs - -- trace ("case head evaluates to " ++ showVal v) $ return () - - Sort s -> whnfSort env s >>= return . vSort - Infty -> return VInfty - Zero -> return VZero - Succ e1 -> do v <- whnf env e1 -- succ is strict - return $ succSize v - - Max es -> do vs <- mapM (whnf env) es -- max is strict - return $ maxSize vs - Plus es -> do vs <- mapM (whnf env) es -- plus is strict - return $ plusSizes vs - - Def (DefId LetK n) -> do - item <- lookupSymbQ n - whnfClos (definingVal item) - - Def (DefId (ConK DefPat) n) -> whnfClos . definingVal =<< lookupSymbQ n --- Def (DefId (ConK DefPat) n) -> throwErrorMsg $ "internal error: whnf of defined pattern " ++ show n - Def id -> return $ vDef id -{- - Con co n -> return $ VCon co n - - Def n -> return $ VDef n - - Let n -> do sig <- gets signature - let (LetSig _ v) = lookupSig n sig - return v --- let (LetSig _ e) = lookupSig n sig --- whnf [] e --} - Var y -> lookupEnv env y >>= whnfClos - Ann e -> whnf env (unTag e) -- return VIrr -- NEED TO KEEP because of eta-exp! - Irr -> return VIrr - e -> throwErrorMsg $ "NYI whnf " ++ show e - -whnfMeasure :: Env -> Measure Expr -> TypeCheck (Measure Val) -whnfMeasure rho (Measure mu) = mapM (whnf rho) mu >>= return . Measure - -whnfSort :: Env -> Sort Expr -> TypeCheck (Sort Val) -whnfSort rho (SortC c) = return $ SortC c -whnfSort rho (CoSet e) = whnf rho e >>= return . CoSet -whnfSort rho (Set e) = whnf rho e >>= return . Set - -whnfClos :: Clos -> TypeCheck Val -whnfClos v = -- trace ("whnfClos " ++ show v) $ - case v of - (VClos e rho) -> whnf e rho - -- (VApp (VProj Pre n) [u]) -> app u (VProj Post n) -- NO EFFECT - (VApp (VDef (DefId FunK n)) vl) -> appDef n vl -- THIS IS TO SOLVE A PROBLEM - v -> return v -{- THE PROBLEM IS that - (tail (x Up Stream)) Up Stream is a whnf, because Up Stream is lazy - in equality checking this is a problem when the Up is removed. --} - --- evaluate in standard environment -whnf' :: Expr -> TypeCheck Val -whnf' e = do - env <- getEnv - whnf env e - --- = 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 (throwErrorMsg $ "app: projection " ++ show n ++ " not found in " ++ show u) - whnfClos (lookup n rho) - VDef (DefId FunK n) -> appDef_ n [v] - VApp (VDef (DefId FunK n)) vl -> appDef_ n (vl ++ [v]) - VApp h@(VDef (DefId (ConK Cons) n)) vl -> do - v <- whnfClos v -- inductive constructors are strict! - return $ VApp h (vl ++ [v]) --- VDef n -> appDef n [v] --- VApp (VDef id) vl -> VApp (VDef id) (vl ++ [v]) - VApp v1 vl -> return $ VApp v1 (vl ++ [v]) - --- VSing is a type! --- VSing u (VQuant Pi x dom fu) -> vSing <$> app u v <*> app fu v - - VLam x env e -> whnf (update env x v) e - VConst u -> whnfClos u - VAbs x i u valu -> flip reval' u =<< updateValu valu i v - VUp u (VQuant Pi x dom fu) -> up False ==<< (app u v, app fu v) - -{- - VUp u1 (VQuant Pi x dom rho b) -> do -{- --- ALT: erased functions are not applied to their argument! - v1 <- if erased dec then return v else app v [w] -- eta-expand w ?? --} - v1 <- app u1 v -- eta-expand v ?? - bv <- whnf (update rho x v) b - up False v1 bv --} - VUp u1 (VApp (VDef (DefId DatK n)) vl) -> do - u' <- force u - app u' v - - VIrr -> return VIrr -{- 2010-11-01 this breaks extraction for System U example - VIrr -> throwErrorMsg $ "app internal error: " ++ show (VApp u [v]) --} - _ -> return $ VApp u [v] --- --- app :: Val -> [Val] -> TypeCheck Val --- app u [] = return $ u --- app u c = do --- case (u,c) of --- (VApp u2 c2,_) -> app u2 (c2 ++ c) --- (VLam x env e,(v:vl)) -> do v' <- whnf (update env x v) e --- app v' vl --- (VDef n,_) -> appDef n c --- (VUp v (VPi dec x av rho b), w:wl) -> do --- {- --- -- ALT: erased functions are not applied to their argument! --- v1 <- if erased dec then return v else app v [w] -- eta-expand w ?? --- -} --- v1 <- app v [w] -- eta-expand w ?? --- bv <- whnf (update rho x w) b --- v2 <- up v1 bv --- app v2 wl --- {- --- -- ALT: VIrr consumes applications --- (VIrr,_) -> return VIrr --- -} --- (VIrr,_) -> throwErrorMsg $ "app internal error: " ++ show (VApp u c) --- _ -> return $ VApp u c - - --- unroll a corecursive definition one time (until constructor appears) -force' :: Bool -> Val -> TypeCheck (Bool, Val) -force' b (VSing v tv) = do -- for singleton types, force type! - (b',tv') <- force' b tv - return (b', VSing v tv') -force' b (VUp v tv) = up True v tv >>= \ v' -> return (True, v') -- force eta expansion -force' b (VClos rho e) = do - v <- whnf rho e - force' b v -force' b v@(VDef (DefId FunK n)) = failValInv v -{- - --trace ("force " ++ show v) $ - do sig <- gets signature - case lookupSig n sig of - (FunSig CoInd t cl True) -> do m <- matchClauses [] cl [] - case m of - Just v' -> force v' - Nothing -> return v - _ -> return v --} -force' b v@(VApp (VDef (DefId FunK n)) vl) = enterDoc (text "force" <+> prettyTCM v) $ - do sig <- gets signature - case Map.lookup n sig of - Just (FunSig isCo t ki ar cl True _) -> traceMatch ("forcing " ++ show v) $ - do m <- matchClauses emptyEnv cl vl - case m of - Just v' -> traceMatch ("forcing " ++ show n ++ " succeeded") $ - force' True v' - Nothing -> traceMatch ("forcing " ++ show n ++ " failed") $ - return (b, v) - _ -> return (b, v) -force' b v = return (b, v) - -force :: Val -> TypeCheck Val -force v = -- trace ("forcing " ++ show v) $ - liftM snd $ force' False v - --- apply a recursive function --- corecursive ones are not expanded even if the arity is exceeded --- this is because a coinductive type needs to be destructed by pattern matching -appDef :: QName -> [Val] -> TypeCheck Val -appDef n vl = --trace ("appDef " ++ n) $ - do - -- identifier might not be in signature yet, e.g. ind.-rec.def. - sig <- gets signature - case (Map.lookup n sig) of - Just (FunSig { isCo = Ind, arity = ar, clauses = cl, isTypeChecked = True }) - | length vl >= fullArity ar -> do - m <- matchClauses emptyEnv cl vl - case m of - Nothing -> return $ VApp (VDef (DefId FunK n)) vl - Just v2 -> return v2 - _ -> return $ VApp (VDef (DefId FunK n)) vl - --- reflection and reification --------------------------------------- - --- TODO: eta for builtin sigma-types !? - --- up force v tv --- force==True also expands at coinductive type -up :: Bool -> Val -> TVal -> TypeCheck Val -up f (VUp v tv') tv = up f v tv -up f v tv@VQuant{ vqPiSig = Pi } = return $ VUp v tv -up f _ (VSing v vt) = up f v vt -up f v (VDef d) = failValInv $ VDef d -up f v (VApp (VDef (DefId DatK d)) vl) = upData f v d vl -up f v _ = return v - -{- Most of the code to eta expand on data types is in - TypeChecker.hs "typeCheckDeclaration" - - Currently, eta expansion only happens at data *types* with exactly -one constructor. In a first step, this will be extended to -non-recursive pattern inductive families. - -The strategy is: match type value with result type for all the constructors -0. if there are no matches, eta expand to * (VIrr) -1. if there is exactly one match, eta expand accordingly using destructors -2. if there are more matches, do not eta-expand - -up{Vec A (suc n)} x = vcons A n (head A n x) (tail A n x) - -up{Vec Bool (suc zero)} x - = vcons Bool zero (head Bool zero x) (tail Bool zero x) - -For vcons -- the patterns of Vec : (A : Set) -> Nat -> Set are [A,suc n] -- matching Bool,suc zero against A,suc n yields A=Bool,n=zero -- this means we can eta expand to vcons -- go through the fields of vcons - - if Index use value obtained by matching - - if Field destr, use destr x - --} - --- matchingConstructors is for use in checkPattern --- matchingConstructors (D vs) returns all the constructors --- each as tuple (ci,rho) --- of family D whose target matches (D vs) under substitution rho -matchingConstructors :: Val -> TypeCheck (Maybe [(ConstructorInfo,Env)]) -matchingConstructors v@(VDef d) = failValInv v -- matchingConstructors' d [] -matchingConstructors (VApp (VDef (DefId DatK d)) vl) = matchingConstructors' d vl >>= return . Just -matchingConstructors v = return Nothing --- throwErrorMsg $ "matchingConstructors: not a data type: " ++ show v -- return [] - -matchingConstructors' :: QName -> [Val] -> TypeCheck [(ConstructorInfo,Env)] -matchingConstructors' n vl = do - sige <- lookupSymbQ n - case sige of - (DataSig {symbTyp = dv, constructors = cs}) -> -- if (null cs) then ret [] else do -- no constructor - matchingConstructors'' True vl dv cs - --- matchingConstructors'' --- Arguments: --- symm symmetric match --- vl arguments to D (instance of D) --- dv complete type value of D --- cs constructors --- Returns a list [(ci,rho)] of matching constructors together with the --- environments which are solutions for the free variables in the constr.type --- this is also for use in upData -matchingConstructors'' :: Bool -> [Val] -> Val -> [ConstructorInfo] -> TypeCheck [(ConstructorInfo,Env)] -matchingConstructors'' symm vl dv cs = do - vl <- mapM whnfClos vl - compressMaybes <$> do - forM cs $ \ ci -> do - let ps = snd (cPatFam ci) - -- list of patterns ps where D ps is the constructor target - fmap (ci,) <$> nonLinMatchList symm emptyEnv ps vl dv - - -data MatchingConstructors a - = NoConstructor - | OneConstructor a - | ManyConstructors - | UnknownConstructors - deriving (Eq,Show) - -getMatchingConstructor - :: Bool -- eta : must the field etaExpand be set of the data type - -> QName -- d : the name of the data types - -> [Val] -- vl : the arguments of the data type - -> TypeCheck (MatchingConstructors - ( Co -- co : coinductive type? - , [Val] -- parvs : the parameter half of the arguments - , Env -- rho : the substitution for the index variables to arrive at d vl - , [Val] -- indvs : the index values of the constructor - , ConstructorInfo -- ci : the only matching constructor - )) -getMatchingConstructor eta n vl = traceRecord ("getMatchingConstructor " ++ show (n, vl)) $ - do - -- when checking a mutual data decl, the sig entry of the second data - -- is not yet in place when checking the first, thus, lookup may fail - sig <- gets signature - case Map.lookup n sig of - Just (DataSig {symbTyp = dv, numPars = npars, isCo = co, constructors = cs, etaExpand}) | eta `implies` etaExpand -> - if (null cs) then return NoConstructor else do -- no constructor: empty type - -- for each constructor, match its core against the type - -- produces a list of maybe (c.info, environment) - cenvs <- matchingConstructors'' False vl dv cs - traceRecordM $ "Matching constructors: " ++ show cenvs - case cenvs of - -- exactly one matching constructor: can eta expand --- [(ci,env)] -> if not (eta `implies` cEtaExp ci) then return UnknownConstructors else do - [(ci,env)] -> if eta && not (cEtaExp ci) then return UnknownConstructors else do - -- get list of index values from environment - let fis = cFields ci - let indices = filter (\ fi -> fClass fi == Index) fis - let indvs = map (\ fi -> lookupPure env (fName fi)) indices - let (pars, _) = splitAt npars vl - return $ OneConstructor (co, pars, env, indvs, ci) - -- more or less than one matching constructors: cannot eta expand - l -> -- trace ("getMatchingConstructor: " ++ show (length l) ++ " patterns match at type " ++ show n ++ show vl) $ - return ManyConstructors - _ -> traceRecord ("no eta expandable type") $ return UnknownConstructors - -getFieldsAtType - :: QName -- d : the name of the data types - -> [Val] -- vl : the arguments of the data type - -> TypeCheck - (Maybe -- Nothing if not a record type - [(Name -- list of projection names - ,TVal)]) -- and their instantiated type R ... -> C -getFieldsAtType n vl = do - mc <- getMatchingConstructor False n vl - case mc of - OneConstructor (_, pars, _, indvs, ci) -> do - let pi = pars ++ indvs - -- for each argument of constructor, get value - let arg (FieldInfo { fName = x, fClass = Index }) = return [] - arg (FieldInfo { fName = d, fClass = Field _ }) = do - -- lookup type sig t of destructor d - t <- lookupSymbTyp d - -- pi-apply destructor type to parameters and indices - t' <- piApps t pi - return [(d,t')] - Just . concat <$> mapM arg (cFields ci) - _ -> return Nothing - --- similar to piApp, but for record types and projections -projectType :: TVal -> Name -> Val -> TypeCheck TVal -projectType tv p rv = do - let fail1 = failDoc (text "expected record type when taking the projection" <+> prettyTCM (Proj Post p) <> comma <+> text "but found type" <+> prettyTCM tv) - let fail2 = failDoc (text "record type" <+> prettyTCM tv <+> text "does not have field" <+> prettyTCM p) - case tv of - VApp (VDef (DefId DatK d)) vl -> do - mfs <- getFieldsAtType d vl - case mfs of - Nothing -> fail1 - Just ptvs -> - case lookup p ptvs of - Nothing -> fail2 - Just tv -> piApp tv rv -- apply to record arg - _ -> fail1 - --- eta expand v at data type n vl -upData :: Bool -> Val -> QName -> [Val] -> TypeCheck Val -upData force v n vl = -- trace ("upData " ++ show v ++ " at " ++ n ++ show vl) $ - do - let ret v' = traceEta ("Eta-expanding: " ++ show v ++ " --> " ++ show v' ++ " at type " ++ show n ++ show vl) $ return v' - mc <- getMatchingConstructor True n vl - case mc of - NoConstructor -> ret VIrr - OneConstructor (co, pars, env, indvs, ci) -> - -- lazy eta-expansion for coinductive records like streams! - if (co==CoInd && not force) then return $ VUp v (VApp (VDef $ DefId DatK n) vl) else do - -- get list of index values from environment - let fis = cFields ci - let piv = pars ++ indvs ++ [v] - -- for each argument of constructor, get value - let arg (FieldInfo { fName = x, fClass = Index }) = - lookupEnv env x - arg (FieldInfo { fName = d, fClass = Field _ }) = do - -- lookup type sig t of destructor d - LetSig {symbTyp = t, definingVal = w} <- lookupSymb d - -- pi-apply destructor type to parameters, indices and value v - t' <- piApps t piv - -- recursively eta expand (d 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 = throwErrorMsg $ "matchList internal error: inequal length while trying to match patterns " ++ show pl ++ " against values " ++ show vl - --- * Typed Non-linear Matching ----------------------------------------- - -type GenToPattern = [(Int,Pattern)] -type MatchState = (Env, GenToPattern) - --- @nonLinMatch True@ allows also instantiation in v0 --- this is useful for finding all matching constructors --- for an erased argument in checkPattern -nonLinMatch :: Bool -> Bool -> MatchState -> Pattern -> Val -> TVal -> TypeCheck (Maybe MatchState) -nonLinMatch undot symm st p v0 tv = traceMatch ("matching pattern " ++ show (p,v0)) $ do - -- force against constructor pattern - v <- case p of - ConP{} -> force v0 - PairP{} -> force v0 - _ -> whnfClos v0 - case (p,v) of - (ErasedP{}, _) -> return $ Just st - (DotP{} , _) -> return $ Just st - (_, VGen i) | symm -> return $ Just $ mapSnd ((i,p):) st -- no check in case of non-lin! - (VarP x, _) -> matchVarP x v - (SizeP _ x, _) -> matchVarP x v - (ProjP x, VProj Post y) | x == y -> return $ Just st - (ConP _ c pl, VApp (VDef (DefId (ConK _) c')) vl) | nameInstanceOf c c' -> do - vc <- conLType c tv - nonLinMatchList' undot symm st pl vl vc - -- Here, we do accept dotted constructors, since we are abusing this for unification. - (ConP _ c pl, VRecord (NamedRec _ c' _ dotted) rs) | nameInstanceOf c c' -> do - when undot $ clearDotted dotted - vc <- conLType c tv - nonLinMatchList' undot symm st pl (map snd rs) vc - -- if the match against an unconfirmed constructor - -- we can succeed, but not compute a sensible environment - (_, VRecord (NamedRec _ c' _ dotted) rs) | isDotted dotted && not undot -> return $ Just st - (p@(ConP pi _ _), v) | coPat pi == DefPat -> do - p <- expandDefPat p - nonLinMatch undot symm st p v tv - (PairP p1 p2, VPair v1 v2) -> do - tv <- force tv - case tv of - VQuant Sigma x dom fv -> do - nonLinMatch undot symm st p1 v1 (typ dom) `bindMaybe` \ st -> do - nonLinMatch undot symm st p2 v2 =<< app fv v1 - _ -> failDoc $ text "nonLinMatch: expected" <+> prettyTCM tv <+> text "to be a Sigma-type (&)" - (SuccP p', v) -> (predSize <$> whnfClos v) `bindMaybe` \ v' -> - nonLinMatch undot symm st p' v' tv - _ -> return Nothing - where - -- Check that the previous solution for @x@ is equal to @v@. - -- Here, we need the type! - matchVarP x v = do - let env = fst st - case find ((x ==) . fst) $ envMap $ fst st of - Nothing -> return $ Just $ mapFst (\ env -> update env x v) st - Just (y,v') -> ifM (eqValBool tv v v') (return $ Just st) (return Nothing) - --- nonLinMatchList symm env ps vs tv --- typed non-linear matching of patterns ps against values vs at type tv --- env is the accumulator for the solution of the matching -nonLinMatchList :: Bool -> Env -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe Env) -nonLinMatchList symm env ps vs tv = - fmap fst <$> nonLinMatchList' False symm (env, []) ps vs tv - -nonLinMatchList' :: Bool -> Bool -> MatchState -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe MatchState) -nonLinMatchList' undot symm st [] [] tv = return $ Just st -nonLinMatchList' undot symm st (p:pl) (v:vl) tv = do - tv <- force tv - case tv of - VQuant Pi x dom fv -> - nonLinMatch undot symm st p v (typ dom) `bindMaybe` \ st' -> - nonLinMatchList' undot symm st' pl vl =<< app fv v - _ -> throwErrorMsg $ "nonLinMatchList': cannot match in absence of pi-type" -nonLinMatchList' _ _ _ _ _ _ = return Nothing - - --- | Expand a top-level pattern synonym -expandDefPat :: Pattern -> TypeCheck Pattern -expandDefPat p@(ConP pi c ps) | coPat pi == DefPat = do - PatSig ns pat v <- lookupSymbQ c - unless (length ns == length ps) $ - throwErrorMsg ("underapplied defined pattern in " ++ show p) - let pat' = if dottedPat pi then dotConstructors pat else pat - return $ patSubst (zip ns ps) pat' -expandDefPat p = return p - ---------------------------------------------------------------------------- --- * Unification ---------------------------------------------------------------------------- - -instance Monoid (TypeCheck Bool) where - mempty = return True - mappend = andLazy - mconcat = andM - --- | Occurrence check @nocc ks v@ (used by 'SPos' and 'TypeCheck'). --- Checks that generic values @ks@ does not occur in value @v@. --- In the process, @tv@ is normalized. -class Nocc a where - nocc :: [Int] -> a -> TypeCheck Bool - -instance Nocc a => Nocc [a] where - nocc = foldMap . nocc - -instance Nocc a => Nocc (Dom a) where - nocc = foldMap . nocc - -instance Nocc a => Nocc (Measure a) where - nocc = foldMap . nocc - -instance Nocc a => Nocc (Bound a) where - nocc = foldMap . nocc - -instance (Nocc a, Nocc b) => Nocc (a,b) where - nocc ks (a, b) = nocc ks a `andLazy` nocc ks b - -instance Nocc a => Nocc (Sort a) where - nocc ks (Set v) = nocc ks v - nocc ks (CoSet v) = nocc ks v - nocc ks (SortC _) = mempty - -instance Nocc Val where - nocc ks v = do - -- traceM ("nocc " ++ show v) - v <- whnfClos v - case v of - -- neutrals - VGen k -> return $ not $ k `elem` ks - VApp v1 vl -> nocc ks $ v1 : vl - VDef{} -> mempty - VProj{} -> mempty - -- Binders: - -- ALT: do not evaluate under binders (just check environment). - -- This is less precise but more efficient. Can give false alarms. - -- Still sound. (Should maybe done first, like in Agda). - VQuant pisig x dom fv -> nocc ks dom `mappend` do - underAbs x dom fv $ \ _i _xv bv -> nocc ks bv - fv@(VLam x env b) -> underAbs' x fv $ \ _xv bv -> nocc ks bv - fv@(VAbs x i u valu) -> underAbs' x fv $ \ _xv bv -> nocc ks bv - fv@(VConst v) -> underAbs' noName fv $ \ _xv bv -> nocc ks bv - -- pairs - VRecord _ rs -> nocc ks $ map snd rs - VPair v w -> nocc ks (v, w) - -- sizes - VZero -> mempty - VSucc v -> nocc ks v - VInfty -> mempty - VMax vl -> nocc ks vl - VPlus vl -> nocc ks vl - VSort s -> nocc ks s - VMeasured mu tv -> nocc ks (mu, tv) - VGuard beta tv -> nocc ks (beta, tv) - VBelow ltle v -> nocc ks v - VSing v tv -> nocc ks (v, tv) - VUp v tv -> nocc ks (v, tv) - VIrr -> mempty - VCase v tv env cls -> nocc ks $ v : tv : map snd (envMap env) - -- impossible: closure (reduced away) - VClos{} -> throwErrorMsg $ "internal error: nocc " ++ show (ks,v) - - --- heterogeneous typed equality and subtyping ------------------------ - -eqValBool :: TVal -> Val -> Val -> TypeCheck Bool -eqValBool tv v v' = errorToBool $ eqVal tv v v' --- eqValBool tv v v' = (eqVal tv v v' >> return True) `catchError` (\ _ -> return False) - -eqVal :: TVal -> Val -> Val -> TypeCheck () -eqVal tv = leqVal' N mixed (Just (One tv)) - - --- force history -data Force = N | L | R -- not yet, left , right - deriving (Eq,Show) - -class Switchable a where - switch :: a -> a - -instance Switchable Force where - switch L = R - switch R = L - switch N = N - -instance Switchable Pol where - switch = polNeg - -instance Switchable (a,a) where - switch (a,b) = (b,a) - -instance Switchable a => Switchable (Maybe a) where - switch = fmap switch - -{- --- WONTFIX: FOR THE FOLLOWING TO BE SOUND, ONE NEEDS COERCIVE SUBTYPING! --- the problem is that after extraction, erased arguments are gone! --- a function which does not use its argument can be used as just a function --- [A] -> A <= A -> A --- A <= [A] -leqDec :: Pol -> Dec -> Dec -> Bool -leqDec SPos dec1 dec2 = erased dec2 || not (erased dec1) -leqDec Neg dec1 dec2 = erased dec1 || not (erased dec2) -leqDec mixed dec1 dec2 = erased dec1 == erased dec2 --} - --- subtyping for erasure disabled --- but subtyping for polarities! -leqDec :: Pol -> Dec -> Dec -> Bool -leqDec p dec1 dec2 = erased dec1 == erased dec2 - && relPol p leqPol (polarity dec1) (polarity dec2) - --- subtyping --------------------------------------------------------- - -subtype :: Val -> Val -> TypeCheck () -subtype v1 v2 = -- enter ("subtype " ++ show v1 ++ " <= " ++ show v2) $ - leqVal' N Pos Nothing v1 v2 - --- Pol ::= Pos | Neg | mixed -leqVal :: Pol -> TVal -> Val -> Val -> TypeCheck () -leqVal p tv = leqVal' N p (Just (One tv)) - -type MT12 = Maybe (OneOrTwo TVal) - --- view the shape of a type or a pair of types -data TypeShape - = ShQuant PiSigma - (OneOrTwo Name) - (OneOrTwo Domain) - (OneOrTwo FVal) -- both are function types - | ShSort SortShape -- sort of same shape - | ShData QName (OneOrTwo TVal)-- same data, but with possibly different args - | ShNe (OneOrTwo TVal) -- both neutral - | ShSing Val TVal -- 1 and singleton - | ShSingL Val TVal TVal -- 2 and the left is a singleton - | ShSingR TVal Val TVal -- 2 and the right is a singleton - | ShNone - deriving (Eq, Ord) - -data SortShape - = ShSortC Class -- same sort constant - | ShSet (OneOrTwo Val) -- Set i and Set j - | ShCoSet (OneOrTwo Val) -- CoSet i and CoSet j - deriving (Eq, Ord) - -shSize = ShSort (ShSortC Size) - --- typeView does not normalize! -typeView :: TVal -> TypeShape -typeView tv = - case tv of - VQuant pisig x dom fv -> ShQuant pisig (One x) (One dom) (One fv) - VBelow{} -> shSize - VSort s -> ShSort (sortView s) - VSing v tv -> ShSing v tv - VApp (VDef (DefId DatK n)) vs -> ShData n (One tv) - VApp (VDef (DefId FunK n)) vs -> ShNe (One tv) -- stuck fun - VApp (VGen i) vs -> ShNe (One tv) -- type variable - VGen i -> ShNe (One tv) -- type variable - VCase{} -> ShNe (One tv) -- stuck case - _ -> ShNone -- error $ "typeView " ++ show tv - -sortView :: Sort Val -> SortShape -sortView s = - case s of - SortC c -> ShSortC c - Set v -> ShSet (One v) - CoSet v -> ShCoSet (One v) - -typeView12 :: (Functor m, Monad m, MonadError TraceError m) => OneOrTwo TVal -> m TypeShape --- typeView12 :: OneOrTwo TVal -> TypeCheck TypeShape -typeView12 (One tv) = return $ typeView tv -typeView12 (Two tv1 tv2) = - case (tv1, tv2) of - (VQuant pisig1 x1 dom1 fv1, VQuant pisig2 x2 dom2 fv2) - | pisig1 == pisig2 && erased (decor dom1) == erased (decor dom2) -> - return $ ShQuant pisig1 (Two x1 x2) (Two dom1 dom2) (Two fv1 fv2) - (VSort s1, VSort s2) -> ShSort <$> sortView12 (Two s1 s2) - (VSing v tv, _) -> return $ ShSingL v tv tv2 - (_, VSing v tv) -> return $ ShSingR tv1 v tv - _ -> case (typeView tv1, typeView tv2) of - (ShSort s1, ShSort s2) | s1 == s2 -> return $ ShSort $ s1 - (ShData n1 _, ShData n2 _) | n1 == n2 -> return $ ShData n1 (Two tv1 tv2) - (ShNe{} , ShNe{} ) -> return $ ShNe (Two tv1 tv2) - _ -> throwErrorMsg $ "type " ++ show tv1 ++ " has different shape than " ++ show tv2 - -sortView12 :: (Monad m, MonadError TraceError m) => OneOrTwo (Sort Val) -> m SortShape -sortView12 (One s) = return $ sortView s -sortView12 (Two s1 s2) = - case (s1, s2) of - (SortC c1, SortC c2) | c1 == c2 -> return $ ShSortC c1 - (Set v1, Set v2) -> return $ ShSet (Two v1 v2) - (CoSet v1, CoSet v2) -> return $ ShCoSet (Two v1 v2) - _ -> throwErrorMsg $ "sort " ++ show s1 ++ " has different shape than " ++ show s2 - -whnf12 :: OneOrTwo Env -> OneOrTwo Expr -> TypeCheck (OneOrTwo Val) -whnf12 env12 e12 = Traversable.traverse id $ zipWith12 whnf env12 e12 - -app12 :: OneOrTwo Val -> OneOrTwo Val -> TypeCheck (OneOrTwo Val) -app12 fv12 v12 = Traversable.traverse id $ zipWith12 app fv12 v12 - --- if m12 = Nothing, we are checking subtyping, otherwise we are --- comparing objects or higher-kinded types --- if two types are given (heterogeneous equality), they need to be --- of the same shape, otherwise they cannot contain common terms -leqVal' :: Force -> Pol -> MT12 -> Val -> Val -> TypeCheck () -leqVal' f p mt12 u1' u2' = local (\ cxt -> cxt { consistencyCheck = False }) $ do - -- 2013-03-30 During subtyping, it is fine to add any size hypotheses. - l <- getLen - ren <- getRen - enterDoc (case mt12 of - Nothing -> -- text ("leqVal' (subtyping) " ++ show (Map.toList $ ren) ++ " |-") - text "leqVal' (subtyping) " - <+> prettyTCM u1' <+> text (" <=" ++ show p ++ " ") - <+> prettyTCM u2' - Just (One tv) -> -- text ("leqVal' " ++ show (Map.toList $ ren) ++ " |-") - text "leqVal' " - <+> prettyTCM u1' <+> text (" <=" ++ show p ++ " ") - <+> prettyTCM u2' <+> colon - <+> prettyTCM tv - Just (Two tv1 tv2) -> -- text ("leqVal' " ++ show (Map.toList $ ren) ++ " |-") - text "leqVal' " - <+> prettyTCM u1' <+> colon - <+> prettyTCM tv1 <+> text (" <=" ++ show p ++ " ") - <+> prettyTCM u2' <+> colon - <+> prettyTCM tv2) $ do -{- - ce <- ask - trace (("rewrites: " +?+ show (rewrites ce)) ++ " leqVal': " ++ show ce ++ "\n |- " ++ show u1' ++ "\n <=" ++ show p ++ " " ++ show u2') $ --} - mt12f <- mapM (mapM force) mt12 -- leads to LOOP, see HungryEta.ma - sh12 <- case mt12f of - Nothing -> return Nothing - Just tv12 -> case runExcept $ typeView12 tv12 of - Right sh -> return $ Just sh - Left err -> (recoverFail $ show err) >> return Nothing - case sh12 of - - -- subtyping directed by common type shape - - Just (ShSing{}) -> return () -- two terms are equal at singleton type! - Just (ShSingL v1 tv1' tv2) -> leqVal' f p (Just (Two tv1' tv2)) v1 u2' - Just (ShSingR tv1 v2 tv2') -> leqVal' f p (Just (Two tv1 tv2')) u1' v2 - Just (ShSort (ShSortC Size)) -> leqSize p u1' u2' - -{- functions are compared pointwise - - Gamma, p(x:A) |- t x : B <= Gamma', p'(x:A') |- t' x : B' - ---------------------------------------------------------- - Gamma |- t : p(x:A) -> B <= Gamma' |- t' : p'(x:A') -> B' --} - Just (ShQuant Pi x12 dom12 fv12) -> do - x <- do - let x = name12 x12 - if null (suggestion x) then do - case (u1', u2') of - (VLam x _ _, _) -> return x - (_, VLam x _ _) -> return x - _ -> return x - else return x - newVar x dom12 $ \ _ xv12 -> do - u1' <- app u1' (first12 xv12) - u2' <- app u2' (second12 xv12) - tv12 <- app12 fv12 xv12 - leqVal' f p (Just tv12) u1' u2' -{- - Just (VPi x1 dom1 env1 b1, VPi x2 dom2 env2 b2) -> - new2 x1 (dom1, dom2) $ \ (xv1, xv2) -> do - u1' <- app u1' xv1 - u2' <- app u2' xv2 - tv1' <- whnf (update env1 x1 xv1) b1 - tv2' <- whnf (update env2 x2 xv2) b2 - leqVal' f p (Just (tv1', tv2')) u1' u2' --} - - - -- structural subtyping (not directed by types) - - _ -> do - u1 <- reduce =<< whnfClos u1' - u2 <- reduce =<< whnfClos u2' - - let tryForcing fallback = do - (f1,u1f) <- force' False u1 - (f2,u2f) <- force' False u2 - case (f1,f2) of -- (u1f /= u1,u2f /= u2) of - - (True,False) | f /= R -> -- only unroll one side - enter ("forcing LHS") $ - leqVal' L p mt12 u1f u2 - (False,True) | f /= L -> - enter ("forcing RHS") $ - leqVal' R p mt12 u1 u2f - _ -> -- enter ("not forcing " ++ show (f1,f2,f)) $ - fallback - - leqCons n1 vl1 n2 vl2 = do - unless (n1 == n2) $ - recoverFail $ - "leqVal': head mismatch " ++ show u1 ++ " != " ++ show u2 - case mt12 of - Nothing -> recoverFail $ "leqVal': cannot compare constructor terms without type" - Just tv12 -> do - ct12 <- Traversable.mapM (conType n1) tv12 - leqVals' f p ct12 vl1 vl2 - return () -{- - leqStructural u1 u2 where - leqStructural u1 u2 = --} - case (u1,u2) of - -{- - C = C' (proper: C' entails C, but I do not want to implement entailment) - Gamma, C |- A <= Gamma', C' |- A' - ----------------------------------------- - Gamma |- C ==> A <= Gamma' |- C' ==> A' --} - (VGuard beta1 bv1, VGuard beta2 bv2) -> do - entailsGuard (switch p) beta1 beta2 - leqVal' f p Nothing bv1 bv2 - - (VGuard beta u1, u2) | p `elem` [Neg,Pos] -> - addOrCheckGuard (switch p) beta $ - leqVal' f p Nothing u1 u2 - - (u1, VGuard beta u2) | p `elem` [Neg,Pos] -> - addOrCheckGuard p beta $ - leqVal' f p Nothing u1 u2 - {- - p' <= p - Gamma' |- A' <= Gamma |- A - Gamma, p(x:A) |- B <= Gamma', p'(x:A') |- B' - --------------------------------------------------------- - Gamma |- p(x:A) -> B : s <= Gamma' |- p'(x:A') -> B' : s' --} - (VQuant piSig1 x1 dom1@(Domain av1 _ dec1) fv1, - VQuant piSig2 x2 dom2@(Domain av2 _ dec2) fv2) -> do - let p' = if piSig1 == Pi then switch p else p - if piSig1 /= piSig2 || not (leqDec p' dec1 dec2) then - recoverFailDoc $ text "subtyping" <+> prettyTCM u1 <+> text (" <=" ++ show p ++ " ") <+> prettyTCM u2 <+> text "failed" - else do - leqVal' (switch f) p' Nothing av1 av2 - -- take smaller domain - let dom = if (p' == Neg) then dom2 else dom1 - let x = bestName $ if p' == Neg then [x2,x1] else [x1,x2] - new x dom $ \ xv -> do - bv1 <- app fv1 xv - bv2 <- app fv2 xv - enterDoc (text "comparing codomain" <+> prettyTCM bv1 <+> text "with" <+> prettyTCM bv2) $ - leqVal' f p Nothing bv1 bv2 - - (VSing v1 av1, VSing v2 av2) -> do - leqVal' f p Nothing av1 av2 - leqVal' N mixed (Just (Two av1 av2)) v1 v2 -- compare for eq. - - (VSing v1 av1, VBelow ltle v2) | av1 == vSize && p == Pos -> do - v1 <- whnfClos v1 - leSize ltle p v1 v2 - -{- 2012-01-28 now vSize is VBelow Le Infty - - -- extra cases since vSize is not implemented as VBelow Le Infty - (u1,u2) | isVSize u1 && isVSize u2 -> return () - (VSort (SortC Size), VBelow{}) -> leqStructural (VBelow Le VInfty) u2 - (VBelow{}, VSort (SortC Size)) -> leqStructural u1 (VBelow Le VInfty) --} - -- care needed to not make <=# a subtype of <# - (VBelow ltle1 v1, VBelow ltle2 v2) -> - case (p, ltle1, ltle2) of - _ | ltle1 == ltle2 -> leSize Le p v1 v2 - (Neg, Le, Lt) -> leSize Le p (vSucc v1) v2 - (Neg, Lt, Le) -> leSize Lt p v1 v2 -- careful here - (p , Lt, Le) -> leSize Le p v1 (vSucc v2) - (p , Le, Lt) -> leSize Lt p v1 v2 -- careful here - - -- unresolved eta-expansions (e.g. at coinductive type) - (VUp v1 av1, VUp v2 av2) -> do - -- leqVal' f p Nothing av1 av2 -- do not compare types - leqVal' f p (Just (Two av1 av2)) v1 v2 -- OR: Just(tv1,tv2) ? - (VUp v1 av1, u2) -> leqVal' f p mt12 v1 u2 - (u1, VUp v2 av2) -> leqVal' f p mt12 u1 v2 - - (VRecord (NamedRec _ n1 _ _) rs1, VRecord (NamedRec _ n2 _ _) rs2) -> - leqCons n1 (map snd rs1) n2 (map snd rs2) - -{- - -- the following three cases should be impossible - -- but aren't. I gave up on this bug -- 2012-01-25 - -- FOUND IT - - (VRecord (NamedRec _ n1 _) rs1, - VApp v2@(VDef (DefId (ConK _) n2)) vl2) -> leqCons n1 (map snd rs1) n2 vl2 - - (VApp v1@(VDef (DefId (ConK _) n1)) vl1, - VRecord (NamedRec _ n2 _) rs2) -> leqCons n1 vl1 n2 (map snd rs2) - - (VApp v1@(VDef (DefId (ConK _) n1)) vl1, - VApp v2@(VDef (DefId (ConK _) n2)) vl2) -> leqCons n1 vl1 n2 vl2 --} - - -- smart equality is not transitive - (VCase v1 tv1 env1 cl1, VCase v2 tv2 env2 cl2) -> do - leqVal' f p (Just (Two tv1 tv2)) v1 v2 -- FIXED: do not have type here, but v1,v2 are neutral - leqClauses f p mt12 v1 tv1 env1 cl1 env2 cl2 - -{- REMOVED, NOT TRANSITIVE - (VCase v env cl, v2) -> leqCases (switch f) (switch p) (switch mt12) v2 v env cl - (v1, VCase v env cl) -> leqCases f p mt12 v1 v env cl --} - (VSing v1 av1, av2) -> leqVal' f p Nothing av1 av2 -- subtyping ax - (VSort s1, VSort s2) -> leqSort p s1 s2 - (a1,a2) | a1 == a2 -> return () - (u1,u2) -> tryForcing $ - case (u1,u2) of - (VApp v1 vl1, VApp v2 vl2) -> leqApp f p v1 vl1 v2 vl2 - (VApp v1 vl1, u2) -> leqApp f p v1 vl1 u2 [] - (u1, VApp v2 vl2) -> leqApp f p u1 [] v2 vl2 - _ -> leqApp f p u1 [] u2 [] - -leqClauses :: Force -> Pol -> MT12 -> Val -> TVal -> Env -> [Clause] -> Env -> [Clause] -> TypeCheck () -leqClauses f pol mt12 v tvp env1 cls1 env2 cls2 = loop cls1 cls2 where - loop cls1 cls2 = case (cls1,cls2) of - ([],[]) -> return () - (Clause _ [p1] mrhs1 : cls1', Clause _ [p2] mrhs2 : cls2') -> do - ns <- flip execStateT [] $ alphaPattern p1 p2 - case (mrhs1, mrhs2) of - (Nothing, Nothing) -> return () - (Just e1, Just e2) -> do - let tv = maybe vTopSort first12 mt12 - let tv012 = maybe [] toList12 mt12 - addPattern (tvp `arrow` tv) p2 env2 $ \ _ pv env2' -> - addRewrite (Rewrite v pv) tv012 $ \ tv012 -> do - let env1' = env2' { envMap = compAssoc ns (envMap env2') } - v1 <- whnf (appendEnv env1' env1) e1 - v2 <- whnf (appendEnv env2' env2) e2 - leqVal' f pol (toMaybe12 tv012) v1 v2 - loop cls1' cls2' -{- --- naive implementation for now -leqClauses :: Force -> Pol -> MT12 -> Val -> TVal -> Env -> [Clause] -> Env -> [Clause] -> TypeCheck () -leqClauses f pol mt12 v tvp env1 cls1 env2 cls2 = loop cls1 cls2 where - loop cls1 cls2 = case (cls1,cls2) of - ([],[]) -> return () - (Clause _ [p1] mrhs1 : cls1', Clause _ [p2] mrhs2 : cls2') -> do - eqPattern p1 p2 - case (mrhs1, mrhs2) of - (Nothing, Nothing) -> return () - (Just e1, Just e2) -> do - let tv = maybe vTopSort first12 mt12 - let tv012 = maybe [] toList12 mt12 - addPattern (tvp `arrow` tv) p1 env1 $ \ _ pv env' -> - addRewrite (Rewrite v pv) tv012 $ \ tv012 -> do - v1 <- whnf (appendEnv env' env1) e1 - v2 <- whnf (appendEnv env' env2) e2 - leqVal' f pol (toMaybe12 tv012) v1 v2 - loop cls1' cls2' - -eqPattern :: Pattern -> Pattern -> TypeCheck () -eqPattern p1 p2 = if p1 == p2 then return () else throwErrorMsg $ "pattern " ++ show p1 ++ " != " ++ show p2 --} - -type NameMap = [(Name,Name)] - -alphaPattern :: Pattern -> Pattern -> StateT NameMap TypeCheck () -alphaPattern p1 p2 = do - let failure = throwErrorMsg $ "pattern " ++ show p1 ++ " != " ++ show p2 - alpha x1 x2 = do - ns <- get - case lookup x1 ns of - Nothing -> put $ (x1,x2) : ns - Just x2' | x2 == x2' -> return () - | otherwise -> failure - case (p1,p2) of - (VarP x1, VarP x2) -> alpha x1 x2 - (ConP pi1 n1 ps1, ConP pi2 n2 ps2) | pi1 == pi2 && n1 == n2 -> - zipWithM_ alphaPattern ps1 ps2 - (SuccP p1, SuccP p2) -> alphaPattern p1 p2 - (SizeP _ x1, SizeP _ x2) -> alpha x1 x2 - (PairP p11 p12, PairP p21 p22) -> do - alphaPattern p11 p21 - alphaPattern p12 p22 - (ProjP n1, ProjP n2) -> unless (n1 == n2) failure - (DotP _, DotP _) -> return () - (AbsurdP, AbsurdP) -> return () - (ErasedP p1, ErasedP p2) -> alphaPattern p1 p2 - (UnusableP p1, UnusableP p2) -> alphaPattern p1 p2 - _ -> failure - --- leqCases f p tv1 v1 v tv env cl --- checks whether v1 <=p (VCase v tv env cl) : tv1 -leqCases :: Force -> Pol -> MT12 -> Val -> Val -> TVal -> Env -> [Clause] -> TypeCheck () -leqCases f pol mt12 v1 v tvp env cl = do - vcase <- evalCase v tvp env cl - case vcase of - (VCase v tvp env cl) -> mapM_ (leqCase f pol mt12 v1 v tvp env) cl - v2 -> leqVal' f pol mt12 v1 v2 - --- absurd cases need not be checked -leqCase :: Force -> Pol -> MT12 -> Val -> Val -> TVal -> Env -> Clause -> TypeCheck () -leqCase f pol mt12 v1 v tvp env (Clause _ [p] Nothing) = return () -leqCase f pol mt12 v1 v tvp env (Clause _ [p] (Just e)) = enterDoc (text "leqCase" <+> prettyTCM v <+> text " --> " <+> text (show p ++ " |- ") <+> prettyTCM v1 <+> text (" <=" ++ show pol ++ " ") <+> prettyTCM (VClos env e)) $ do -- ++ " : " ++ show mt12) $ --- the dot patterns inside p are only valid in environment env - let tv = case mt12 of - Nothing -> vTopSort - Just tv12 -> second12 tv12 - addPattern (tvp `arrow` tv) p env $ \ _ pv env' -> - addRewrite (Rewrite v pv) [tv,v1] $ \ [tv',v1'] -> do - v2 <- whnf (appendEnv env' env) e - v2' <- reval v2 -- 2010-09-10, WHY? - let mt12' = fmap (mapSecond12 (const tv')) mt12 - leqVal' f pol mt12' v1' v2' - --- compare spines (see rule Al-App-Ne, Abel, MSCS 08) --- q ::= mixed | Pos | Neg -leqVals' :: Force -> Pol -> OneOrTwo TVal -> [Val] -> [Val] -> TypeCheck (OneOrTwo TVal) -leqVals' f q tv12 vl1 vl2 = do - sh12 <- typeView12 =<< mapM force tv12 - case (vl1, vl2, sh12) of - - ([], [], _) -> return tv12 - - (VProj Post p1 : vs1, VProj Post p2 : vs2, ShData d _) -> do - unless (p1 == p2) $ - recoverFailDoc $ text "projections" - <+> prettyTCM p1 <+> text "and" - <+> prettyTCM p2 <+> text "differ!" - -- recoverFail $ "projections " ++ show p1 ++ " and " ++ show p2 ++ " differ!" - tv12 <- mapM (\ tv -> projectType tv p1 VIrr) tv12 - leqVals' f q tv12 vs1 vs2 - - (w1:vs1, w2:vs2, ShQuant Pi x12 dom12 fv12) -> do - let p = oneOrTwo id polAnd (fmap (polarity . decor) dom12) - let dec = Dec p -- WAS: , erased = erased $ decor $ first12 dom12 } - v1 <- whnfClos w1 - v2 <- whnfClos w2 - tv12 <- do - if erased p -- WAS: (erased dec || p == Pol.Const) - -- we have skipped an argument, so proceed with two types! - then app12 (toTwo fv12) (Two v1 v2) - else do - let q' = polComp p q - applyDec dec $ - leqVal' f q' (Just $ fmap typ dom12) v1 v2 - -- we have not skipped comparison, so proceed (1/2) as we came in - case fv12 of - Two{} -> app12 fv12 (Two v1 v2) - One fv -> One <$> app fv v1 - -- type is invariant, so it does not matter which one we take - leqVals' f q tv12 vs1 vs2 - - _ -> failDoc $ text "leqVals': not (compatible) function types or mismatch number of arguments when comparing " - <+> prettyTCM vl1 <+> text " to " - <+> prettyTCM vl2 <+> text " at type " - <+> prettyTCM tv12 --- _ -> throwErrorMsg $ "leqVals': not (compatible) function types or mismatch number of arguments when comparing " ++ show vl1 ++ " to " ++ show vl2 ++ " at type " ++ show tv12 - -{- -leqVals' f q (VPi x1 dom1@(Domain av1 _ dec1) env1 b1, - VPi x2 dom2@(Domain av2 _ dec2) env2 b2) - (w1:vs1) (w2:vs2) | dec1 == dec2 = do - let p = polarity dec1 - v1 <- whnfClos w1 - v2 <- whnfClos w2 - when (not (erased dec1)) $ - applyDec dec1 $ leqVal' f (polComp p q) (Just (av1,av2)) v1 v2 - tv1 <- whnf (update env1 x1 v1) b1 - tv2 <- whnf (update env2 x2 v2) b2 - leqVals' f q (tv1,tv2) vs1 vs2 --} - -{- -leqNe :: Force -> Val -> Val -> TypeCheck TVal -leqNe f v1 v2 = --trace ("leqNe " ++ show v1 ++ "<=" ++ show v2) $ - do case (v1,v2) of - (VGen k1, VGen k2) -> if k1 == k2 then do - dom <- lookupGem k1 - return $ typ dom - else throwErrorMsg $ "gen mismatch " ++ show k1 ++ " " ++ show k2 --} - --- leqApp f pol v1 vs1 v2 vs2 checks v1 vs1 <=pol v2 vs2 --- pol ::= Param | Pos | Neg -leqApp :: Force -> Pol -> Val -> [Val] -> Val -> [Val] -> TypeCheck () -leqApp f pol v1 w1 v2 w2 = {- trace ("leqApp: " -- ++ show delta ++ " |- " - ++ show v1 ++ show w1 ++ " <=" ++ show pol ++ " " ++ show v2 ++ show w2) $ -} -{- - do let headMismatch = recoverFail $ - "leqApp: head mismatch " ++ show v1 ++ " != " ++ show v2 --} - do let headMismatch = recoverFailDoc $ text "leqApp: head mismatch" - <+> prettyTCM v1 <+> text "!=" <+> prettyTCM v2 - let emptyOrUnit u1 u2 = - unlessM (isEmptyType u1) $ unlessM (isUnitType u2) $ headMismatch - case (v1,v2) of -{- IMPOSSIBLE: - (VApp v1 [], v2) -> leqApp f pol v1 w1 v2 w2 - (v1, VApp v2 []) -> leqApp f pol v1 w1 v2 w2 --} -{- - (VApp{}, _) -> throwErrorMsg $ "leqApp: internal error: hit application v1 = " ++ show v1 - (_, VApp{}) -> throwErrorMsg $ "leqApp: internal error: hit application v2 = " ++ show v2 --} - - (VUp v1 _, v2) -> leqApp f pol v1 w1 v2 w2 - (v1, VUp v2 _) -> leqApp f pol v1 w1 v2 w2 - - (VGen k1, VGen k2) | k1 == k2 -> do - tv12 <- (fmap typ . domain) <$> lookupGen k1 - leqVals' f pol tv12 w1 w2 - return () -{- - (VGen k1, VGen k2) -> - if k1 /= k2 - then headMismatch - else do tv12 <- (fmap typ . domain) <$> lookupGen k1 - leqVals' f pol tv12 w1 w2 - return () --} -{- - (VCon _ n, VCon _ m) -> - if n /= m - then throwErrorMsg $ - "leqApp: head mismatch " ++ show v1 ++ " != " ++ show v2 - else do - sige <- lookupSymb n - case sige of - (ConSig tv) -> -- constructor - leqVals' f tv (repeat mixed) w1 w2 >> return () --} - - (VDef n, VDef m) | n == m -> do - tv <- lookupSymbTypQ (idName n) - leqVals' f pol (One tv) w1 w2 - return () - - -- check for least or greatest type - - (u1,u2) -> if pol == Pos then emptyOrUnit u1 u2 else - if pol == Neg then emptyOrUnit u2 u1 else headMismatch - -{- - -- least type - (VDef (DefId DatK n), v2) | pol == Pos -> - ifM (isEmptyData n) (return ()) headMismatch - (v1, VDef (DefId DatK n)) | pol == Neg -> - ifM (isEmptyData n) (return ()) headMismatch --} -{- - (VDef n, VDef m) -> - if (name n) /= (name m) then do - bot <- if pol==Neg then isEmptyData $ name m else - if pol==Pos then isEmptyData $ name n else return False - if bot then return () else headMismatch - else do - tv <- lookupSymbTyp (name n) - leqVals' f pol (One tv) w1 w2 - return () --} -{- - sig <- gets signature - case lookupSig (name n) sig of - (DataSig{ numPars = p, positivity = pos, isSized = s, isCo = co, symbTyp = tv }) -> -- data type - let positivitySizeIndex = if s /= Sized then mixed else - if co == Ind then Pos else Neg - pos' = -- trace ("leqApp: posOrig = " ++ show (pos ++ [positivitySizeIndex])) $ - map (polComp pol) (pos ++ positivitySizeIndex : repeat mixed) -- the polComp will replace all SPos by Pos - in leqVals' f tv pos' w1 w2 - >> return () - --- otherwise, we are dealing with a (co) recursive function or a constructor - entry -> leqVals' f (symbTyp entry) (repeat mixed) w1 w2 >> return () --} - -{- - _ -> headMismatch - - _ -> recoverFail $ "leqApp: " ++ show v1 ++ show w1 ++ " !<=" ++ show pol ++ " " ++ show v2 ++ show w2 --} - -isEmptyType :: TVal -> TypeCheck Bool -isEmptyType (VDef (DefId DatK n)) = isEmptyData n -isEmptyType _ = return False - -isUnitType :: TVal -> TypeCheck Bool -isUnitType (VDef (DefId DatK n)) = isUnitData n -isUnitType _ = return False - --- comparing sorts and sizes ----------------------------------------- - -leqSort :: Pol -> Sort Val -> Sort Val -> TypeCheck () -leqSort p = relPolM p leqSort' -{- -leqSort mixed s1 s2 = leqSort' s1 s2 >> leqSort' s2 s1 -leqSort Neg s1 s2 = leqSort' s2 s1 -leqSort Pos s1 s2 = leqSort' s1 s2 --} - -leqSort' :: Sort Val -> Sort Val -> TypeCheck () -leqSort' s1 s2 = do --- let err = "universe test " ++ show s1 ++ " <= " ++ show s2 ++ " failed" - let err = text "universe test" - <+> prettyTCM s1 <+> text "<=" - <+> prettyTCM s2 <+> text "failed" - case (s1,s2) of - (_ , Set VInfty) -> return () - (SortC c , SortC c') | c == c' -> return () - (Set v1 , Set v2) -> leqSize Pos v1 v2 - (CoSet VInfty , Set v) -> return () - (Set VZero , CoSet{}) -> return () - (CoSet v1 , CoSet v2) -> leqSize Neg v1 v2 - _ -> recoverFailDoc err - -minSize :: Val -> Val -> Maybe Val -minSize v1 v2 = - case (v1,v2) of - (VZero,_) -> return VZero - (_,VZero) -> return VZero - (VInfty,_) -> return v2 - (_,VInfty) -> return v1 - (VMax vs,_) -> maxMins $ map (\ v -> minSize v v2) vs - (_,VMax vs) -> maxMins $ map (\ v -> minSize v1 v) vs - (VSucc v1', VSucc v2') -> fmap succSize $ minSize v1' v2' - (VGen i, VGen j) -> if i == j then return $ VGen i else Nothing - (VSucc v1', VGen j) -> minSize v1' v2 - (VGen i, VSucc v2') -> minSize v1 v2' - -maxMins :: [Maybe Val] -> Maybe Val -maxMins mvs = case compressMaybes mvs of - [] -> Nothing - vs' -> return $ maxSize vs' - --- substaging on size values -leqSize :: Pol -> Val -> Val -> TypeCheck () -leqSize = leSize Le - -ltSize :: Val -> Val -> TypeCheck () -ltSize = leSize Lt Pos - -leSize :: LtLe -> Pol -> Val -> Val -> TypeCheck () -leSize ltle pol v1 v2 = enterDoc (text "leSize" - <+> prettyTCM v1 <+> text (show ltle ++ show pol) - <+> prettyTCM v2) $ --- enter ("leSize " ++ show v1 ++ " " ++ show ltle ++ show pol ++ " " ++ show v2) $ - traceSize ("leSize " ++ show v1 ++ " " ++ show ltle ++ show pol ++ " " ++ show v2) $ - do case (v1,v2) of - _ | v1 == v2 && ltle == Le -> return () -- TODO: better handling of sums! - (VSucc v1,VSucc v2) -> leSize ltle pol v1 v2 -{- - (VGen i1,VGen i2) -> do - d <- getSizeDiff i1 i2 -- check size relation from constraints - case d of - Nothing -> recoverFail $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2 - Just k -> case (pol,k) of - (_, 0) | pol == mixed -> return () - (Pos, _) | k >= 0 -> return () - (Neg, _) | k <= 0 -> return () - _ -> recoverFail $ "leqSize: " ++ show v1 ++ " !<=" ++ show pol ++ " " ++ show v2 ++ " failed" --} -{- - if v1 == v2 then return () - else throwErrorMsg $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2 --} - (VInfty,VInfty) | ltle == Le -> return () - | otherwise -> recoverFail "leSize: # < # failed" - (VApp h1 tl1,VApp h2 tl2) -> leqApp N pol h1 tl1 h2 tl2 - _ -> relPolM pol (leSize' ltle) v1 v2 - -leqSize' :: Val -> Val -> TypeCheck () -leqSize' = leSize' Le - -leSize' :: LtLe -> Val -> Val -> TypeCheck () -leSize' ltle v1 v2 = -- enter ("leSize' " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2) $ - enterDoc (text "leSize'" <+> prettyTCM v1 <+> text (show ltle) <+> prettyTCM v2) $ - traceSize ("leSize' " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2) $ - do let failure = recoverFailDoc $ text "leSize':" - <+> prettyTCM v1 <+> text (show ltle) - <+> prettyTCM v2 <+> text "failed" - -- err = "leSize': " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2 ++ " failed" - case (v1,v2) of - (VZero,_) | ltle == Le -> return () - (VSucc{}, VZero) -> failure - (VInfty, VZero) -> failure - (VGen{}, VZero) -> failure - (VMax vs,_) -> mapM_ (\ v -> leSize' ltle v v2) vs -- all v in vs <= v2 - (_,VMax vs) -> foldr1 orM $ map (leSize' ltle v1) vs -- this produces a disjunction --- (_,VMax _) -> addLe ltle v1 v2 -- this produces a disjunction - (_,VInfty) | ltle == Le -> return () - (VZero, VInfty) -> return () - (VMeta{},VZero) -> addLe ltle v1 v2 -{- - (0,VMeta i n', VMeta j m') -> - let (n,m) = if bal <= 0 then (n', m' - bal) else (n' + bal, m') in --} - (VMeta i rho n, VMeta j rho' m) -> - addLe ltle (VMeta i rho (n - min n m)) - (VMeta j rho' (m - min n m)) - (VMeta i rho n, VSucc v2) | n > 0 -> leSize' ltle (VMeta i rho (n-1)) v2 - (VMeta i rho n, v2) -> addLe ltle v1 v2 - (VSucc v1, VMeta i rho n) | n > 0 -> leSize' ltle v1 (VMeta i rho (n-1)) - (v1,VMeta i rho n) -> addLe ltle v1 v2 - _ -> leSize'' ltle 0 v1 v2 -{- HANDLED BY leSize'' ltle - (VSucc{}, VGen{}) -> throwErrorMsg err - (VSucc{}, VPlus{}) -> throwErrorMsg err --} --- leSize'' ltle bal v v' checks whether Succ^bal v `lt` v' --- invariant: bal is zero in cases for VMax and VMeta -leSize'' :: LtLe -> Int -> Val -> Val -> TypeCheck () -leSize'' ltle bal v1 v2 = traceSize ("leSize'' " ++ show v1 ++ " + " ++ show bal ++ " " ++ show ltle ++ " " ++ show v2) $ - do let failure = recoverFailDoc (text "leSize'':" <+> prettyTCM v1 <+> text ("+ " ++ show bal) <+> text (show ltle) <+> prettyTCM v2 <+> text "failed") - check mb = ifM mb (return ()) failure - ltlez = case ltle of { Le -> 0 ; Lt -> -1 } - case (v1,v2) of -#ifdef STRICTINFTY --- Only cancel variables < # - _ | v1 == v2 && ltle == Le && bal <= 0 -> return () - (VGen i, VGen j) | i == j && bal <= -1 -> check $ isBelowInfty i -#else --- Allow cancelling of all variables - _ | v1 == v2 && bal <= ltlez -> return () -- TODO: better handling of sums! -#endif - (VGen i, VInfty) | ltle == Lt -> check $ isBelowInfty i - (VZero,_) | bal <= ltlez -> return () - (VZero,VInfty) -> return () - (VZero,VGen _) | bal > ltlez -> recoverFailDoc $ text "0 not <" <+> prettyTCM v2 - (VSucc v1, v2) -> leSize'' ltle (bal + 1) v1 v2 - (v1, VSucc v2) -> leSize'' ltle (bal - 1) v1 v2 - (VPlus vs1, VPlus vs2) -> leSizePlus ltle bal vs1 vs2 - (VPlus vs1, VZero) -> leSizePlus ltle bal vs1 [] - (VZero, VPlus vs2) -> leSizePlus ltle bal [] vs2 - (VPlus vs1, _) -> leSizePlus ltle bal vs1 [v2] - (_, VPlus vs2) -> leSizePlus ltle bal [v1] vs2 - (VZero,_) -> leSizePlus ltle bal [] [v2] - (_,VZero) -> leSizePlus ltle bal [v1] [] - _ -> leSizePlus ltle bal [v1] [v2] - -#if (defined STRICTINFTY) -{- 2012-02-06 this modification cancels only variables < # - However, omega-instantiation is valid [i < #] -> F i subseteq F # - because every chain has a limit at #. --} -leSizePlus :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck () -leSizePlus Lt bal vs1 vs2 = do - vs2' <- filterM varBelowInfty vs2 - vs1' <- filterM varBelowInfty vs1 - leSizePlus' Lt bal (vs1 List.\\ vs2') (vs2 List.\\ vs1') -leSizePlus Le bal vs1 vs2 = - leSizePlus' Le bal (vs1 List.\\ vs2) (vs2 List.\\ vs1) -#else -leSizePlus :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck () -leSizePlus ltle bal vs1 vs2 = - leSizePlus' ltle bal (vs1 List.\\ vs2) (vs2 List.\\ vs1) -#endif - - -varBelowInfty :: Val -> TypeCheck Bool -varBelowInfty (VGen i) = isBelowInfty i -varBelowInfty _ = return False - -leSizePlus' :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck () -leSizePlus' ltle bal vs1 vs2 = do - let v1 = plusSizes vs1 - let v2 = plusSizes vs2 - let exit True = return () - exit False | bal >= 0 = recoverFailDoc (text "leSize:" <+> prettyTCM v1 <+> text ("+ " ++ show bal ++ " " ++ show ltle) <+> prettyTCM v2 <+> text "failed") - | otherwise = recoverFailDoc (text "leSize:" <+> prettyTCM v1 <+> text (show ltle) <+> prettyTCM v2 <+> text ("+ " ++ show (-bal) ++ " failed")) - traceSizeM ("leSizePlus' ltle " ++ show v1 ++ " + " ++ show bal ++ " " ++ show ltle ++ " " ++ show v2) - let ltlez = case ltle of { Le -> 0 ; Lt -> -1 } - case (vs1,vs2) of - ([],_) | bal <= ltlez -> return () - ([],[VGen i]) -> do - n <- getMinSize i - -- traceM ("getMinSize = " ++ show n) - case n of - Nothing -> exit False -- height of VGen i == 0 - Just n -> exit (bal <= n + ltlez) - ([VGen i1],[VGen i2]) -> do - d <- sizeVarBelow i1 i2 - traceSizeM ("sizeVarBelow " ++ show (i1,i2) ++ " returns " ++ show d) - case d of - Nothing -> tryIrregularBound i1 i2 (ltlez - bal) --- recoverFail $ "leSize: head mismatch: " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2 - Just k -> exit (bal <= k + ltlez) - _ -> exit False - --- BAD HACK! --- check (VGen i1) <= (VGen i2) + k -tryIrregularBound :: Int -> Int -> Int -> TypeCheck () -tryIrregularBound i1 i2 k = do - betas <- asks bounds - let beta = Bound Le (Measure [VGen i1]) (Measure [iterate VSucc (VGen i2) !! k]) - foldl (\ result beta' -> result `orM` entailsGuard Pos beta' beta) - (recoverFail "bound not entailed") - betas - -{- -leqSize' :: Val -> Val -> TypeCheck () -leqSize' v1 v2 = --trace ("leqSize' " ++ show v1 ++ show v2) $ - do case (v1,v2) of - (VMax vs,_) -> mapM_ (\ v -> leqSize' v v2) vs -- all v in vs <= v2 - (_,VMax _) -> addLeq v1 v2 -- this produces a disjunction - (VSucc v1,VSucc v2) -> leqSize' v1 v2 - (VGen v1,VGen v2) -> do - d <- getSizeDiff v1 v2 - case d of - Nothing -> throwErrorMsg $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2 - Just k -> if k >= 0 then return () else throwErrorMsg $ "leqSize: " ++ show v1 ++ " !<= " ++ show v2 ++ " failed" - (_,VInfty) -> return () - (VMeta i n, VSucc v2) | n > 0 -> leqSize' (VMeta i (n-1)) v2 - (VMeta i n, VMeta j m) -> addLeq (VMeta i (n - min n m)) - (VMeta j (m - min n m)) - (VMeta i n, v2) -> addLeq v1 v2 - (VSucc v1, VMeta i n) | n > 0 -> leqSize' v1 (VMeta i (n-1)) - (v1,VMeta i n) -> addLeq v1 v2 - (v1,VSucc v2) -> leqSize' v1 v2 - _ -> throwErrorMsg $ "leqSize: " ++ show v1 ++ " !<= " ++ show v2 --} - --- measures and guards ----------------------------------------------- - -{- --- compare lexicographically --- precondition: same length -ltMeasure :: Measure Val -> Measure Val -> TypeCheck () -ltMeasure (Measure mu1) (Measure mu2) = - -- enter ("checking " ++ show mu1 ++ " < " ++ show mu2) $ - lexSizes Lt mu1 mu2 --} - -{- -leqMeasure :: Pol -> Measure Val -> Measure Val -> TypeCheck () -leqMeasure mixed (Measure mu1) (Measure mu2) = do - zipWithM (leqSize mixed) mu1 mu2 - return () -leqMeasure Pos (Measure mu1) (Measure mu2) = lexSizes mu1 mu2 -leqMeasure Neg (Measure mu1) (Measure mu2) = lexSizes mu2 mu1 --} - --- lexSizes True mu mu' checkes mu < mu' --- lexSizes False mu mu' checkes mu <= mu' -lexSizes :: LtLe -> [Val] -> [Val] -> TypeCheck () -lexSizes ltle mu1 mu2 = traceSize ("lexSizes " ++ show (ltle,mu1,mu2)) $ - case (ltle, mu1, mu2) of - (Lt, [], []) -> recoverFail $ "lexSizes: no descent detected" - (Le, [], []) -> return () - (lt, a1:mu1, a2:mu2) -> do - b <- newAssertionHandling Failure $ errorToBool $ leSize ltle Pos a1 a2 - case (lt,b) of - (Le,False) -> recoverFailDoc $ text "lexSizes: expected" <+> prettyTCM a1 <+> text "<=" <+> prettyTCM a2 - -- recoverFail $ "lexSizes: expected " ++ show a1 ++ " <= " ++ show a2 - (Lt,True) -> return () - _ -> lexSizes ltle mu1 mu2 - -{- - r <- compareSize a1 a2 - case r of - LT -> return () - EQ -> lexSizes ltle mu1 mu2 - GT -> recoverFail $ "lexSizes: expected " ++ show a1 ++ " <= " ++ show a2 --} - -{- --- TODO: reprogram leqSize in terms of a proper compareSize -compareSize :: Val -> Val -> TypeCheck Ordering -compareSize a1 a2 = do - let ret o = trace ("compareSize: " ++ show a1 ++ " compared to " ++ show a2 ++ " returns " ++ show o) $ return o - le <- newAssertionHandling Failure $ errorToBool $ leqSize Pos a1 a2 - ge <- newAssertionHandling Failure $ errorToBool $ leqSize Pos a2 a1 - case (le,ge) of - (True,False) -> ret LT -- THIS IS COMPLETE BOGUS!!! - (True,True) -> ret EQ - (False,True) -> ret GT - (False,False) -> throwErrorMsg $ "compareSize (" ++ show a1 ++ ", " ++ show a2 ++ "): sizes incomparable" --} - -{- Bound entailment - -1. (mu1 < mu1') ==> (mu2 < mu2') if mu2 <= mu1 and mu1' <= mu2' -2. (mu1 <= mu1') ==> (mu2 < mu2') one of these <= strict (<) -3. (mu1 < mu1') ==> (mu2 <= mu2') as 1. -4. (mu1 <= mu1') ==> (mu2 <= mu2') as 1. - --} -entailsGuard :: Pol -> Bound Val -> Bound Val -> TypeCheck () -entailsGuard pol beta1@(Bound ltle1 (Measure mu1) (Measure mu1')) beta2@(Bound ltle2 (Measure mu2) (Measure mu2')) = enterDoc (text ("entailsGuard:") <+> prettyTCM beta1 <+> text (show pol ++ "==>") <+> prettyTCM beta2) $ do - case pol of - _ | pol == mixed -> do - assert (ltle1 == ltle2) $ "unequal bound types" - zipWithM (leqSize mixed) mu1 mu2 - zipWithM (leqSize mixed) mu1' mu2' - return () - Pos | ltle1 == Lt || ltle2 == Le -> do - lexSizes Le mu2 mu1 -- not strictly smaller - lexSizes Le mu1' mu2' - return () - Pos -> do - (lexSizes Lt mu2 mu1 >> lexSizes Le mu1' mu2') - `orM` - (lexSizes Le mu2 mu1 >> lexSizes Lt mu1' mu2') - Neg -> entailsGuard (switch pol) beta2 beta1 - -{- -eqGuard :: Bound Val -> Bound Val -> TypeCheck () -eqGuard (Bound (Measure mu1) (Measure mu1')) (Bound (Measure mu2) (Measure mu2')) = do - zipWithM (leqSize mixed) mu1 mu2 - zipWithM (leqSize mixed) mu1' mu2' - return () --} - -checkGuard :: Bound Val -> TypeCheck () -checkGuard beta@(Bound ltle mu mu') = - enterDoc (text "checkGuard" <+> prettyTCM beta) $ - lexSizes ltle (measure mu) (measure mu') - -addOrCheckGuard :: Pol -> Bound Val -> TypeCheck a -> TypeCheck a -addOrCheckGuard Neg beta cont = checkGuard beta >> cont -addOrCheckGuard Pos beta cont = addBoundHyp beta cont - --- comparing polarities ------------------------------------------------- - -leqPolM :: Pol -> PProd -> TypeCheck () -leqPolM p (PProd Pol.Const _) = return () -leqPolM p (PProd q m) | Map.null m && not (isPVar p) = - if leqPol p q then return () - else recoverFail $ "polarity check " ++ show p ++ " <= " ++ show q ++ " failed" -leqPolM p q = do - traceM $ "adding polarity constraint " ++ show p ++ " <= " ++ show q - -leqPolPoly :: Pol -> PPoly -> TypeCheck () -leqPolPoly p (PPoly l) = mapM_ (leqPolM p) l - --- adding an edge to the positivity graph -addPosEdge :: DefId -> DefId -> PProd -> TypeCheck () -addPosEdge src tgt p = unless (src == tgt && isSPos p) $ do - -- traceM ("adding interesting positivity graph edge " ++ show src ++ " --[ " ++ show p ++ " ]--> " ++ show tgt) - st <- get - put $ st { positivityGraph = Arc (Rigid src) (ppoly p) (Rigid tgt) : positivityGraph st } - -checkPositivityGraph :: TypeCheck () -checkPositivityGraph = enter ("checking positivity") $ do - st <- get - let cs = positivityGraph st - let gr = buildGraph cs - let n = nextNode gr - let m0 = mkMatrix n (graph gr) - let m = warshall m0 - let isDataId i = case Map.lookup i (intMap gr) of - Just (Rigid (DefId DatK _)) -> True - _ -> False - let dataDiag = [ m Array.! (i,i) | i <- [0..n-1], isDataId i ] - mapM_ (\ x -> leqPolPoly oone x) dataDiag -{- - let solvable = all (\ x -> leqPol oone x) - unless solvable $ recoverFail $ "positivity check failed" --} - -- TODO: solve constraints - put $ st { positivityGraph = [] } - --- telescopes -------------------------------------------------------- - -telView :: TVal -> TypeCheck ([(Val, TBinding TVal)], TVal) -telView tv = do - case tv of - VQuant Pi x dom fv -> underAbs_ x dom fv $ \ _ xv bv -> do - (vTel, core) <- telView bv - return ((xv, TBind x dom) : vTel, core) - _ -> return ([], tv) - --- | Turn a fully applied constructor value into a named record value. -mkConVal :: Dotted -> ConK -> QName -> [Val] -> TVal -> TypeCheck Val -mkConVal dotted co n vs vc = do - (vTel, _) <- telView vc - let fieldNames = map (boundName . snd) vTel - return $ VRecord (NamedRec co n False dotted) $ zip fieldNames vs diff --git a/Eval.hs-boot b/Eval.hs-boot deleted file mode 100644 --- a/Eval.hs-boot +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} - -module Eval where - -import Abstract -import Value -import {-# SOURCE #-} TCM (TypeCheck) - -class Reval a where - reval' :: Valuation -> a -> TypeCheck a - reval :: a -> TypeCheck a - reval = reval' emptyVal - -instance Reval Val -instance Reval Env - -toExpr :: Val -> TypeCheck Expr - -whnf :: Env -> Expr -> TypeCheck Val -whnf' :: Expr -> TypeCheck Val -app :: Val -> Val -> TypeCheck Val - -whnfClos :: Val -> TypeCheck Val -force :: Val -> TypeCheck Val -piApps :: TVal -> [Clos] -> TypeCheck TVal - -matchList :: Env -> [Pattern] -> [Val] -> TypeCheck (Maybe Env) - -type GenToPattern = [(Int,Pattern)] -type MatchState = (Env, GenToPattern) -nonLinMatchList' :: Bool -> Bool -> MatchState -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe MatchState) - -projectType :: TVal -> Name -> Val -> TypeCheck TVal - -up :: Bool -> Val -> TVal -> TypeCheck Val - -leqSize' :: Val -> Val -> TypeCheck () - -mkConVal :: Dotted -> ConK -> QName -> [Val] -> TVal -> TypeCheck Val diff --git a/Extract.hs b/Extract.hs deleted file mode 100644 --- a/Extract.hs +++ /dev/null @@ -1,690 +0,0 @@ -{-# LANGUAGE TupleSections, NamedFieldPuns #-} - -module Extract where - -{- extract to Fomega - -Examples: ---------- - -MiniAgda - - data Vec (A : Set) : Nat -> Set - { vnil : Vec A zero - ; vcons : [n : Nat] -> (head : A) -> (tail : Vec A n) -> Vec A (suc n) - } fields head, tail - - fun length : [A : Set] -> [n : Nat] -> Vec A n -> - { length .A .zero (vnil A) = zero - ; length .A .(suc n) (vcons A n a as) = suc (length A n as) - } - -Fomega - - data Vec (A : Set) : Set - { vnil : Vec A - ; vcons : (head : A) -> (tail : Vec A) -> Vec A - } - - fun head : [A : Set] -> Vec A -> A - { head (vcons 'head 'tail) = 'head - } - - fun tail : [A : Set] -> Vec A -> A - { head (vcons 'head 'tail) = 'tail - } - - fun length : [A : Set] -> Vec A -> Nat - { length [A] vnil = zero - ; length [A] (vcons [.A] a as) = suc (length [A] as) - } - - -Bidirectional extraction -======================== - -Types - - Base ::= D As data type - | ? inexpressible type - - A,B ::= Base | A -> B | [x:K] -> B | [] -> B with erasure markers - A0, B0 ::= Base | A0 -> B0 | [x:K0] -> B0 without erasure markers - - |.| erase erasure markers - -Inference mode: - - Term extraction: Gamma |- t :> A --> e |Gamma| |- e : |A| - Type extraction: Gamma |- T :> K --> A |Gamma| |- A : |K| - Kind extraction: Gamma |- U :> [] --> K |Gamma| |- K : [] - -Checking mode: - - Term extraction: Gamma |- t <: A --> e |Gamma| |- e : |A| - Type extraction: Gamma |- T <: K --> A |Gamma| |- A : |K| - Kind extraction: Gamma |- U <: [] --> K |Gamma| |- K : [] - -Type and kind extraction keep erasure markers! - -Checking abstraction: - - Relevant abstraction: - Gamma, x:A |- t <: B --> e - -------------------------------- - Gamma |- \x.t <: A -> B --> \x.e - - Type abstraction: - Gamma, x:K |- t <: B --> e : B0 - ---------------------------------------- - Gamma |- \[x].t <: [x:K] -> B --> \[x].e - also \xt - - Irrelevant abstraction: - Gamma |- t : B --> e - ------------------------------- - Gamma |- \[x].t : [] -> B --> e - also \xt - - Relevant abstraction at unknown type: - Gamma, x:? |- t : ? --> e - -------------------------- - Gamma |- \x.t : ? --> \x.e - - Irrelevant abstraction at unknown type: - Gamma |- t : ? --> e - ------------------------- - Gamma |- \[x].t : ? --> e - -Checking by inference: - - Gamma |- t :> A --> e e : |A| <: |B| --> e' - ---------------------------------------------- - Gamma |- t <: B --> e' : B0 - -Casting: - - ------------------ A0 does not contain ? - e : A0 <: A0 --> e - - ----------------------- A0 != B0 or one does contain ? - e : A0 <: B0 --> cast e - -Inferring variable: - - ---------------------------- - Gamma |- x :> Gamma(x) --> x - -Inferring application: - - Relevant application: - Gamma |- t :> A -> B --> f Gamma |- u <: A --> e - ---------------------------------------------------- - Gamma |- t u :> B --> f e - - Type application: - Gamma |- t :> [x:K] -> B --> f Gamma |- u <: K --> A - ------------------------------------------------------ - Gamma |- t [u] :> : B[A/x] --> f [A] - also t u - - Irrelevant application: - Gamma |- t :> [] -> B --> f - --------------------------- - Gamma |- t [u] :> B --> f - also t u - - Relevant application at unknown type: - Gamma |- t :> ? --> f Gamma |- u <: ? --> e - ----------------------------------------------- - Gamma |- t u :> ? --> f e - - Irrelevant application at unknown type: - Gamma |- t :> ? --> f - ------------------------- - Gamma |- t [u] :> ? --> f - - - --} - -import Prelude hiding (pi, null) - -import Control.Applicative -import Control.Monad -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State - -import Data.Char -import Data.Traversable (Traversable) -import qualified Data.Traversable as Traversable -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe - -import Text.PrettyPrint - -import Polarity as Pol -import Abstract -import Value -import Eval -import TCM -import TraceError -import Util - -traceExtrM s = return () - -runExtract sig k = runExceptT (runReaderT (runStateT k (initWithSig sig)) emptyContext) - --- extraction - -type FExpr = Expr -type FDeclaration = Declaration -type FClause = Clause -type FPattern = Pattern -type FConstructor = Constructor -type FTypeSig = TypeSig -type FFun = Fun -type FTelescope = Telescope - -type FTVal = TVal - -extractDecls :: [EDeclaration] -> TypeCheck [FDeclaration] -extractDecls ds = concat <$> mapM extractDecl ds - -extractDecl :: EDeclaration -> TypeCheck [FDeclaration] -extractDecl d = - case d of - MutualDecl _ ds -> extractDecls ds -- TODO! - OverrideDecl{} -> throwErrorMsg $ "extractDecls internal error: overrides impossible" - MutualFunDecl _ co funs -> extractFuns co funs - FunDecl co fun -> extractFun co fun - LetDecl evl x tel (Just t) e | null tel -> extractLet evl x t e - PatternDecl{} -> return [] - DataDecl n _ co _ tel ty cs fields -> extractDataDecl n co tel ty cs - -extractFuns :: Co -> [Fun] -> TypeCheck [FDeclaration] -extractFuns co funs = do - funs <- concat <$> mapM extractFunTypeSig funs - concat <$> mapM (extractFun co) funs - -extractFun :: Co -> Fun -> TypeCheck [FDeclaration] -extractFun co (Fun (TypeSig n t) n' ar cls) = do - tv <- whnf' t - cls <- concat <$> mapM (extractClause n tv) cls - return [ FunDecl co $ Fun (TypeSig n t) n' ar cls - -- , LetDecl False (TypeSig n' t) (Var n) -- no longer needed, since n and n' print the same - ] - -{- OLD -extractFun :: Co -> Fun -> TypeCheck [FDeclaration] -extractFun co (TypeSig n t, (ar, cls)) = extractIfTerm n $ do - tv0 <- whnf' t - t <- extractType tv0 - setExtrTyp n t - let n' = mkExtName n - setExtrTyp n' t - tv <- whnf' t - cls <- concat <$> mapM (extractClause n tv) cls - return [ FunDecl co (TypeSig n t, (ar, cls)) - , LetDecl False (TypeSig n' t) (Var n) - ] --} -{- -extractFunTypeSigs :: [Fun] -> TypeCheck [Fun] -extractFunTypeSigs = mapM extractFunTypeSig --} - --- only extract type sigs -extractFunTypeSig :: Fun -> TypeCheck [Fun] -extractFunTypeSig (Fun ts@(TypeSig n t) n' ar cls) = extractIfTerm n $ do - ts@(TypeSig n t) <- extractTypeSig ts - setExtrTyp n' t - return [Fun ts n' ar cls] - -extractLet :: Bool -> Name -> Type -> Expr -> TypeCheck [FDeclaration] -extractLet evl n t e = extractIfTerm n $ do - TypeSig n t <- extractTypeSig (TypeSig n t) - e <- extractCheck e =<< whnf' t - return [LetDecl evl n emptyTel (Just t) e] - -extractTypeSig :: TypeSig -> TypeCheck FTypeSig -extractTypeSig (TypeSig n t) = do - t <- extractType =<< whnf' t - setExtrTyp n t - return $ TypeSig n t - -extractIfTerm :: Name -> TypeCheck [a] -> TypeCheck [a] -extractIfTerm n cont = do - k <- symbolKind <$> lookupSymb n - if k == NoKind || lowerKind k == SortC Tm then cont else return [] - -extractDataDecl :: Name -> Co -> Telescope -> Type -> [Constructor] -> TypeCheck [FDeclaration] -extractDataDecl n co tel ty cs = do - -- k <- extrTyp <$> lookupSymb n - tel' <- extractKindTel tel - Just core <- addBinds tel $ extractKind =<< whnf' ty - -- (_, core) = typeToTele' (length tel') k - cs <- mapM (extractConstructor tel) cs - return [DataDecl n NotSized co [] tel' core cs []] - -extractConstructor :: Telescope -> Constructor -> TypeCheck FConstructor -extractConstructor tel0 (Constructor n pars t) = do -{- fails for HEq - -- 2012-01-22: remove irrelevant parameters - let tel = filter (\ (TBind _ dom) -> not $ erased $ decor dom) tel0 --} - let tel = tel0 - -- compute full extracted constructor type and add to the signature - t' <- extractType =<< whnf emptyEnv (teleToTypeErase tel t) - setExtrTypQ n t' - let (tel',core) = typeToTele' (size tel) t' - return $ Constructor n pars core - -- compute type minus telescope - -- TypeSig n <$> (extractType =<< whnf' t) - -extractClause :: Name -> FTVal -> Clause -> TypeCheck [FClause] -extractClause f tv (Clause _ pl Nothing) = return [] -- discard absurd clauses -extractClause f tv cl@(Clause vtel pl (Just rhs)) = do - traceM ("extracting clause " ++ render (prettyClause f cl) - ++ "\n at type " ++ show tv) -{- - tel <- introPatterns pl tv0 $ \ _ _ -> do - vtel <- getContextTele - extractTeleVal vtel - addBinds tel $ --} - introPatVars pl $ - extractPatterns tv pl $ \ pl tv -> do - rhs <- extractCheck rhs tv - return [Clause vtel pl (Just rhs)] -- TODO: return FTelescope (type!) - --- the pattern variables are already in context -extractPatterns :: FTVal -> [Pattern] -> - ([FPattern] -> FTVal -> TypeCheck a) -> TypeCheck a -extractPatterns tv [] cont = cont [] tv -extractPatterns tv (p:ps) cont = - extractPattern tv p $ \ pl tv -> - extractPatterns tv ps $ \ ps tv -> - cont (pl ++ ps) tv - -extractPattern :: FTVal -> Pattern -> - ([FPattern] -> FTVal -> TypeCheck a) -> TypeCheck a -extractPattern tv p cont = do - traceM ("extracting pattern " ++ render (pretty p) ++ " at type " ++ show tv) - fv <- funView tv - case fv of - EraseArg tv -> cont [] tv -- skip erased patterns - - Forall x dom fv -> do - xv <- whnf' (patternToExpr p) -- pattern variables are already in scope - bv <- app fv xv -- TODO! - case p of - ErasedP (VarP y) -> setTypeOfName y dom $ cont [] bv - _ -> cont [] bv -{- - Forall x ki env t -> new x ki $ \ xv -> - cont [] =<< whnf (update env x xv) t -- TODO! --} - Arrow av bv -> extractPattern' av p (flip cont bv) - -extractPattern' :: FTVal -> Pattern -> - ([FPattern] -> TypeCheck a) -> TypeCheck a -extractPattern' av p cont = - case p of - VarP y -> setTypeOfName y (defaultDomain av) $ - cont [VarP y] - PairP p1 p2 -> do - view <- prodView av - -- hack to avoid IMPOSSIBLE - let (av1, av2) = case view of - Prod av1 av2 -> (av1, av2) - _ -> (av, av) -- HACK - extractPattern' av1 p1 $ \ ps1 -> do - extractPattern' av2 p2 $ \ ps2 -> - let ps [] ps2 = ps2 - ps ps1 [] = ps1 - ps [p1] [p2] = [PairP p1 p2] - in cont $ ps ps1 ps2 - -{- - case view of - Prod av1 av2 -> - extractPattern' av1 p1 $ \ [p1] -> do - extractPattern' av2 p2 $ \ [p2] -> cont [PairP p1 p2] - _ -> throwErrorMsg $ "extractPattern': IMPOSSIBLE: pattern " ++ - show p ++ " : " ++ show av --} - ConP pi n ps -> do --- tv <- whnf' =<< extrTyp <$> lookupSymb n - tv <- extrConType n av - extractPatterns tv ps $ \ ps _ -> - cont [ConP pi n ps] - _ -> cont [] - -extrConType :: QName -> FTVal -> TypeCheck FTVal -extrConType c av = do - ConSig { conPars, extrTyp, dataPars } <- lookupSymbQ c - traceExtrM ("extrConType " ++ show c ++ " has extrTyp = " ++ show extrTyp) - tv <- whnf' extrTyp - numPars <- maybe (return dataPars) (const $ throwErrorMsg $ "NYI: extrConType for pattern parameters") conPars - case numPars of - 0 -> return tv - _ -> do - case av of - VApp (VDef (DefId DatK d)) vs -> do - DataSig { positivity } <- lookupSymbQ d - traceExtrM ("extrConType " ++ show c ++ "; data type has positivity = " ++ show positivity) - let pars 0 pols vs = [] - pars n (pol:pols) vs | erased pol = VIrr : pars (n-1) pols vs - pars n (pol:pols) (v:vs) = v : pars (n-1) pols vs - pars n pols vs = error $ "pars " ++ show n ++ show pols ++ show vs - piApps tv $ pars numPars positivity $ vs ++ repeat VIrr -{- - let (pars, inds) = splitAt numPars vs - piApps tv pars --} - _ -> piApps tv $ replicate numPars VIrr --- _ -> throwErrorMsg $ "extrConType " ++ show c ++ ": expected datatype, found " ++ show av - --- extracting a term from a term ------------------------------------- - -extractInfer :: Expr -> TypeCheck (FExpr, FTVal) -extractInfer e = do - case e of - - Var x -> (Var x,) . typ . domain <$> lookupName1 x - - App f e0 -> do - let (er, e) = isErasedExpr e0 - (f, tv) <- extractInfer f - fv <- funView tv - case fv of - EraseArg bv -> return (f,bv) - Forall x dom fv -> do - e <- extractTypeAt e (typ dom) - bv <- app fv =<< whnf' e - return $ (App f (erasedExpr e), bv) - Arrow av bv -> return (if er then f else App f e, bv) - NotFun -> return (if er then f else castExpr f `App` e, VIrr) - - Def f -> (Def f,) <$> do (whnf' . extrTyp) =<< lookupSymbQ (idName f) - - Pair{} -> throwErrorMsg $ "extractInfer: IMPOSSIBLE: pair " ++ show e - -- other expressions are erased or types - - _ -> return (Irr, VIrr) - -extractCheck :: Expr -> FTVal -> TypeCheck (FExpr) -extractCheck e tv = do - case e of - Lam dec y e -> do - fv <- funView tv - case fv of - EraseArg bv -> extractCheck e bv -- discard lambda - Forall x dom fv -> - Lam (decor dom) y <$> do - newWithGen y dom $ \ i xv -> - extractCheck e =<< app fv (VGen i) -- no eta-expansion - Arrow av bv -> - if erased dec then extractCheck e bv - else Lam dec y <$> do - new' y (defaultDomain av) $ - extractCheck e bv - NotFun -> castExpr <$> - if erased dec then extractCheck e VIrr - else Lam dec y <$> do - new' y (defaultDomain VIrr) $ - extractCheck e VIrr - - LLet (TBind x dom0) tel e1 e2 | null tel -> do - let dom = fmap Maybe.fromJust dom0 - if erased (decor dom) then extractCheck e2 tv else do -- discard let - vdom <- Traversable.mapM whnf' dom -- MiniAgda type val - dom <- Traversable.mapM extractType vdom -- Fomega type - vdom <- Traversable.mapM whnf' dom -- Fomega type val - e1 <- extractCheck e1 (typ vdom) - LLet (TBind x (fmap Just dom)) emptyTel e1 <$> do - new' x vdom $ extractCheck e2 tv - - Pair e1 e2 -> do - view <- prodView tv - let (av1,av2) = case view of - Prod av1 av2 -> (av1, av2) - _ -> (tv,tv) -- HACK!! - Pair <$> extractCheck e1 av1 <*> extractCheck e2 av2 -{- - case view of - Prod av1 av2 -> Pair <$> extractCheck e1 av1 <*> extractCheck e2 av2 - _ -> throwErrorMsg $ "extractCheck: tuple type expected " ++ show e ++ " : " ++ show tv --} - - -- TODO: case - - _ -> fallback - where - fallback = do - (e,tv') <- extractInfer e - insertCast e tv tv' - -insertCast :: FExpr -> FTVal -> FTVal -> TypeCheck FExpr -insertCast e tv1 tv2 = loop tv1 tv2 where - loop tv1 tv2 = - case (tv1,tv2) of - (VIrr,_) -> return $ castExpr e - (_,VIrr) -> return $ castExpr e - _ -> return e -- TODO! - -funView :: FTVal -> TypeCheck FunView -funView tv = - case tv of - -- erasure mark - VQuant Pi x dom fv | erased (decor dom) && typ dom == VIrr -> - EraseArg <$> app fv VIrr - -- forall - VQuant Pi x dom fv | erased (decor dom) -> - return $ Forall x dom fv - -- function type - VQuant Pi x dom fv -> - Arrow (typ dom) <$> app fv VIrr - -- any other type can be a function type, but this needs casts! - _ -> return NotFun -- $ Arrow VIrr VIrr - -data FunView - = Arrow FTVal FTVal -- A -> B - | Forall Name Domain FTVal -- forall X:K. A - | EraseArg FTVal -- [] -> B - | NotFun -- () - -prodView :: FTVal -> TypeCheck ProdView -prodView tv = - case tv of - VQuant Sigma x dom fv -> Prod (typ dom) <$> app fv VIrr - _ -> return $ NotProd - -data ProdView - = Prod FTVal FTVal -- A * B - | NotProd - --- extracting a kind from a value ------------------------------------ - -type FKind = Expr -- FKind ::= Set | FKind -> FKind | [Irr] -> FKind - -star :: FKind -star = Sort $ Set Zero - -extractSet :: Sort Val -> Maybe FKind -extractSet s = - case s of - SortC _ -> Nothing - Set _ -> Just $ star - CoSet _ -> Just $ star - --- keep irrelevant entries -extractKindTel :: Telescope -> TypeCheck FTelescope -extractKindTel (Telescope tel) = Telescope <$> loop tel where - loop [] = return [] - loop (TBind x dom : tel) = do - dom <- Traversable.mapM whnf' dom - dom' <- extractKindDom dom - if erased (decor dom') then - newIrr x $ - (TBind x dom' :) <$> loop tel - else newTyVar x (typ dom') $ \ i -> do - x <- nameOfGen i - (TBind x dom' :) <$> loop tel - -{- --- keep irrelevant entries -extractKindTel :: Telescope -> TypeCheck FTelescope -extractKindTel tel = do - tv <- whnf' (teleToType tel star) - Just k <- extractKind tv - let (tel, s) = typeToTele k - return tel - -- throw away erasure marks - -- return $ filter (\ tb -> not $ erased $ decor $ boundDom tb) tel --} - -extractKindDom :: Domain -> TypeCheck (Dom FKind) -extractKindDom dom = - maybe (defaultIrrDom Irr) defaultDomain <$> - if erased (decor dom) then return Nothing - else extractKind (typ dom) - -extractKind :: TVal -> TypeCheck (Maybe FKind) -extractKind tv = - case tv of - VSort s -> return $ extractSet s - VMeasured mu vb -> extractKind vb - VGuard beta vb -> extractKind vb - VQuant Pi x dom fv -> new' x dom $ do - bv <- app fv VIrr - mk' <- extractKind bv - case mk' of - Nothing -> return Nothing - Just k' -> do - dom' <- extractKindDom dom - let x = fresh "" - return $ Just $ pi (TBind x dom') k' - _ -> return Nothing - --- extracting a type constructor from a value ------------------------ - -type FType = Expr -{- FType ::= Irr -- not expressible in Fomega - | D FTypes -- data type - | X FTypes -- type variable - | FType -> FType -- function type - | [X:FKind] -> FType -- polymorphic type - | [Irr] -> FType -- erasure marker - -} - --- tyVarName i = fresh $ "a" ++ show i - -newTyVar :: Name -> FKind -> (Int -> TypeCheck a) -> TypeCheck a -newTyVar x k cont = newWithGen x (defaultDomain (VClos emptyEnv k)) $ - \ i _ -> cont i -- store kinds unevaluated - -addFKindTel :: FTelescope -> TypeCheck a -> TypeCheck a -addFKindTel (Telescope tel) = loop tel where - loop [] cont = cont - loop (TBind x dom : tel) cont = newTyVar x (typ dom) $ \ _ -> - loop tel cont - -extractTeleVal :: TeleVal -> TypeCheck FTelescope -extractTeleVal = Telescope <.> loop where - loop [] = return [] - loop (tb : vtel) = do - tb <- Traversable.mapM extractType tb - addBind tb $ do - (tb :) <$> loop vtel - -extractType :: TVal -> TypeCheck FType -extractType = extractTypeAt star - -extractTypeAt :: FKind -> TVal -> TypeCheck FType -extractTypeAt k tv = do - case (tv,k) of - - (VMeasured mu vb, _) -> extractTypeAt k vb - (VGuard beta vb, _) -> extractTypeAt k vb - - -- relevant function space / sigma type --> non-dependent - (VQuant pisig x dom fv, _) | not (erased (decor dom)) -> do - a <- extractType (typ dom) - -- new' x dom $ do - bv <- app fv VIrr - b <- extractType bv - let x = fresh "" - return $ piSig pisig (TBind x (defaultDomain a)) b - - -- irrelevant function space --> forall or erasure marker - (VQuant Pi x dom fv, _) | erased (decor dom) -> do - mk <- extractKind (typ dom) - case mk of - Nothing -> do -- new' x dom $ do - bv <- app fv VIrr - b <- extractType bv - let x = fresh "" - return $ pi (TBind x (defaultIrrDom Irr)) b - Just k' -> do - newTyVar x k' $ \ i -> do - bv <- app fv $ VGen i - b <- extractType bv - x <- nameOfGen i - return $ pi (TBind x (defaultIrrDom k')) b - - (VApp (VDef (DefId DatK n)) vs, _) -> do - k <- extrTyp <$> lookupSymbQ n -- get kind of dname from signature - as <- extractTypes k vs -- turn vs into types as at kind k - return $ foldl App (Def (DefId DatK n)) as - - (VGen i,_) -> do --- VClos _ k <- (typ . fromOne . domain) <$> lookupGen i -- get kind of var from cxt - Var <$> nameOfGen i - -- return $ Var (tyVarName i) - - (VApp (VGen i) vs,_) -> do - VClos _ k <- (typ . fromOne . domain) <$> lookupGen i -- get kind of var from cxt - as <- extractTypes k vs -- turn vs into types as at kind k - x <- nameOfGen i - return $ foldl App (Var x) as - - (VLam x env e, Quant Pi (TBind _ dom) k) | erased (decor dom) -> do - tv <- whnf (update env x VIrr) e - extractTypeAt k tv - - (VLam x env e, Quant Pi (TBind _ dom) k) -> newTyVar x (typ dom) $ \ i -> do - tv <- whnf (update env x (VGen i)) e - x <- nameOfGen i - Lam defaultDec x <$> extractTypeAt k tv - - (VLam{},_) -> error $ "panic! extractTypeAt " ++ show (tv,k) - - (VSing _ tv,_) -> extractTypeAt k tv - - (VUp v _,_) -> extractTypeAt k v - - _ -> return Irr - -extractTypes :: FKind -> [TVal] -> TypeCheck [FType] -extractTypes k vs = - case (k,vs) of - (_, []) -> return [] - (Quant Pi (TBind _ dom) k, v:vs) | erased (decor dom) -> extractTypes k vs - (Quant Pi (TBind _ dom) k, v:vs) -> do - v <- whnfClos v - a <- extractTypeAt (typ dom) v - as <- extractTypes k vs - return $ a : as - _ -> error $ "panic! extractTypes " ++ show k ++ " " ++ show vs - --- auxiliary functions ----------------------------------------------- - -{- this is setExtrTyp -addFTypeSig :: Name -> FType -> TypeCheck () -addFTypeSig n t = modifySig n (\ item -> item { extrTyp = t }) --} diff --git a/HsSyntax.hs b/HsSyntax.hs deleted file mode 100644 --- a/HsSyntax.hs +++ /dev/null @@ -1,129 +0,0 @@ -{- 2010-09-17 haskell syntax tools -} - -module HsSyntax where - -import Abstract (PiSigma(..)) -import Language.Haskell.Exts.Syntax - -noLoc :: SrcLoc -noLoc = SrcLoc "" 0 0 - -mkQual :: String -> String -> QName -mkQual m s = Qual (ModuleName m) (Ident s) - -mkModule :: [Decl] -> Module -mkModule hs = Module noLoc main_mod pragmas warning exports imports decls where - pragmas = [ LanguagePragma noLoc $ map Ident - [ "NoImplicitPrelude" - , "GADTs" - , "KindSignatures" - ]] - warning = Nothing - exports = Nothing - imports = - [ mkQualImport "GHC.Show" "Show" - , mkQualImport "System.IO" "IO" - , mkQualImport "Unsafe.Coerce" "Coerce" - ] - decls = hs ++ - [ TypeSig noLoc [ main_name ] io - , FunBind [ mkClause main_name [] rhs ] - ] where rhs = Var (mkQual "IO" "putStrLn") `App` Lit (String "Hello, world!") - io = TyCon (mkQual "IO" "IO") `TyApp` unit_tycon - -mkQualImport :: String -> String -> ImportDecl -mkQualImport modName asName = - ImportDecl - { importLoc = noLoc - , importModule = ModuleName modName - , importQualified = True - , importSrc = False - , importPkg = Nothing - , importAs = Just $ ModuleName asName - , importSpecs = Nothing - } - -noContext = [] -noDeriving = [] -noTyVarBind = [] -showDeriving = (mkQual "Show" "Show", []) - -mkDataDecl :: Name -> [TyVarBind] -> Kind -> [GadtDecl] -> Decl -mkDataDecl n tel k cs = GDataDecl noLoc DataType noContext n tel (Just k) cs [showDeriving] - -mkConDecl :: Name -> Type -> GadtDecl -mkConDecl n t = GadtDecl noLoc n t - -mkKindFun :: Kind -> Kind -> Kind -mkKindFun = KindFn -{- -mkKindFun k k' = parens k `KindFn` k' - where parens H.KindStar = H.KindStar - parens k = H.KindParen k --} - -mkTyPiSig :: PiSigma -> Type -> Type -> Type -mkTyPiSig Pi = mkTyFun -mkTyPiSig Sigma = mkTyProd - -mkTyProd :: Type -> Type -> Type -mkTyProd a b = TyTuple Boxed [a,b] - -mkTyFun :: Type -> Type -> Type -mkTyFun = TyFun --- mkTyFun a b = mkTyParen a `TyFun` b - -mkForall :: Name -> Kind -> Type -> Type -mkForall x k t = TyForall (Just $ [KindedVar x k]) noContext t - -mkTyParen :: Type -> Type -mkTyParen a@(TyVar{}) = a -mkTyParen a@(TyCon{}) = a -mkTyParen a = TyParen a - -mkTyApp :: Type -> Type -> Type -mkTyApp f a = TyApp f a - -noBinds = BDecls [] - -mkTypeSig :: Name -> Type -> Decl -mkTypeSig x t = TypeSig noLoc [x] t - --- create a simple function clause x = t -mkLet :: Name -> Exp -> Decl -mkLet x e = FunBind [mkClause x [] e] - -mkClause :: Name -> [Pat] -> Exp -> Match -mkClause f ps e = Match noLoc f ps Nothing (UnGuardedRhs e) noBinds - -mkCast :: Exp -> Exp -mkCast e = Var (mkQual "Coerce" "unsafeCoerce") `App` e - -mkCon :: Name -> Exp -mkCon = Con . UnQual - -mkVar :: Name -> Exp -mkVar = Var . UnQual - -mkLam :: Name -> Exp -> Exp -mkLam x (Lambda _ ps e) = Lambda noLoc (PVar x : ps) e -mkLam x e = Lambda noLoc [PVar x] e - -mkParen :: Exp -> Exp -mkParen e@(Var{}) = e -mkParen e@(Con{}) = e -mkParen e = Paren e - -mkApp :: Exp -> Exp -> Exp -mkApp f e = App f e -- (mkParen e) - -mkLLet :: Name -> Maybe Type -> Exp -> Exp -> Exp -mkLLet x t e e' = Let (BDecls [mkLet x e]) e' - -mkPair :: Exp -> Exp -> Exp -mkPair e1 e2 = Tuple Boxed [e1,e2] - -{- this is already predefined as unit_con -hsDummyExp :: HsExp -hsDummyExp = HsCon $ Special $ HsUnitCon -- Haskell's '()' --} diff --git a/Lexer.x b/Lexer.x deleted file mode 100644 --- a/Lexer.x +++ /dev/null @@ -1,208 +0,0 @@ - -{ - -module Lexer where - -} - -%wrapper "posn" - -$digit = 0-9 -- digits -$alpha = [a-zA-Z] -- alphabetic characters -$u = [ . \n ] -- universal: any character -@ident = $alpha ($alpha | $digit | \_ | \')* -- identifier - -tokens :- - -$white+ ; -"--".* ; -"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; - - -sized { tok (\p s -> Sized p) } -data { tok (\p s -> Data p) } -codata { tok (\p s -> CoData p) } -record { tok (\p s -> Record p) } -fields { tok (\p s -> Fields p) } -fun { tok (\p s -> Fun p) } -cofun { tok (\p s -> CoFun p) } -pattern { tok (\p s -> Pattern p) } -case { tok (\p s -> Case p) } -def { tok (\p s -> Def p) } -let { tok (\p s -> Let p) } -in { tok (\p s -> In p) } -eval { tok (\p s -> Eval p)} -fail { tok (\p s -> Fail p)} -check { tok (\p s -> Check p)} -trustme { tok (\p s -> TrustMe p)} -impredicative { tok (\p s -> Impredicative p)} -mutual { tok (\p s -> Mutual p) } -Type { tok (\p s -> Type p) } -Set { tok (\p s -> Set p) } -CoSet { tok (\p s -> CoSet p) } -"<|" { tok (\p s -> LTri p) } -"|>" { tok (\p s -> RTri p) } -Size { tok (\p s -> Size p) } -\# { tok (\p s -> Infty p) } -\$ { tok (\p s -> Succ p) } -max { tok (\p s -> Max p) } - -\{ { tok (\p s -> BrOpen p) } -\} { tok (\p s -> BrClose p) } -\[ { tok (\p s -> BracketOpen p) } -\] { tok (\p s -> BracketClose p) } -\( { tok (\p s -> PrOpen p) } -\) { tok (\p s -> PrClose p) } -\| { tok (\p s -> Bar p) } -\; { tok (\p s -> Sem p) } -\: { tok (\p s -> Col p) } -\, { tok (\p s -> Comma p) } -\. { tok (\p s -> Dot p) } -\+\+ { tok (\p s -> PlusPlus p) } -\+ { tok (\p s -> Plus p) } -\- { tok (\p s -> Minus p) } -\/ { tok (\p s -> Slash p) } -\* { tok (\p s -> Times p) } -\^ { tok (\p s -> Hat p) } -\& { tok (\p s -> Amp p) } -"->" { tok (\p s -> Arrow p) } -"<=" { tok (\p s -> Leq p) } -= { tok (\p s -> Eq p) } -\\ { tok (\p s -> Lam p) } -\_ { tok (\p s -> Underscore p) } -\< { tok (\p s -> AngleOpen p) } -\> { tok (\p s -> AngleClose p) } - -[$digit]+ { tok (\p s -> (Number s p )) } -@ident { tok (\p s -> (Id s p )) } -@ident \. @ident { tok (\p s -> (qualId s p)) } - -{ -data Token = Id String AlexPosn - | QualId (String, String) AlexPosn - | Number String AlexPosn - | Sized AlexPosn - | Data AlexPosn - | CoData AlexPosn - | Record AlexPosn - | Fields AlexPosn - | Mutual AlexPosn - | Fun AlexPosn - | CoFun AlexPosn - | Pattern AlexPosn - | Case AlexPosn - | Def AlexPosn - | Let AlexPosn - | In AlexPosn - | Type AlexPosn - | Set AlexPosn - | CoSet AlexPosn - | Eval AlexPosn - | Fail AlexPosn - | Check AlexPosn - | TrustMe AlexPosn - | Impredicative AlexPosn - -- size type - | Size AlexPosn - | Infty AlexPosn - | Succ AlexPosn - | Max AlexPosn - -- - | LTri AlexPosn - | RTri AlexPosn - | AngleOpen AlexPosn - | AngleClose AlexPosn - | BrOpen AlexPosn - | BrClose AlexPosn - | BracketOpen AlexPosn - | BracketClose AlexPosn - | PrOpen AlexPosn - | PrClose AlexPosn - | Bar AlexPosn - | Sem AlexPosn - | Col AlexPosn - | Comma AlexPosn - | Dot AlexPosn - | Arrow AlexPosn - | Leq AlexPosn - | Eq AlexPosn - | PlusPlus AlexPosn - | Plus AlexPosn - | Minus AlexPosn - | Slash AlexPosn - | Times AlexPosn - | Hat AlexPosn - | Amp AlexPosn - | Lam AlexPosn - | Underscore AlexPosn - | NotUsed AlexPosn -- so happy doesn't generate overlap case pattern warning - deriving (Eq) - -qualId s p = let (m, '.':n) = break (== '.') s in QualId (m,n) p - -prettyTok :: Token -> String -prettyTok c = "\"" ++ tk ++ "\" at " ++ (prettyAlexPosn pos) where - (tk,pos) = case c of - (Id s p) -> (show s,p) - (QualId (m, n) p) -> (show m ++ "." ++ show n, p) - (Number i p) -> (i,p) - Sized p -> ("sized",p) - Data p -> ("data",p) - CoData p -> ("codata",p) - Record p -> ("record",p) - Fields p -> ("fields",p) - Mutual p -> ("mutual",p) - Fun p -> ("fun",p) - CoFun p -> ("cofun",p) - Pattern p -> ("pattern",p) - Case p -> ("case",p) - Def p -> ("def",p) - Let p -> ("let",p) - In p -> ("in",p) - Eval p -> ("eval",p) - Fail p -> ("fail",p) - Check p -> ("check",p) - TrustMe p -> ("trustme",p) - Impredicative p -> ("impredicative",p) - Type p -> ("Type",p) - Set p -> ("Set",p) - CoSet p -> ("CoSet",p) - Size p -> ("Size",p) - Infty p -> ("#",p) - Succ p -> ("$",p) - Max p -> ("max",p) - LTri p -> ("<|",p) - RTri p -> ("|>",p) - AngleOpen p -> ("<",p) - AngleClose p -> (">",p) - BrOpen p -> ("{",p) - BrClose p -> ("}",p) - BracketOpen p -> ("[",p) - BracketClose p -> ("]",p) - PrOpen p -> ("(",p) - PrClose p -> (")",p) - Bar p -> ("|",p) - Sem p -> (";",p) - Col p -> (":",p) - Comma p -> (",",p) - Dot p -> (".",p) - Arrow p -> ("->",p) - Leq p -> ("<=",p) - Eq p -> ("=",p) - PlusPlus p -> ("++",p) - Plus p -> ("+",p) - Minus p -> ("-",p) - Slash p -> ("/",p) - Times p -> ("*",p) - Hat p -> ("^",p) - Amp p -> ("&",p) - Lam p -> ("\\",p) - Underscore p -> ("_",p) - _ -> error "not used" - - -prettyAlexPosn (AlexPn _ line row) = "line " ++ show line ++ ", row " ++ show row - -tok f p s = f p s - -} diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,136 +0,0 @@ -module Main where - -import Prelude hiding (null) - -import System.Environment -import System.Exit -import System.IO (stdout, hSetBuffering, BufferMode(..)) - -import qualified Language.Haskell.Exts.Syntax as H -import qualified Language.Haskell.Exts.Pretty as H - -import Lexer -import Parser - -import qualified Concrete as C -import qualified Abstract as A -import Abstract (Name) -import ScopeChecker -import Value -import TCM -import TypeChecker -import Extract -import ToHaskell - -import Util - -main :: IO () -main = do - hSetBuffering stdout NoBuffering - putStrLn "MiniAgda by Andreas Abel and Karl Mehltretter" - args <- getArgs - mapM_ mainFile args - -mainFile :: String -> IO () -mainFile fileName = do - putStrLn $ "--- opening " ++ show fileName ++ " ---" - file <- readFile fileName - let t = alexScanTokens file - let cdecls = parse t - -- putStrLn "--- parsing ---" - -- mapM (putStrLn . show) cdecls - putStrLn "--- scope checking ---" - adecls <- doScopeCheck cdecls - -- mapM (putStrLn . show) adecls - putStrLn "--- type checking ---" - (edecls, sig) <- doTypeCheck adecls - putStrLn "--- evaluating ---" - showAll sig adecls -{- - putStrLn "--- extracting ---" - edecls <- doExtract sig edecls - hsmodule <- doTranslate edecls - putStrLn $ H.prettyPrint hsmodule - -- printHsDecls hsdecls --} - putStrLn $ "--- closing " ++ show fileName ++ " ---" - --- print extracted program - -ppHsMode :: H.PPHsMode -ppHsMode = H.PPHsMode -- H.defaultMode - { H.classIndent = 2 - , H.doIndent = 3 - , H.caseIndent = 3 - , H.letIndent = 4 - , H.whereIndent = 2 - , H.onsideIndent = 1 - , H.spacing = False - , H.layout = H.PPOffsideRule - , H.linePragmas = False - } - -printHsDecls :: [H.Decl] -> IO () -printHsDecls hs = mapM_ (putStrLn . H.prettyPrintWithMode ppHsMode) hs - --- all let declarations -allLet :: Signature -> [A.Declaration] -> [(Name,A.Expr)] -allLet sig [] = [] -allLet sig (decl:xs) = - case decl of - (A.LetDecl True n tel _ e) | null tel -> - (n,e):(allLet sig xs) - _ -> allLet sig xs - - -showAll :: Signature -> [A.Declaration] -> IO () -showAll sig decl = mapM_ (showLet sig) $ allLet sig decl - -showLet :: Signature -> (Name,A.Expr) -> IO () -showLet sig (n,e) = do - r <- doWhnf sig e - case r of - Right (v,_) -> putStrLn $ show n ++ " has whnf " ++ show v - Left err -> do putStrLn $ "error during evaluation:\n" ++ show err - exitFailure - r <- doNf sig e - case r of - Right (v,_) -> putStrLn $ show n ++ " evaluates to " ++ show v - Left err -> do putStrLn $ "error during evaluation:\n" ++ show err - exitFailure - -doExtract :: Signature -> [A.EDeclaration] -> IO [A.EDeclaration] -doExtract sig decls = do - k <- runExtract sig $ extractDecls decls - case k of - Left err -> do - putStrLn $ "error during extraction:\n" ++ show err - exitFailure - Right (hs, _) -> - return hs - -doTranslate :: [A.EDeclaration] -> IO H.Module -doTranslate decls = do - k <- runTranslate $ translateModule decls - case k of - Left err -> do - putStrLn $ "error during extraction:\n" ++ show err - exitFailure - Right hs -> - return hs - -doTypeCheck :: [A.Declaration] -> IO ([A.EDeclaration], Signature) -doTypeCheck decls = do - k <- typeCheck decls - case k of - Left err -> do - putStrLn $ "error during typechecking:\n" ++ show err - exitFailure - Right (edecls, st) -> - return (edecls, signature st) - -doScopeCheck :: [C.Declaration] -> IO [A.Declaration] -doScopeCheck decl = case scopeCheck decl of - Left err -> do putStrLn $ "scope check error: " ++ show err - exitFailure - Right (decl',_) -> return $ decl' diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,111 +1,4 @@ -# Makefile for miniagda - -files=Abstract Collection Concrete Eval Extract HsSyntax Lexer Main Parser Polarity PrettyTCM ScopeChecker Semiring SparseMatrix TCM Termination ToHaskell Tokens TraceError TreeShapedOrder TypeChecker Util Value Warshall -hsfiles=$(foreach file,$(files),$(file).hs) -ghcflags=-ignore-package monads-fd -rtsopts -# -fglasgow-exts -optflags= -# -O #slow compilation, not much speedup -profflags=-prof -auto-all -distfiles=*.hs *.hs-boot Lexer.x Parser.y Makefile -distdirs=test/succeed test/fail examples - -cabalp=cabal install -p --enable-executable-profiling - -.PHONY : test succeed fail examples lib current default all clean veryclean - -default : Main test -all : Main test examples lib - -prof-current : miniagda-prof - miniagda-prof examples/FiCS12/fics12-06.ma +RTS -prof -s -# miniagda-prof test/succeed/Zero.ma +RTS -prof -s -# miniagda-prof privateExamples/NisseContNorm/negative-2010-11-23.ma +RTS -prof -current : Main -# Main test/fail/BoundedFake.ma - Main examples/Existential/StreamProcCase.ma -# Main test/features/Existential/list.ma -# Main test/features/Existential/nat.ma -# Main examples/RBTree/RBTreeConor.ma -# Main test/fail/InvalidField.ma -# Main test/succeed/BuiltinSigma.ma -# Main test/features/records.ma -# Main test/succeed/MeasuredHerSubst2.ma -# Main examples/Coinductive/SubjectReductionProblem.ma -# Main examples/Sized/Maximum.ma -# Main examples/Irrelevance/Vector.ma -# Main examples/JeffTerellCoqClub20100120.ma -# Main examples/HugoCantor/tryLoopInjData.ma -# Main examples/HugoCantor/InjDataLoop.ma -# Main test/features/countConstructors.ma -# Main examples/HugoCantor/injectiveData.ma -# Main examples/BoveCapretta/Eval.ma # vec.ma # examples/List.ma -# Main test/fail/OverlappingPatternIndFam.ma # vec.ma # examples/List.ma - -# ship : ../dist/miniagda-2009-07-03.tgz # 06-27.tgz -# -# ../dist/%.tgz : $(distfiles) -# tar czf $@ $^ $(distdirs) -# - -miniagda-prof : Main.hs $(hsfiles) - ghc $(ghcflags) $(profflags) $< --make -o $@ - -Main : Main.hs $(hsfiles) - ghc $(ghcflags) $(optflags) $< --make -o $@ - -install-prof-libs : - $(cabalp) transformers - $(cabalp) mtl - $(cabalp) syb - $(cabalp) parsec - $(cabalp) preprocessor-tools - $(cabalp) cpphs - $(cabalp) haskell-src-exts - $(cabalp) IfElse - $(cabalp) utility-ht - -SCT : SCT.hs Lexer.hs SCTParser.hs SCTSyntax.hs - ghc $(ghcflags) $< --make -o $@ - -Lexer.hs : Lexer.x - alex $< - -%arser.hs : %arser.y Lexer.hs - happy --info=$<-grm.txt $< - -test : Main succeed fail - -succeed : - @echo "======================================================================" - @echo "===================== Suite of successfull tests =====================" - @echo "======================================================================" - make -C test/succeed - -fail : - @echo "======================================================================" - @echo "======================= Suite of failing tests =======================" - @echo "======================================================================" - make -C test/fail - -examples : Main - @echo "======================================================================" - @echo "========================== Suite of examples =========================" - @echo "======================================================================" - make -C examples - -lib : Main - @echo "======================================================================" - @echo "=============================== Library ==============================" - @echo "======================================================================" - make -C lib - - -clean : - -rm *.o *.hi Main miniagda-prof -# make -C test/fail clean - -veryclean : clean - make -C test/fail clean +install : + cabal install # EOF diff --git a/MiniAgda.cabal b/MiniAgda.cabal --- a/MiniAgda.cabal +++ b/MiniAgda.cabal @@ -1,13 +1,13 @@ name: MiniAgda -version: 0.2014.9.12 +version: 0.2016.12.19 build-type: Simple -cabal-version: >= 1.8 +cabal-version: >= 1.22 license: OtherLicense license-file: LICENSE author: Andreas Abel and Karl Mehltretter maintainer: Andreas Abel homepage: http://www.tcs.ifi.lmu.de/~abel/miniagda/ -bug-reports: http://hub.darcs.net/abel/miniagda/issues +bug-reports: https://github.com/andreasabel/miniagda/issues category: Dependent types synopsis: A toy dependently typed programming language with type-based termination. description: @@ -22,7 +22,10 @@ Recent features include bounded size quantification and destructor patterns for a more general handling of coinduction. -tested-with: GHC == 7.8.3 +tested-with: GHC == 7.6.3 + GHC == 7.8.4 + GHC == 7.10.3 + GHC == 8.0.1 extra-source-files: Makefile @@ -35,20 +38,21 @@ test/fail/adm/*.err lib/*.ma source-repository head - type: darcs - location: http://hub.darcs.net/abel/miniagda + type: git + location: https://github.com/andreasabel/miniagda executable miniagda - hs-source-dirs: . + hs-source-dirs: src build-depends: array >= 0.3 && < 0.6, - base >= 4.2 && < 4.8, + base >= 4.6 && < 5, containers >= 0.3 && < 0.6, - haskell-src-exts >= 1.14 && < 1.16, + haskell-src-exts >= 1.17 && < 1.18, mtl >= 2.2.0.1 && < 2.3, pretty >= 1.0 && < 1.2 build-tools: happy >= 1.15 && < 2, alex >= 3.0 && < 4 - extensions: CPP + default-language: Haskell98 + default-extensions: CPP MultiParamTypeClasses TypeSynonymInstances FlexibleInstances diff --git a/Parser.y b/Parser.y deleted file mode 100644 --- a/Parser.y +++ /dev/null @@ -1,520 +0,0 @@ -{ -{-# LANGUAGE BangPatterns #-} -module Parser where - -import qualified Lexer as T -import qualified Concrete as C - -import Abstract (Decoration(..),Dec,defaultDec,Override(..)) -import Polarity (Pol(..)) -import qualified Abstract as A -import qualified Polarity as A -import Concrete (Name,patApp) -} - -%name parse -%tokentype { T.Token } -%error { parseError } - -%token - -id { T.Id $$ _ } -qualid { T.QualId $$ _ } -number { T.Number $$ _ } -data { T.Data _ } -codata { T.CoData _ } -record { T.Record _ } -sized { T.Sized _ } -fields { T.Fields _ } -mutual { T.Mutual _ } -fun { T.Fun _ } -cofun { T.CoFun _ } -pattern { T.Pattern _ } -case { T.Case _ } -def { T.Def _ } -let { T.Let _ } -in { T.In _ } -eval { T.Eval _ } -fail { T.Fail _ } -check { T.Check _ } -trustme { T.TrustMe _ } -impredicative { T.Impredicative _ } -type { T.Type _ } -set { T.Set _ } -coset { T.CoSet _ } -size { T.Size _ } -infty { T.Infty _ } -succ { T.Succ _ } -max { T.Max _ } -'<|' { T.LTri _ } -'|>' { T.RTri _ } -'<' { T.AngleOpen _ } -'>' { T.AngleClose _ } -'{' { T.BrOpen _ } -'}' { T.BrClose _ } -'[' { T.BracketOpen _ } -']' { T.BracketClose _ } -'(' { T.PrOpen _ } -')' { T.PrClose _ } -'|' { T.Bar _ } -',' { T.Comma _ } -';' { T.Sem _ } -':' { T.Col _ } -'.' { T.Dot _ } -'->' { T.Arrow _ } -'<=' { T.Leq _ } -'=' { T.Eq _ } -'++' { T.PlusPlus _ } -'+' { T.Plus _ } -'-' { T.Minus _ } -'/' { T.Slash _ } -- UNUSED -'*' { T.Times _ } -- UNUSED -'^' { T.Hat _ } -'&' { T.Amp _ } -'\\' { T.Lam _ } -'_' { T.Underscore _ } - -%% - -TopLevel :: { [C.Declaration] } -TopLevel : Declarations { reverse $1} - - -Declarations :: { [C.Declaration] } -Declarations : {- empty -} { [] } - | Declarations Declaration { $2 : $1 } - -Declaration :: { C.Declaration } -Declaration : Data { $1 } - | CoData { $1 } - | SizedData { $1 } - | SizedCoData { $1 } - | RecordDecl { $1 } - | Fun { $1 } - | CoFun { $1 } - | Mutual { $1 } - | Let { $1 } - | PatternDecl { $1 } - | impredicative Declaration { C.OverrideDecl Impredicative [$2] } - | impredicative '{' Declarations '}' { C.OverrideDecl Impredicative $3 } - | fail Declaration { C.OverrideDecl Fail [$2] } - | fail '{' Declarations '}' { C.OverrideDecl Fail $3 } - | check Declaration { C.OverrideDecl Check [$2] } - | check '{' Declarations '}' { C.OverrideDecl Check $3 } - | trustme Declaration { C.OverrideDecl TrustMe [$2] } - | trustme '{' Declarations '}' { C.OverrideDecl TrustMe $3 } -{- -Data :: { C.Declaration } -Data : data Id DataTelescope ':' Expr '{' Constructors '}' OptFields - { C.DataDecl $2 A.NotSized A.Ind $3 $5 (reverse $7) $9 } - -SizedData :: { C.Declaration } -SizedData : sized data Id DataTelescope ':' Expr '{' Constructors '}' OptFields - { C.DataDecl $3 A.Sized A.Ind $4 $6 (reverse $8) $10 } - -CoData :: { C.Declaration } -CoData : codata Id DataTelescope ':' Expr '{' Constructors '}' OptFields - { C.DataDecl $2 A.NotSized A.CoInd $3 $5 (reverse $7) $9 } - -SizedCoData :: { C.Declaration } -SizedCoData : sized codata Id DataTelescope ':' Expr '{' Constructors '}' OptFields - { C.DataDecl $3 A.Sized A.CoInd $4 $6 (reverse $8) $10 } - -RecordDecl :: { C.Declaration } -RecordDecl : record Id DataTelescope ':' Expr '{' Constructor '}' OptFields - { C.RecordDecl $2 $3 $5 $7 $9 } --} - -Data :: { C.Declaration } -Data : data DataDef - { let (n,tel,t,cs,fs) = $2 in C.DataDecl n A.NotSized A.Ind tel t cs fs } - -SizedData :: { C.Declaration } -SizedData : sized data DataDef - { let (n,tel,t,cs,fs) = $3 in C.DataDecl n A.Sized A.Ind tel t cs fs } - -CoData :: { C.Declaration } -CoData : codata DataDef - { let (n,tel,t,cs,fs) = $2 in C.DataDecl n A.NotSized A.CoInd tel t cs fs } - -SizedCoData :: { C.Declaration } -SizedCoData : sized codata DataDef - { let (n,tel,t,cs,fs) = $3 in C.DataDecl n A.Sized A.CoInd tel t cs fs } - -RecordDecl :: { C.Declaration } -RecordDecl : record DataDef1 - { let (n,tel,t,c,fs) = $2 in C.RecordDecl n tel t c fs } - -DataDef :: { (C.Name, C.Telescope, C.Type, [C.Constructor], [C.Name]) } -DataDef : Id DataTelescope ':' Expr '{' Constructors '}' OptFields - { ($1, $2, $4, reverse $6, $8)} - | Id DataTelescope '{' Constructors '}' OptFields - { ($1, $2, C.set0, reverse $4, $6)} - -DataDef1 :: { (C.Name, C.Telescope, C.Type, C.Constructor, [C.Name]) } -DataDef1 : Id DataTelescope ':' Expr '{' Constructor '}' OptFields - { ($1, $2, $4, $6, $8)} - | Id DataTelescope '{' Constructor '}' OptFields - { ($1, $2, C.set0, $4, $6)} - -Fun :: { C.Declaration } -Fun : fun TypeSig '{' Clauses '}' { C.FunDecl A.Ind $2 $4 } - -CoFun :: { C.Declaration } -CoFun : cofun TypeSig '{' Clauses '}' { C.FunDecl A.CoInd $2 $4 } - -Mutual :: { C.Declaration } -Mutual : mutual '{' Declarations '}' { C.MutualDecl (reverse $3) } - -Let :: { C.Declaration } -Let : Eval let LetDef { C.LetDecl $1 $3 } - -{- -Let : Eval let Id Telescope TypeOpt '=' ExprT { C.LetDecl $1 $3 $4 $5 $7 } --- Let : Eval let Id Telescope ':' Expr '=' ExprT { C.LetDecl $1 $3 $4 $6 $8 } --} - -LetDef :: { C.LetDef } -LetDef : PolId Telescope TypeOpt '=' ExprT { let (dec,n) = $1 in C.LetDef dec n $2 $3 $5 } - -Eval :: { Bool } -Eval : {- nothing -} { False } - | eval { True } - -TypeOpt :: { Maybe C.Type } -TypeOpt : {- nothing -} { Nothing } - | ':' Expr { Just $2 } - -{- -Let :: { C.Declaration } -Let : let TypeSig '=' ExprT { C.LetDecl False $2 $4 } - | eval let TypeSig '=' ExprT { C.LetDecl True $3 $5 } --} - -PatternDecl :: { C.Declaration } -PatternDecl : pattern SpcIds '=' PairP { C.PatternDecl (head $2) (tail $2) $4 } - - -OptFields :: { [Name] } -OptFields : {- empty -} { [] } - | fields Ids { $2 } ------ - -Id :: { Name } -Id : id { C.Name $1 } --- no longer number { $1 } - -SpcIds :: { [Name] } -- non-empty list -SpcIds : Id { [$1] } - | Id SpcIds { $1 : $2 } - -Ids :: { [Name] } -- non-empty list -Ids : Id { [$1] } - | Id ',' Ids { $1 : $3 } - -Pol :: { Pol } -Pol : '++' { SPos } - | '+' { Pos } - | '-' { Neg } - | '.' { Const } -- use bracket [..] - | '^' { Param } - | '*' { Rec } -- recursive --- | {- empty -} { Mixed } - -Measure :: { A.Measure C.Expr } -Measure : '|' Meas { A.Measure $2 } - -Meas :: { [C.Expr] } -Meas : Expr '|' { [$1] } - | Expr ',' Meas { $1 : $3 } - -Bound :: { A.Bound C.Expr } -Bound : Measure '<' Measure { A.Bound A.Lt $1 $3 } - | Measure '<=' Measure { A.Bound A.Le $1 $3 } {- (A.succMeasure C.Succ $3) } -} - -EIds :: { [Name] } -- non-empty list -EIds : ExprList { let { f (C.Ident (C.QName x)) = x - ; f e = error ("not an identifier: " ++ C.prettyExpr e) - } in map f $1 - } - -Telescope :: { C.Telescope } -Telescope : {- empty -} { [] } - | TBind Telescope { $1 : $2 } - | Measure Telescope { C.TMeasure $1 : $2 } - --- Binding. -TBind :: { C.TBind } -TBind - : '(' EIds ':' Expr ')' { C.TBind (Dec Default) $2 $4 } - | '(' Id '<' Expr ')' { C.TBounded A.defaultDec $2 A.Lt $4 } - | '(' Id '<=' Expr ')' { C.TBounded A.defaultDec $2 A.Le $4 } - | Pol '(' EIds ':' Expr ')' { C.TBind (Dec $1) $3 $5 } - | Pol '(' Id '<' Expr ')' { C.TBounded (Dec $1) $3 A.Lt $5 } - | Pol '(' Id '<=' Expr ')' { C.TBounded (Dec $1) $3 A.Le $5 } - | EBind { $1 } - | HBind { $1 } - --- Erased binding -EBind :: { C.TBind } -EBind - : '[' Ids ':' Expr ']' { C.TBind A.irrelevantDec $2 $4 } - | '[' Id '<' Expr ']' { C.TBounded A.irrelevantDec $2 A.Lt $4 } - | '[' Id '<=' Expr ']' { C.TBounded A.irrelevantDec $2 A.Le $4 } - --- Hidden binding -HBind :: { C.TBind } -HBind - : '{' Ids ':' Expr '}' { C.TBind A.Hidden $2 $4 } - | '{' Id '<' Expr '}' { C.TBounded A.Hidden $2 A.Lt $4 } - | '{' Id '<=' Expr '}' { C.TBounded A.Hidden $2 A.Le $4 } - - -UntypedBind :: { C.LBind } -UntypedBind : Id { C.TBind A.defaultDec [$1] Nothing } - | '[' Id ']' { C.TBind A.irrelevantDec [$2] Nothing } - | Pol Id { C.TBind (Dec $1) [$2] Nothing } - | Pol '(' Id ')' { C.TBind (Dec $1) [$3] Nothing } - -PolId :: { (Dec, C.Name) } -PolId : Id { (A.defaultDec , $1) } - | '[' Id ']' { (A.irrelevantDec, $2) } - | Pol Id { (Dec $1 , $2) } - -LLetDef :: { C.LetDef } -LLetDef : LetDef { $1 } --- legacy forms - | '[' Id ':' Expr ']' '=' Expr { C.LetDef A.irrelevantDec $2 [] (Just $4) $7 } -- erased binding - | Pol '(' Id ':' Expr ')' '=' Expr { C.LetDef (Dec $1) $3 [] (Just $5) $8 } -- ordinary binding - --- let binding -LBind :: { C.LBind } -LBind : UntypedBind { $1 } - | Id ':' Expr { C.TBind A.defaultDec [$1] (Just $3) } -- ordinary binding - | '(' Id ':' Expr ')' { C.TBind A.defaultDec [$2] (Just $4) } -- ordinary binding - | '[' Id ':' Expr ']' { C.TBind A.irrelevantDec [$2] (Just $4) } -- erased binding - | Pol '(' Id ':' Expr ')' { C.TBind (Dec $1) [$3] (Just $5) } -- ordinary binding --- | Pol '[' Id ':' Expr ']' { C.TBind (Dec True $1) [$3] $5 } -- erased binding - -Domain :: { C.Telescope } -Domain : Expr0 { [C.TBind (Dec Default) {- A.defaultDec -} [] $1] } - | '[' Expr ']' { [C.TBind A.irrelevantDec [] $2] } - | Pol Expr0 { [C.TBind (Dec $1) [] $2] } --- | Pol '[' Expr ']' { [C.TBind (Dec True $1) [] $3] } - | TBind { [$1] } - | Measure { [C.TMeasure $1] } - | Bound { [C.TBound $1] } - | Telescope { $1 } - - --- expressions which can be tuples e , e' -ExprT :: { C.Expr} -ExprT : ExprList { foldr1 C.Pair $1 } - -ExprList :: { [C.Expr] } -ExprList : Expr { [$1] } - | Expr ',' ExprList { $1 : $3 } - - --- general form of expression -Expr :: { C.Expr } -Expr : Domain '->' Expr { C.Quant A.Pi $1 $3 } - | '\\' SpcIds '->' ExprT { foldr C.Lam $4 $2 } - | let LLetDef in ExprT { C.LLet $2 $4 } - | case ExprT TypeOpt '{' Cases '}' { C.Case $2 $3 $5 } - | Expr0 { $1 } -- Sigma type - | Expr1 '+' Expr { C.Plus $1 $3 } - | Expr1 '<|' Expr { C.App $1 [$3] } - | Expr1 '|>' Expr { C.App $3 [$1] } - --- Sigma types (A & B, (x : A) & B) -Expr0 :: { C.Expr } -Expr0 : Expr1 { $1 } - | SigDom '&' Expr0 { C.Quant A.Sigma [$1] $3 } - --- SigDom ~ Domain, but no Telescope and no Expr0 -SigDom :: { C.TBind } -SigDom : Expr1 { C.TBind (Dec Default) {- A.defaultDec -} [] $1 } - | '[' Expr ']' { C.TBind A.irrelevantDec [] $2 } - | Pol Expr1 { C.TBind (Dec $1) [] $2 } --- | Pol '[' Expr ']' { C.TBind (Dec True $1) [] $3 } - | TBind { $1 } - | Measure { C.TMeasure $1 } - | Bound { C.TBound $1 } -- constraint - --- perform applications -Expr1 :: { C.Expr } -Expr1 : Expr2 { let (f : args) = reverse $1 in - if null args then f else C.App f args - } - | coset Expr3 { C.CoSet $2 } - | set { C.Set C.Zero } - | set Expr3 { C.Set $2 } - | number '*' Expr1 { let n = read $1 in - if n==0 then C.Zero else - iterate (C.Plus $3) $3 !! (n-1) } --- | EBind Expr1 { C.EBind $1 $2 } - --- gather applications -Expr2 :: { [C.Expr] } -Expr2 : Expr3 { [$1] } - | Expr2 Expr3 { $2 : $1 } - | Expr2 '.' Id { C.Proj $3 : $1 } - | Expr2 set { C.Set C.Zero : $1 } --- | succ SE { [C.Succ $2] } - --- atoms -Expr3 :: { C.Expr } -Expr3 : size { C.Size } - | max { C.Max } - | infty { C.Infty } - | QName { C.Ident $1} - | '<' ExprT ':' Expr '>' { C.Sing $2 $4 } - | '(' ExprT ')' { $2 } - | '_' { C.Unknown } - | succ Expr3 { C.Succ $2 } -- succ is a prefix op - | number { iterate C.Succ C.Zero !! (read $1) } - | record '{' RecordDefs '}' { C.Record $3 } - -QName :: { C.QName } -QName : qualid { let (m,n) = $1 in C.Qual (C.Name m) (C.Name n) } - | Id { C.QName $1} - -{- --- general form of type expression -Type :: { C.Expr } -Type : Domain '->' Type { C.Quant A.Pi $1 $3 } - | let LBind '=' ExprT in Type { C.LLet $2 $4 $6 } - | case ExprT '{' Cases '}' { C.Case $2 $4 } - | Type1 { $1 } - --- perform applications -Type1 :: { C.Expr } -Type1 : Type2 { let (f : args) = reverse $1 in - if null args then f else C.App f args - } - | coset Expr3 { C.CoSet $2 } - | set { C.Set C.Zero } - | set Expr3 { C.Set $2 } - | Domain '&' Type1 { C.Quant A.Sigma $1 $3 } - --- gather applications -Type2 :: { [C.Expr] } -Type2 : Type3 { [$1] } - | Type2 Expr3 { $2 : $1 } - | Type2 '.' Id { C.Proj $3 : $1 } - | Type2 set { C.Set C.Zero : $1 } - --- type atoms -Type3 :: { C.Expr } -Type3 : size { C.Size } - | Id { C.Ident $1} - | '(' Type ')' { $2 } - | '_' { C.Unknown } --} - -RecordDefs :: { [([Name],C.Expr)] } -RecordDefs - : RecordDef ';' RecordDefs { $1 : $3 } - | RecordDef { [$1] } - | {- empty -} { [] } - -RecordDef :: { ([Name],C.Expr) } -RecordDef : SpcIds '=' ExprT { ($1,$3) } - -TypeSig :: { C.TypeSig } -TypeSig : Id ':' Expr { C.TypeSig $1 $3 } - -Constructor :: { C.Constructor } -Constructor : Id Telescope ':' Expr { C.Constructor $1 $2 (Just $4) } - | Id Telescope { C.Constructor $1 $2 Nothing } - -Constructors :: { [C.Constructor ] } -Constructors : - Constructors ';' Constructor { $3 : $1 } - | Constructors ';' { $1 } - | Constructor { [$1] } - | {- empty -} { [] } - -Cases :: { [C.Clause] } -Cases : Pattern '->' ExprT ';' Cases { (C.Clause Nothing [$1] (Just $3)) : $5 } - | Pattern '->' ExprT { (C.Clause Nothing [$1] (Just $3)) : [] } - | Pattern ';' Cases { (C.Clause Nothing [$1] Nothing) : $3 } - | Pattern { (C.Clause Nothing [$1] Nothing) : [] } - | {- empty -} { [] } - -Clause :: { C.Clause } -Clause : Id LHS '=' ExprT { C.Clause (Just $1) $2 (Just $4) } - | Id LHS { C.Clause (Just $1) $2 Nothing } - -LHS :: { [C.Pattern] } -LHS : Patterns { reverse $1 } - -Patterns :: { [C.Pattern] } -Patterns : {- empty -} { [] } --- | Pattern Patterns { $1 : $2 } - | Patterns Pattern { $2 : $1 } - | Patterns '<|' ElemP { $3 : $1 } - --- atomic patterns -Pattern :: { C.Pattern } -Pattern : '(' ')' { C.AbsurdP } - | '(' PairP ')' { $2 } - | DotId { $1 } - | succ Pattern { C.SuccP $2 } - | '.' set { C.DotP (C.Set C.Zero) } - | '.' Expr3 { C.DotP $2 } - --- pattern tuples -PairP :: { C.Pattern } -PairP : ElemP ',' PairP { C.PairP $1 $3 } - | ElemP { $1 } - -ElemP :: { C.Pattern } -ElemP : ConP { $1 } - | Expr3 '>' Id { C.SizeP $1 $3 } - | Id '<' Expr3 { C.SizeP $3 $1 } - | Pattern { $1 } - | ConP '<|' ElemP { patApp $1 [$3] } -- '<|' is Haskell's '$' (appl.) - --- constructor with at least one argument pattern -ConP :: { C.Pattern } -ConP : DotId Pattern { patApp $1 [$2] } - | ConP Pattern { patApp $1 [$2] } - -DotId :: { C.Pattern } -DotId : Id { C.IdentP (C.QName $1) } - | '.' Id { C.ConP True (C.QName $2) [] } - - -Clauses :: { [C.Clause] } -Clauses : RClauses { reverse $1 } - -RClauses :: { [C.Clause ] } -RClauses - : RClauses ';' Clause { $3 : $1 } - | RClauses ';' { $1 } - | Clause { [$1] } - | {- empty -} { [] } - --- Binding in data telescope, supports (+ X : Set) for backwards compatibility -TBindSP :: { C.TBind } -TBindSP - : '(' Ids ':' Expr ')' { C.TBind (Dec Default) $2 $4 } -- ordinary binding - | '[' Ids ':' Expr ']' { C.TBind A.irrelevantDec $2 $4 } -- erased bind. - | Pol '(' Ids ':' Expr ')' { C.TBind (Dec $1) $3 $5 } - | '(' '+' Ids ':' Expr ')' { C.TBind (Dec SPos) $3 $5 } - --- | '(' sized Id ')' { C.TSized $3 } - -DataTelescope :: { C.Telescope } -DataTelescope : {- empty -} { [] } - | TBindSP DataTelescope { $1 : $2 } - -{ - -parseError :: [T.Token] -> a -parseError [] = error "Parse error at EOF" -parseError (x : xs) = error ("Parse error at token " ++ T.prettyTok x) - -} diff --git a/Polarity.hs b/Polarity.hs deleted file mode 100644 --- a/Polarity.hs +++ /dev/null @@ -1,421 +0,0 @@ -{- In the context of polarities, we use "recursive" in the sense of -"computable" rather than syntactic recursion. -} - -module Polarity where - -import Util -import Warshall - -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.List as List - -{- 2010-10-09 Fusing polarity and irrelevance - - . constant (= irrelevant) function - / \ - ++ | strictly positive function (types only) - | | - + - positive/negative function (types only) - \ / - ^ parametric function (lambda cube), default for types - | - * recursive function (pattern matching), default for terms - - - Composition (AC) - - . p = . - * p = * (p not .) - ^ p = ^ (p not .,*) - ++ p = p - + p = p (p not ++) - - - = + - -Equality/subtyping <=p - - x <=. y iff true - x <=- y iff x >= y - x <=^ y iff x == y - x <=* y iff x == y - -} - --- polarities and strict positivity ---------------------------------- - -class Polarity pol where - erased :: pol -> Bool - compose :: pol -> pol -> pol - neutral :: pol -- ^ neutral for compose. - promote :: pol -> pol - demote :: pol -> pol - hidden :: pol -- ^ corresponding to hidden quantification - -type PVarId = Int - -data Pol - = Const -- non-occurring, irrelevant - | SPos -- strictly positive - | Pos -- positive - | Neg -- negative, used internally for contravariance of sized codata - | Param -- parametric (lambda) function - | Rec -- recursive (takes decision) - | Default -- no polarity given (for parsing) - | PVar PVarId -- flexible polarity variable - deriving (Eq,Ord) - -mixed = Rec -defaultPol = Rec -{- -mixed = Param -- TODO: Rec -defaultPol = Param -- TODO: Rec --} -instance Polarity Pol where - erased = (==) Const - compose = polComp - neutral = SPos - promote = invComp Const - demote = invComp Rec - hidden = Const - -instance Show Pol where - show Const = "." - show SPos = "++" - show Pos = "+" - show Neg = "-" - show Param = "^" - show Rec = "*" - show Default = "{default polarity}" - show (PVar i) = showPVar i - -showPVar i = "?p" ++ show i - -isPVar (PVar{}) = True -isPVar _ = False - --- information ordering -leqPol :: Pol -> Pol -> Bool -leqPol x Const = True -- Const is top -leqPol Const x = False -leqPol Rec y = True -- Rec is bottom -leqPol x Rec = False -leqPol Param y = True -- Param is second bottom -leqPol x Param = False -leqPol Pos SPos = True -leqPol x y = x == y - -{- RETIRED -isSPos :: Pol -> Bool -isSPos SPos = True -isSPos Const = True -isSPos _ = False --} - -{- NOT USED -isPos :: Pol -> Bool -isPos Pos = True -isPos x = isSPos x --} - --- polarity negation --- used in Eval.hs leqVals' for switching sides --- this means it is only applied to Pos, Neg, Param, --- never to SPos, Const, or polarity expressions -polNeg :: Pol -> Pol -polNeg Const = Const -polNeg SPos = Neg -polNeg Pos = Neg -polNeg Neg = Pos -polNeg Param = Param -polNeg Rec = Rec - --- polarity composition --- used in Eval.hs leqVals' -polComp :: Pol -> Pol -> Pol -polComp Const x = Const -- most dominant -polComp x Const = Const -polComp Rec x = Rec -- dominant except for Const -polComp x Rec = Rec -polComp Param x = Param -- dominant except for Const, Rec -polComp x Param = Param -polComp SPos x = x -- neutral -polComp x SPos = x -polComp Pos x = x -- neutral except for SPos -polComp x Pos = x -polComp Neg Neg = Pos -- order 2 -{- pol.comp. is ass., comm., with neutral ++, and infinity Const - cancellation does not hold, since composition with anything by ++ is - information loss: - q p <= q p' ==> p <= p' - only if q = ++ (then it is trivial anyway) -} - --- polarity inverse composition (see Abel, MSCS 2008) --- invComp p q1 <= q2 <==> q1 <= polComp p q2 --- used in TCM.hs cxtApplyDec -invComp :: Pol -> Pol -> Pol -invComp Rec Rec = Rec -- in rec. arg. keep only rec. vars -invComp Rec x = Const -- all others are declared unusable -invComp Param Param = Param -- in parametric mixed arg, keep only mixed vars -invComp Param x = Const -invComp Const x = Param -- a constant function can take any argument -invComp SPos x = x -- SPos is the identity -invComp p SPos = Const -- SPos preserved only under SPos -invComp Pos x = x -- x not SPos -invComp Neg x = polNeg x -- x not SPos - -{- UNUSED -invCompExpr :: Pol -> PExpr -> PExpr -invCompExpr q (PValue p) = PValue $ invComp q p -invCompExpr q (PExpr q' i) = PExpr (polComp q q') i --} - --- polarity conjuction (infimum) --- used in comparing spines -polAnd :: Pol -> Pol -> Pol -polAnd Const x = x -- most information -polAnd x Const = x -polAnd Rec x = Rec -- least information -polAnd x Rec = Rec -{- -polAnd Param x = Param -- 2nd least information -polAnd x Param = Param --} -polAnd x y | x == y = x -- same information -polAnd SPos Pos = Pos -- SPos is more informative than Pos -polAnd Pos SPos = Pos -{- -polAnd SPos Neg = Param -polAnd Neg SPos = Param --} -polAnd _ _ = Param -- remaining cases: conflicting info or Param - -instance SemiRing Pol where - oplus = polAnd - otimes = polComp - ozero = Const -- dominant for composition, neutral for infimum - oone = SPos -- neutral for composition - --- computing a relation from <= -relPol :: Pol -> (a -> a -> Bool) -> (a -> a -> Bool) -relPol Const r a b = True -relPol Rec r a b = r a b && r b a -relPol Param r a b = r a b && r b a -relPol Neg r a b = r b a -relPol Pos r a b = r a b -relPol SPos r a b = r a b - -relPolM :: (Monad m) => Pol -> (a -> a -> m ()) -> (a -> a -> m ()) -relPolM Const r a b = return () -relPolM Rec r a b = r a b >> r b a -relPolM Param r a b = r a b >> r b a -relPolM Neg r a b = r b a -relPolM Pos r a b = r a b -relPolM SPos r a b = r a b - --- polarity product (composition of polarities) ---------------------- - -data Multiplicity = POne | PTwo deriving (Eq, Ord) - -instance Show Multiplicity where - show POne = "1" - show PTwo = "2" - --- addition modulo 2 -addMultiplicity :: Multiplicity -> Multiplicity -> Multiplicity -addMultiplicity PTwo y = y -addMultiplicity x PTwo = x -addMultiplicity POne POne = PTwo - -type VarMults = Map PVarId Multiplicity -- multiplicity of variables (1 or 2) - -showMults :: VarMults -> String -showMults mults = - let ml = Map.toList mults -- get list of (key,value) pairs - l = concat $ map f ml where - f (k, POne) = [k] - f (k, PTwo) = [k,k] - in Util.showList "." showPVar l - -multsEmpty = Map.empty - -multsSingle :: Int -> VarMults -multsSingle i = Map.insert i POne multsEmpty - - -data PProd = PProd - { coeff :: Pol -- a coefficient, excluding PVar - , varMults :: VarMults -- multiplicity of variables (1 or 2) - } deriving (Eq,Ord) - -instance Polarity PProd where - erased = erased . coeff - compose = polProd - neutral = PProd SPos multsEmpty - demote = undefined - promote = undefined - hidden = PProd hidden multsEmpty - -instance Show PProd where - show (PProd Const _) = show Const - show (PProd SPos m) = if Map.null m then show SPos else showMults m - show (PProd q m) = separate "." (show q) (showMults m) - -pprod :: Pol -> PProd -pprod (PVar i) = PProd SPos (multsSingle i) -pprod q = PProd q multsEmpty - --- | fails if not a simple polarity -fromPProd :: PProd -> Maybe Pol -fromPProd (PProd Const _) = Just Const -fromPProd (PProd p m) | Map.null m = Just p -fromPProd _ = Nothing - -isSPos :: PProd -> Bool -isSPos (PProd Const _) = True -isSPos (PProd SPos m) = Map.null m -isSPos _ = False - --- multiply two products - -polProd :: PProd -> PProd -> PProd -polProd (PProd q1 m1) (PProd q2 m2) = PProd (polComp q1 q2) $ - Map.unionWith addMultiplicity m1 m2 - --- polarity expressions are polynomials ------------------------------ - -data PPoly = PPoly { monomials :: [PProd] } deriving (Eq,Ord) - -instance Show PPoly where - show (PPoly []) = show Const - show (PPoly [m]) = show m - show (PPoly l) = Util.showList "/\\" show l - -ppoly :: PProd -> PPoly -ppoly (PProd Const _) = PPoly [] -ppoly pp = PPoly [pp] - -polSum :: PPoly -> PPoly -> PPoly -polSum (PPoly x) (PPoly y) = PPoly $ List.nub $ x ++ y - -polProduct :: PPoly -> PPoly -> PPoly -polProduct (PPoly l1) (PPoly l2) = - let ps = [ polProd x y | x <- l1, y <- l2] - in PPoly $ List.nub $ ps - -instance SemiRing PPoly where - oplus = polSum - otimes = polProduct - ozero = PPoly [] - oone = PPoly [PProd SPos Map.empty] - -{- -data PExpr - = PValue Pol -- constant polarity - | PExpr Pol Int -- PExpr q pi means q^_1 pi (pi is the number of the var) - --- a polarity variable -pvar :: Int -> PExpr -pvar = PExpr SPos -- ++ is the neutral element of inverse polarity composition - -instance Show PExpr where - show (PValue p) = show p - show (PExpr SPos i) = "?p" ++ show i - show (PExpr q i) = show q ++ "^-1(?p" ++ show i ++ ")" --} - - -{- ML-style Polarity inference - -Preliminaries: -1. constructor types are mixed-variant function types only -2. matching is only allowed on mixed-variant arguments - 1+2 are both consequences that only type-valued functions have variance - and 1. data constructors are not types, 2. types are not matched on - -Concrete syntax - - f : (xs : As) -> C (C not a Pi-type) - f = t - -is parsed as abstract syntax - - f : pis(xs : As) -> C - f = t - -where pi_1..n are fresh polarity variables - -Then t is type-checked to infer the polarity variables, e.g. - - f xs = t - - pis(xs : As) |- t : C - -Now what can happen? - -Variable: t = x_i. Then we add a constraint pi_i <= ++ - -Application t = u v where u : q(x:B) -> D - - q^-1(pis(xs: As)) |- v : B - - A term q^-1 pi arises where q is a polarity constant (!, ML-inference) - or a polarity variable (recursion!, e.g. u = f) - and pi is a polarity expression - -In the context, keep SOLL and HABEN - - SOLL is the original polarity (variable or constant) - HABEN is a (ordered) list of pol.vars. and a pol.const. (default: ++) - -Variable : add constraint SOLL <= HABEN -Application: add q to HABEN by polarity multiplication (q is a var or const) -Abstraction: \xt : q(x:A) -> B: continue with x (SOLL = q, HABEN = ++) - -What kind of constraints do arise -1) q <= pi [ from variables , pi is a Pol-product ] -2) ++ <= pis [ from positivity graph, pis is a sum of Pol-products ] - this means ++ <= pi for all pi in pis - -Solving constraints - -- discard o <= pi and q <= / (do not even need to add them) -- all pvars which are not bounded below (appearing in one q in 1) - can be instantiated to / which will remove some constraints - - --} - -{- Mutual recursion - -In mutual declarations, use the following Ansatz: data/codata ++, functions o - - A = B -> A - B = A -> B - -A (B) is positive in its own body and negative in the body of B (A) - - F A B = B -> A F(-,++) - G A B = A -> B G(-,++) - - F A B = G A B -> F A B - G A B = F A B -> G A B - - Polarities: - F : fa * -> fb * -> * - G : ga * -> gb * -> * - - A : -fa, B : -fb |- G A B : * ==> -fa <= ga, -fb <= gb - A : -ga, B : -gb |- F A B : * ==> -ga <= fa, -gb <= fb - --} - -{- Pure polarity inference - -Judgement: pis(xs:As) |- t : B ---> C - -Variable: pis(xs:As) |- xi : Ai ---> pi_i <= ++ - -Application: Delta |- u : q(x:A) -> B ---> C1 - Delta |- v : A ---> C2 - -------------------------------------------------- - Delta |- u v : B[u/x] ---> C1,C2,q(Delta) <= Delta --} diff --git a/PrettyTCM.hs b/PrettyTCM.hs deleted file mode 100644 --- a/PrettyTCM.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module PrettyTCM where - -import Prelude hiding (sequence, mapM) - -import Abstract -import {-# SOURCE #-} Eval -import {-# SOURCE #-} TCM -import qualified Util -import Value - -import Control.Applicative hiding (empty) -import Control.Monad ((<=<)) -import Data.Traversable - -import qualified Text.PrettyPrint as P - - --- from Agda.TypeChecking.Pretty - -type Doc = P.Doc - -empty, comma, colon :: Monad m => m Doc - -empty = return P.empty -comma = return P.comma -colon = text ":" -pretty x = return $ Util.pretty x --- prettyA x = P.prettyA x -text s = return $ P.text s -pwords s = map return $ Util.pwords s -fwords s = return $ Util.fwords s -sep ds = P.sep <$> sequence ds -fsep ds = P.fsep <$> sequence ds -hsep ds = P.hsep <$> sequence ds -vcat ds = P.vcat <$> sequence ds -d1 $$ d2 = (P.$$) <$> d1 <*> d2 -d1 <> d2 = (P.<>) <$> d1 <*> d2 -d1 <+> d2 = (P.<+>) <$> d1 <*> d2 -nest n d = P.nest n <$> d -braces d = P.braces <$> d -brackets d = P.brackets <$> d -parens d = P.parens <$> d - -prettyList ds = brackets $ fsep $ punctuate comma ds - -punctuate _ [] = [] -punctuate d ds = zipWith (<>) ds (replicate n d ++ [empty]) - where - n = length ds - 1 - --- monadic pretty printing - -class ToExpr a where - toExpression :: a -> TypeCheck Expr - -instance ToExpr Expr where - toExpression = return - -instance ToExpr Val where - toExpression = toExpr - - -class PrettyTCM a where - prettyTCM :: a -> TypeCheck Doc - -instance PrettyTCM Name where - prettyTCM = pretty - -instance PrettyTCM Pattern where - prettyTCM = pretty - -instance PrettyTCM [Pattern] where - prettyTCM = sep . map pretty - -instance PrettyTCM Expr where - prettyTCM = pretty - -instance PrettyTCM (Sort Expr) where - prettyTCM = pretty - -instance PrettyTCM Val where - prettyTCM = pretty <=< toExpr - -instance PrettyTCM [Val] where - prettyTCM = sep . map (pretty <=< toExpr) - -instance PrettyTCM (Sort Val) where - prettyTCM = pretty <=< mapM toExpr - -instance PrettyTCM a => PrettyTCM (OneOrTwo a) where - prettyTCM (One a) = prettyTCM a - prettyTCM (Two a1 a2) = prettyTCM a1 <+> text "||" <+> prettyTCM a2 - -instance (ToExpr a) => PrettyTCM (Measure a) where - prettyTCM mu = pretty =<< mapM toExpression mu - -instance (ToExpr a) => PrettyTCM (Bound a) where - prettyTCM beta = pretty =<< mapM toExpression beta - -instance (PrettyTCM a, PrettyTCM b) => PrettyTCM (a,b) where - prettyTCM (a,b) = parens $ prettyTCM a <> comma <+> prettyTCM b diff --git a/ScopeChecker.hs b/ScopeChecker.hs deleted file mode 100644 --- a/ScopeChecker.hs +++ /dev/null @@ -1,1124 +0,0 @@ --- NOTE: insertion of polarity variables disabled here, must be done --- in TypeChecker - -{-# LANGUAGE TupleSections, DeriveFunctor, GeneralizedNewtypeDeriving, - FlexibleContexts, FlexibleInstances, UndecidableInstances, - MultiParamTypeClasses #-} - -module ScopeChecker (scopeCheck) where - -import Prelude hiding (mapM, null) - -import Control.Applicative -import Control.Monad.Identity hiding (mapM) -import Control.Monad.Reader hiding (mapM) -import Control.Monad.State hiding (mapM) -import Control.Monad.Except hiding (mapM) - -import Data.List as List hiding (null) -import Data.Maybe -import Data.Traversable (mapM) - -import Debug.Trace - -import Polarity(Pol(..)) -import qualified Polarity as A -import Abstract (Sized,mkExtRef,Co,ConK(..),PrePost(..),MVar,Decoration(..),Override(..),Measure(..),adjustTopDecsM,Arity,polarity,LensPol(..)) -import qualified Abstract as A -import qualified Concrete as C - -import TraceError - -import Util - --- * scope checker --- check that all identifiers are in scope and global identifiers are only used once --- replaces Ident with Con, Def, Let or Var --- replaces IdentP with ConP or VarP in patterns --- replaces Unknown by a new Meta-Variable --- check pattern length is equal in each clause --- group mutual declarations - --- | Entry point for scope checker. -scopeCheck :: [C.Declaration] -> Either TraceError ([A.Declaration],SCState) -scopeCheck dl = runScopeCheck initCtx initSt (scopeCheckDecls dl) - --- * Local identifiers. - --- ** local environment of scope checker - -data SCCxt = SCCxt - { stack :: Stack -- ^ Local names in scope. - -- We keep a stack of these to disallow shadowing on the same level. - , defaultPolarity :: Pol -- ^ Replacement for @Default@ polarity. - , constraintAllowed :: Bool -- ^ Is a constraint @|m| < |m'|@ legal now, since we just parsed a quantifier? - } - -type Stack = [Context] - -initCtx :: SCCxt -initCtx = SCCxt - { stack = [[]] -- one empty context to begin with - , defaultPolarity = A.Rec -- POL VARS DISABLED!! - , constraintAllowed = False - } - --- ** A lens for @constraintAllowed@ - -class LensConstraintAllowed a where - mapConstraintAllowed :: (Bool -> Bool) -> a -> a - setConstraintAllowed :: Bool -> a -> a - setConstraintAllowed b = mapConstraintAllowed (const b) - -instance LensConstraintAllowed SCCxt where - mapConstraintAllowed f sc = sc { constraintAllowed = f (constraintAllowed sc) } - -instance (LensConstraintAllowed r, MonadReader r m) => LensConstraintAllowed (m a) where - mapConstraintAllowed f = local (mapConstraintAllowed f) - --- ** Managing the stack of local contexts. - -newLevel :: ScopeCheck a -> ScopeCheck a -newLevel = local $ \ cxt -> cxt { stack = [] : stack cxt } - -thisLevel :: SCCxt -> Context -thisLevel cxt = head (stack cxt) - -instance Push Local SCCxt where - push nx sc = sc { stack = push nx (stack sc) } - --- ** translating concrete names to abstract names - -type Local = (C.Name,A.Name) -type Context = [Local] - -emptyCtx :: Context -emptyCtx = [] - -newLocal :: Push Local b => C.Name -> b -> (A.Name, b) -newLocal n cxt = (x, push (n, x) cxt) - where x = A.fresh $ C.theName n - -lookupLocal :: C.Name -> ScopeCheck (Maybe A.Name) -lookupLocal n = retrieve n <$> asks stack - -lookupGlobal :: C.QName -> ScopeCheck (Maybe DefI) -lookupGlobal n = lookupSig n <$> getSig - -addContext :: Context -> SCCxt -> SCCxt -addContext delta sc = sc { stack = delta : stack sc } - --- * Global identifiers. - --- | Kind of identifier. -data IKind - = DataK - | ConK ConK - | FunK Bool -- ^ @False@ = inside body, @True@ = outside body - | ProjK -- ^ a record projection - | LetK - --- | Global identifier. -data DefI = DefI { ikind :: IKind, aname :: A.QName } - --- | Scope check signature. -type Sig = [(C.QName,DefI)] - -emptySig :: Sig -emptySig = [] - -lookupSigU :: C.Name -> Sig -> Maybe DefI -lookupSigU n = lookupSig (C.QName n) - -lookupSig :: C.QName -> Sig -> Maybe DefI -lookupSig n [] = Nothing -lookupSig n ((x,k):xs) = if (x == n) then Just k else lookupSig n xs - --- ** State of scope checker. - -data SCState = SCState - { signature :: Sig - , nextMeta :: MVar - , nextPolVar :: MVar - } - -initSt = SCState emptySig 0 0 - --- * The scope checking monad. - --- | Scope checking monad. --- --- Reader monad for local environment of variables (used in expresssions and patterns). --- State monad (hidden) for global signature. --- Error monad for reporting scope violations. -newtype ScopeCheck a = ScopeCheck { unScopeCheck :: - ReaderT SCCxt (StateT SCState (ExceptT TraceError Identity)) a } - deriving (Functor, Applicative, Monad, - MonadReader SCCxt, MonadError TraceError) - -runScopeCheck - :: SCCxt -- ^ Local variable mapping. - -> SCState -- ^ Global identifier mapping. - -> ScopeCheck a -- ^ The computation. - -> Either TraceError (a, SCState) -runScopeCheck ctx st (ScopeCheck sc) = runIdentity $ runExceptT $ - runStateT (runReaderT sc ctx) st - --- ** Local state. - --- | Add a local identifier. --- (Not tail recursive, since it also returns the generate id.) -addBind' :: Show e => e -> C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck (A.Name, a) -addBind' e n k = do - ctx <- ask - case retrieve n (thisLevel ctx) of - Just _ -> errorAlreadyInContext e n - Nothing -> do - let (x, ctx') = newLocal n ctx -- addCtx' n ctx - a <- local (const ctx') $ k x - return (x, a) - -addBind :: Show e => e -> C.Name -> ScopeCheck a -> ScopeCheck (A.Name, a) -addBind e n k = addBind' e n $ const k - -addBinds :: Show e => e -> [C.Name] -> ScopeCheck a -> ScopeCheck ([A.Name], a) -addBinds e ns k = foldr step start ns where - start = do - a <- k - return ([], a) - step n k = do - (x, (xs, a)) <- addBind e n k - return (x:xs, a) - --- | Add local variable without checking shadowing. -addLocal :: C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck a -addLocal n k = do - ctx <- ask - let (x, ctx') = newLocal n ctx - local (const ctx') $ k x - -addTel :: C.Telescope -> A.Telescope -> ScopeCheck a -> ScopeCheck a -addTel ctel atel = local (addContext nxs) - where nxs = reverse $ zipTels ctel atel - -zipTels :: C.Telescope -> A.Telescope -> [(C.Name,A.Name)] -zipTels ctel atel = zip ns xs - where ns = collectTelescopeNames ctel - xs = map A.boundName $ A.telescope atel - --- ** Global state. - -getSig :: ScopeCheck Sig -getSig = ScopeCheck $ gets signature - --- | Add a global identifier. -addName :: IKind -> C.Name -> ScopeCheck A.Name -addName k n = do - sig <- getSig - when (isJust (lookupSig (C.QName n) sig)) $ - errorAlreadyInSignature "shadowing of global definitions forbidden" n - let x = A.fresh $ C.theName n - addANameU k n x - return x - --- addNameU :: IKind -> C.Name -> ScopeCheck A.Name --- addNameU k n = A.unqual <$> addName k (C.QName n) - --- | Add an already translated global identifier. -addAName :: IKind -> C.QName -> A.QName -> ScopeCheck () -addAName k n x = ScopeCheck $ modify $ \ st -> - st { signature = (n, DefI k x) : signature st } - -addANameU :: IKind -> C.Name -> A.Name -> ScopeCheck () -addANameU ki n x = addAName ki (C.QName n) (A.QName x) - --- | Add or reuse an unqualified name. -overloadName :: IKind -> C.Name -> ScopeCheck A.Name -overloadName k n = do - sig <- getSig - case lookupSigU n sig of - Nothing -> do - let x = A.fresh $ C.theName n - addANameU k n x - return x - Just (DefI k' (A.QName x)) -> return x - -{- UNUSED -addDecl :: C.Declaration -> ScopeCheck A.Name -addDecl (C.DataDecl n _ _ _ _ _ _) = addName DataK n -addDecl (C.RecordDecl n _ _ _ _) = addName DataK n --} -{- UNUSED -addFunDecl :: Bool -> C.Declaration -> ScopeCheck A.Name -addFunDecl b (C.FunDecl _ ts _) = addTypeSig (FunK b) ts --} - -addTypeSig :: IKind -> C.TypeSig -> A.TypeSig -> ScopeCheck () -addTypeSig kind (C.TypeSig n _) (A.TypeSig x _) = addANameU kind n x - -{- UNUSED --- | Add a global identifier. Fail if already in signature. -addGlobal :: Show d => d -> IKind -> C.Name -> ScopeCheck A.Name -addGlobal d k n = enterShow n $ do - sig <- getSig - case lookupSig n sig of - Just _ -> errorAlreadyInSignature d n - Nothing -> addName k n --} - --- | Create a meta variable. -nextMVar :: (MVar -> ScopeCheck a) -> ScopeCheck a -nextMVar f = ScopeCheck $ do - st <- get - put $ st { nextMeta = nextMeta st + 1 } - unScopeCheck $ f (nextMeta st) - --- | Create a polarity meta variable. -nextPVar :: (MVar -> ScopeCheck a) -> ScopeCheck a -nextPVar f = ScopeCheck $ do - st <- get - put $ st { nextPolVar = nextPolVar st + 1 } - unScopeCheck $ f (nextPolVar st) - --- ** Additional services of scope monad. - --- | Default polarity is context-sensitive. -setDefaultPolarity :: Pol -> ScopeCheck a -> ScopeCheck a -setDefaultPolarity p = local (\ sccxt -> sccxt { defaultPolarity = p }) -{- -insertingPolVars :: Bool -> ScopeCheck a -> ScopeCheck a -insertingPolVars b = local (\ sccxt -> sccxt { insertPolVars = b }) --} - --- | Insert polarity variables for omitted polarities. -generalizeDec :: A.Dec -> ScopeCheck A.Dec -generalizeDec dec@A.Hidden = return dec -generalizeDec dec@A.Dec{} = - if (polarity dec == Default) then do - p0 <- asks defaultPolarity - case p0 of - PVar{} -> nextPVar $ \ i -> - return $ setPol (PVar i) dec - _ -> return $ setPol p0 dec - else return dec - -generalizeTBind :: C.TBind -> ScopeCheck C.TBind -generalizeTBind tb@C.TMeasure{} = return tb -generalizeTBind tb = do - dec' <- generalizeDec (C.boundDec tb) - return $ tb { C.boundDec = dec' } - --- | Insert polarity variables in telescope. -generalizeTel :: C.Telescope -> ScopeCheck C.Telescope -generalizeTel = mapM generalizeTBind - --- * Scope checking concrete syntax. ----------------------------------------------------------------------- - -scopeCheckDecls :: [C.Declaration] -> ScopeCheck [A.Declaration] -scopeCheckDecls = mapM scopeCheckDeclaration - -scopeCheckDeclaration :: C.Declaration -> ScopeCheck A.Declaration - -scopeCheckDeclaration (C.OverrideDecl Check ds) = ScopeCheck $ do - st <- get - as <- unScopeCheck $ scopeCheckDecls ds -- declarations need to scope check - put st -- but then forget their effect: restore old state - return $ A.OverrideDecl Check as - -scopeCheckDeclaration (C.OverrideDecl Fail ds) = ScopeCheck $ do - st <- get - as <- unScopeCheck $ scopeCheckDecls ds - `catchError` (const $ return []) --on error discard block - put st - return $ A.OverrideDecl Fail as -{- -scopeCheckDeclaration (C.OverrideDecl Fail ds) = do - st <- get - (as,st') <- (do as <- scopeCheckDecls ds - st' <- get - return (as,st')) - `catchError` (const $ return ([],st)) --on error discard block - put st' - return $ A.OverrideDecl Fail as --} -scopeCheckDeclaration (C.OverrideDecl override ds) = do -- TrustMe,Impredicative - as <- scopeCheckDecls ds - return $ A.OverrideDecl override as - -scopeCheckDeclaration (C.RecordDecl n tel t c fields) = - scopeCheckRecordDecl n tel t c fields - -scopeCheckDeclaration d@(C.DataDecl{}) = - scopeCheckDataDecl d -- >>= return . (:[]) - -scopeCheckDeclaration d@(C.FunDecl co _ _) = - scopeCheckFunDecls co [d] -- >>= return . (:[]) - -scopeCheckDeclaration (C.LetDecl eval letdef@C.LetDef{ C.letDefDec = dec, C.letDefName = n }) = do - unless (dec == A.defaultDec) $ - throwErrorMsg $ "polarity annotation not supported in global let definition of " ++ show n - (tel, mt, e) <- scopeCheckLetDef letdef - x <- addName LetK n - return $ A.LetDecl eval x tel mt e - -scopeCheckDeclaration d@(C.PatternDecl n ns p) = do - let errorHead = "invalid pattern declaration\n" ++ C.prettyDecl d ++ "\n" - -- check pattern - (p, delta) <- runStateT (scopeCheckPattern p) emptyCtx - p <- local (addContext delta) $ scopeCheckDotPattern p - -- ensure that pattern variables are the declared variables - unless (sort ns == sort (map fst delta)) $ do - let usedNames = map fst delta - unusedNames = ns \\ usedNames - undeclaredNames = usedNames \\ ns - when (not (null unusedNames)) $ throwErrorMsg $ - errorHead ++ "unsed variables in pattern: " - ++ Util.showList " " show unusedNames - when (not (null undeclaredNames)) $ throwErrorMsg $ - errorHead ++ "undeclared variables in pattern: " - ++ Util.showList " " show undeclaredNames - -- when (n `elem` ns) $ throwErrorMsg $ errorHead ++ "pattern" - x <- addName (ConK DefPat) n - let xs = map (fromJust . flip lookup delta) ns - return (A.PatternDecl x xs p) - --- we support --- - mutual (co)funs --- - mutual (co)data - -scopeCheckDeclaration (C.MutualDecl []) = throwErrorMsg "empty mutual block" -scopeCheckDeclaration (C.MutualDecl l@(C.DataDecl{}:xl)) = - scopeCheckMutual l -scopeCheckDeclaration (C.MutualDecl l@(C.FunDecl co _ _:xl)) = - scopeCheckFunDecls co l -- >>= return . (:[]) -scopeCheckDeclaration (C.MutualDecl _) = throwErrorMsg "mutual combination not supported" - -scopeCheckLetDef :: C.LetDef -> ScopeCheck (A.Telescope, Maybe (A.Type), A.Expr) -scopeCheckLetDef (C.LetDef dec n tel mt e) = setDefaultPolarity A.Rec $ do - tel <- generalizeTel tel - (tel, (mt, e)) <- scopeCheckTele tel $ do - (,) <$> mapM scopeCheckExprN mt -- allow shadowing after : in type - <*> scopeCheckExprN e -- allow shadowing after = - return (tel, mt, e) - -{- scopeCheck Mutual block -first check signatures -then bodies --} -scopeCheckMutual :: [C.Declaration] -> ScopeCheck A.Declaration -scopeCheckMutual ds0 = do - -- flatten nested mutual blocks and override decls - ds <- mutualFlattenDecls ds0 - -- extract, check, and add type signatures - let ktsigs = map mutualGetTypeSig ds - (mmm, tsigs') <- unzip <$> mapM checkAndAddTypeSig ktsigs - -- funs have been added with internal names - -- check that all functions are unmeasured or have a same length measure - let (ns, mll) = unzip $ compressMaybes mmm - let measured = null mll || isJust (head mll) - let ok = null mll || all ((head mll)==) (tail mll) - when (not ok) $ throwErrorMsg $ "in a mutual function block, either all functions must be without measure or have a measure of the same length" -{- - -- switch to internal fun ids - let funNames = [ n | (FunK _ , A.TypeSig n _) <- ktsigs ] -- internal fun names -{- SAME W/O COMPR - let funNames = map (\ (_, C.TypeSig n _) -> n) $ filter aux ktsigs where - aux (FunK _, _) = True - aux _ = False --} - mapM_ (addName (FunK False)) funNames -- TODO --} - -- check bodies of declarations - ds' <- mapM (setDefaultPolarity A.Rec . checkBody) (zip tsigs' ds) - -- switch back to external fun ids - let funNames = [ x | A.FunDecl _ (A.Fun _ x _ _) <- ds' ] -- external fun names - zipWithM_ (addANameU (LetK)) ns funNames --- zipWithM_ (addAName (FunK True)) ns funNames - return $ A.MutualDecl measured ds' - -scopeCheckTele :: C.Telescope -> ScopeCheck a -> ScopeCheck (A.Telescope, a) -scopeCheckTele [] cont = (A.emptyTel,) <$> cont -scopeCheckTele (tb : tel) cont = do - (tbs, (A.Telescope tel, a)) <- scopeCheckTBind tb $ scopeCheckTele tel cont - return (A.Telescope $ tbs ++ tel, a) - -scopeCheckTBind :: C.TBind -> ScopeCheck a -> ScopeCheck ([A.TBind], a) -scopeCheckTBind tb cont = do - let contYes = setConstraintAllowed True cont - contNo = setConstraintAllowed False cont - case tb of - C.TBind dec [] t -> do -- non-dependent function type - t <- scopeCheckExprN t - ([A.noBind $ A.Domain t A.defaultKind dec],) <$> contNo - C.TBind dec ns t -> do - t <- scopeCheckExprN t - (xs, a) <- addBinds tb ns $ contYes - return (map (\ x -> A.TBind x (A.Domain t A.defaultKind dec)) xs, a) - C.TBounded dec n ltle e -> do - e <- scopeCheckExprN e - (x, a) <- addBind tb n $ contYes - return ([A.TBind x (A.Domain (A.Below ltle e) A.defaultKind dec)], a) - C.TMeasure mu -> do - mu <- scopeCheckMeasure mu - ([A.TMeasure mu],) <$> cont --- C.TMeasure mu -> throwErrorMsg $ "measure not allowed in telescope" - C.TBound beta -> do - unlessM (asks constraintAllowed) $ - errorConstraintNotAllowed beta - beta <- scopeCheckBound beta - ([A.TBound beta],) <$> cont - -checkBody :: (A.TypeSig, C.Declaration) -> ScopeCheck A.Declaration -checkBody (A.TypeSig x tt, C.DataDecl n sz co tel _ cs fields) = - checkDataBody tt n x sz co tel cs fields -checkBody (ts@(A.TypeSig n t), d@(C.FunDecl co tsig cls)) = do - (ar,cls') <- scopeCheckFunClauses d - let n' = A.mkExtName n - return $ A.FunDecl co $ A.Fun ts n' ar cls' - -mutualFlattenDecls :: [C.Declaration] -> ScopeCheck [C.Declaration] -mutualFlattenDecls ds = mapM mutualFlattenDecl ds >>= return . concat - -mutualFlattenDecl :: C.Declaration -> ScopeCheck [C.Declaration] -mutualFlattenDecl (C.MutualDecl ds) = mutualFlattenDecls ds -mutualFlattenDecl (C.OverrideDecl Fail _) = throwErrorMsg $ "fail declaration not supported in mutual block" -mutualFlattenDecl (C.OverrideDecl o ds) = do - ds' <- mutualFlattenDecls ds - return $ map (\ d -> C.OverrideDecl o [d]) ds' -mutualFlattenDecl (C.LetDecl{}) = throwErrorMsg $ "let in mutual block not supported" -mutualFlattenDecl d = return $ [d] - --- extract type sigs of a mutual block in order, error on nested mutual -mutualGetTypeSig :: C.Declaration -> (IKind, C.TypeSig) -mutualGetTypeSig (C.DataDecl n sz co tel t cs fields) = - (DataK, C.TypeSig n (C.teleToType tel t)) -mutualGetTypeSig (C.FunDecl co tsig cls) = - (FunK False, tsig) -- fun id for use inside defining body -mutualGetTypeSig (C.LetDecl ev (C.LetDef dec n tel Nothing e)) = - error $ "let declaration of " ++ show n ++ ": type required in mutual block" -mutualGetTypeSig (C.LetDecl ev (C.LetDef dec n tel (Just t) e)) = - (LetK, C.TypeSig n (C.teleToType tel t)) -{- mutualGetTypeSig (C.LetDecl ev tsig e) = - (LetK, tsig) -} -mutualGetTypeSig (C.OverrideDecl _ [d]) = - mutualGetTypeSig d - - -scopeCheckRecordDecl :: C.Name -> C.Telescope -> C.Type -> C.Constructor -> [C.Name] -> - ScopeCheck A.Declaration -scopeCheckRecordDecl n tel t c cfields = enterShow n $ do - setDefaultPolarity A.Param $ do - tel <- generalizeTel tel - -- STALE COMMENT: we do not infer at all: -- do not infer polarities in index arguments - (A.TypeSig x tt') <- scopeCheckTypeSig (C.TypeSig n $ C.teleToType tel t) - addANameU DataK n x - let names = collectTelescopeNames tel - target = C.App (C.ident n) (map C.ident names) -- R pars - (tel',t') = A.typeToTele' (length names) tt' - c' <- scopeCheckConstructor n x (zipTels tel tel') A.CoInd target c - let delta = contextFromConstructors c c' - afields <- addFields ProjK delta cfields - return $ A.RecordDecl x tel' t' c' afields - -contextFromConstructors :: C.Constructor -> A.Constructor -> Context -contextFromConstructors (C.Constructor _ ctel0 mct) (A.Constructor _ _ at) = delta - where ctel = maybe [] (fst . C.typeToTele) mct - (atel, _) = A.typeToTele at - delta = zipTels (ctel0 ++ ctel) atel - -scopeCheckField :: Context -> C.Name -> ScopeCheck A.Name -scopeCheckField delta n = - case lookup n delta of - Nothing -> errorNotAField n - Just x -> return $ x - -addFields :: IKind -> Context -> [C.Name] -> ScopeCheck [A.Name] -addFields kind delta cfields = do - afields <- mapM (scopeCheckField delta) cfields - mapM (uncurry $ addANameU kind) $ zip cfields afields - return afields - -scopeCheckDataDecl :: C.Declaration -> ScopeCheck A.Declaration -scopeCheckDataDecl decl@(C.DataDecl n sz co tel0 t cs fields) = enterShow n $ do - setDefaultPolarity A.Param $ do - tel <- generalizeTel tel0 - -- STALE: -- do not infer polarities in index arguments - (A.TypeSig x tt') <- scopeCheckTypeSig (C.TypeSig n $ C.teleToType tel t) - addANameU DataK n x - checkDataBody tt' n x sz co tel cs fields - --- precondition: name already added to signature -checkDataBody :: A.Type -> C.Name -> A.Name -> Sized -> Co -> C.Telescope -> [C.Constructor] -> [C.Name] -> ScopeCheck A.Declaration -checkDataBody tt' n x sz co tel cs fields = do - let cnames = collectTelescopeNames tel -- parameters - target = C.App (C.ident n) $ map C.ident cnames -- D pars - (tel',t') = A.typeToTele' (length cnames) tt' - cs' <- mapM (scopeCheckConstructor n x (zipTels tel tel') co target) cs -{- NO LONGER INFER DESTRUCTORS - -- traceM ("constructors: " ++ show cs') --- when (t' == A.Sort A.Set && length cs' == 1) $ do --- when (length cs' == 1) $ do -- TOO STRICT, DOES NOT TREAT Vec right - let cis = A.analyzeConstructors co n tel' cs' - flip mapM_ cis $ \ ci -> when (A.cEtaExp ci) $ do --- Add destructor names - let fields = A.cFields ci -- A.classifyFields co n (A.typePart c) - -- TODO Check for recursive occurrence! - -- when (A.etaExpandable fields) $ - let destrNames = A.destructorNames fields - --when (not (null (destrNames))) $ - -- traceM ("fields: " ++ show fields) - -- traceM ("destructors: " ++ show destrNames) - mapM_ (addName (FunK True)) $ destrNames -- destructors are also upped - {- - let (ctel,_) = A.typeToTele (A.typePart (head cs')) - let destrNames = map (\(_,x,_) -> x) ctel - when (all (/= "") destrNames) $ - mapM_ (addName (FunK True)) destrNames -- destructors are also upped --} --} - -- add declared destructor names - let delta = concat $ map (uncurry contextFromConstructors) $ zip cs cs' - -- fields <- addFields (LetK) delta fields - -- 2012-01-26 register as projections - fields <- addFields ProjK delta fields - let pos = map (A.polarity . A.decor . A.boundDom) $ A.telescope tel' - return $ A.DataDecl x sz co pos tel' t' cs' fields - --- check whether all declarations in mutual block are (co)funs -checkFunMutual :: Co -> [C.Declaration] -> ScopeCheck () -checkFunMutual co [] = return () -checkFunMutual co (C.FunDecl co' _ _:xl) | co == co' = checkFunMutual co xl -checkFunMutual _ _ = throwErrorMsg "mutual combination not supported" - -scopeCheckFunDecls :: Co -> [C.Declaration] -> ScopeCheck A.Declaration -scopeCheckFunDecls co l = do - -- check for uniformity of mutual block (all funs/all cofuns) - checkFunMutual co l - -- check signatures and look for measures - r <- mapM (\ (C.FunDecl _ tysig _) -> scopeCheckFunSig tysig) l - let (ml:mll, tsl') = unzip r - let ok = all (ml==) mll - when (not ok) $ throwErrorMsg $ "in a mutual function block, either all functions must be without measure or have a measure of the same length" - -- add names as internal ids and check bodies - let nxs = zipWith (\ (C.FunDecl _ (C.TypeSig n _) _) (A.TypeSig x _) -> (n,x)) l tsl' - --let addFuns b = mapM (uncurry $ addAName $ FunK b) nxs --- let addFuns b = mapM (\ (n,x) -> addAName (FunK b) n x) nxs - -- addFuns False - mapM (uncurry $ addANameU $ FunK False) nxs - arcll' <- mapM (setDefaultPolarity A.Rec . scopeCheckFunClauses) l - -- add names as external ids - --addFuns True - let nxs' = map (mapPair id A.mkExtName) nxs - mapM (uncurry $ addANameU (LetK)) nxs' --- mapM (uncurry $ addAName (FunK True)) nxs' - return $ A.MutualFunDecl (isJust ml) co $ - zipWith3 (\ ts (_, x') (ar, cls) -> A.Fun ts x' ar cls) tsl' nxs' arcll' - --- | Does not add name to signature. -scopeCheckFunSig :: C.TypeSig -> ScopeCheck (Maybe Int, A.TypeSig) -scopeCheckFunSig d@(C.TypeSig n t) = checkInSig d n $ \ x -> do - (ml, t') <- scopeCheckFunType t - return (ml, A.TypeSig x t') - --- scope check type of mutual function, return length of measure (if present) --- a fun type is a telescope followed by (maybe) a measure and a type expression -scopeCheckFunType :: C.Expr -> ScopeCheck (Maybe Int, A.Expr) -scopeCheckFunType t = - case t of - - -- found a measure: continue normal scope checking - C.Quant A.Pi [C.TMeasure mu] e1 -> do - mu' <- scopeCheckMeasure mu - e1' <- scopeCheckExprN e1 - return (Just $ length (measure mu'), A.pi (A.TMeasure mu') e1') - - -- bounds are allowed here, since we check a function type - C.Quant A.Pi [C.TBound beta] e1 -> do - beta' <- scopeCheckBound beta - (ml, e1') <- scopeCheckFunType e1 - return (ml, A.pi (A.TBound beta') e1') - - C.Quant A.Pi tel e -> do - tel <- generalizeTel tel - (tel, (ml, e)) <- setDefaultPolarity A.Rec $ setConstraintAllowed False $ - scopeCheckTele tel $ setConstraintAllowed True $ scopeCheckFunType e - ml' <- findMeasure tel - ml <- case (ml,ml') of - (Nothing,ml') -> return ml' - (ml, Nothing) -> return ml - (Just{}, Just{}) -> errorOnlyOneMeasure - return (ml, A.teleToType tel e) - - t -> (Nothing,) <$> scopeCheckExpr t -- no measure found - -findMeasure :: A.Telescope -> ScopeCheck (Maybe Int) -findMeasure (A.Telescope tel) = - case [ mu | A.TMeasure mu <- tel ] of - [] -> return Nothing - [Measure mu] -> return $ Just $ length mu - _ -> errorOnlyOneMeasure - --- | Check whether concrete name is already in signature. --- If yes, fail. If no, create abstract name and continue. -checkInSig :: Show d => d -> C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck a -checkInSig d n k = enterShow n $ do - sig <- getSig - case lookupSig (C.QName n) sig of - Just _ -> errorAlreadyInSignature d n - Nothing -> k (A.fresh $ C.theName n) - --- checkInSigU :: Show d => d -> C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck a --- checkInSigU d n k = checkInSig d (C.QName n) (k . A.unqual) - -scopeCheckFunClauses :: C.Declaration -> ScopeCheck (Arity, [A.Clause]) -scopeCheckFunClauses (C.FunDecl _ (C.TypeSig n _) cl) = enterShow n $ do - cl <- mapM (scopeCheckClause (Just n)) cl - let m = if null cl then 0 else - List.foldl1 min $ map (length . A.clPatterns) cl - return (A.Arity m Nothing, cl) -{- - let b = checkPatternLength cl - case b of - Just m -> return $ (A.Arity m Nothing, cl) - Nothing -> throwErrorMsg $ " pattern length differs" --} - --- | Check the type of a signature and generate abstract name. --- Does not add abstract name to signature. -scopeCheckTypeSig :: C.TypeSig -> ScopeCheck A.TypeSig -scopeCheckTypeSig d@(C.TypeSig n t) = checkInSig d n $ \ x -> do - t' <- scopeCheckExpr t - return $ A.TypeSig x t' - --- | Results: --- --- @Nothing@ Not a function declaration. --- --- @Just (n, Nothing)@ Unmeasured function. --- --- @Just (n, Just m)@ Function with measure of length m -checkAndAddTypeSig :: (IKind, C.TypeSig) -> ScopeCheck (Maybe (C.Name, Maybe Int), A.TypeSig) -checkAndAddTypeSig (kind, ts@(C.TypeSig n _)) = do - (mm, ts'@(A.TypeSig x _)) <- - case kind of - FunK _ -> mapPair (Just . (n,)) id <$> scopeCheckFunSig ts -{- - do - (mi, ts) <- scopeCheckFunSig ts - return (Just mi, ts) --} - _ -> (Nothing,) <$> scopeCheckTypeSig ts - addANameU kind n x -- or: addTypeSig kind ts ts' - return (mm, ts') - -collectTelescopeNames :: C.Telescope -> [C.Name] -collectTelescopeNames = concat . map C.boundNames - --- | Check whether concrete name is already in signature. --- If yes, fail. If no, create abstract name and continue. -checkConsInSig :: Show decl => decl -> C.Name -> A.Name -> IKind -> C.Name -> (A.QName -> ScopeCheck a) -> ScopeCheck a -checkConsInSig decl d dx ki n cont = enterShow n $ do - -- first check whether the datatype has this constructor already - ifJustM (lookupSig (C.Qual d n) <$> getSig) (const $ errorAlreadyInSignature decl n) $ do - -- then check the overloaded name and possibly add it - x <- overloadName ki n - -- the qualified name is added in the continuation - cont $ A.Qual dx x - --- | @cxt@ is the data telescope. -scopeCheckConstructor :: C.Name -> A.Name -> Context -> Co -> C.Type -> C.Constructor -> ScopeCheck A.Constructor -scopeCheckConstructor d dx cxt co t0 a@(C.Constructor n tel mt) = do - let ki = ConK $ A.coToConK co - checkConsInSig a d dx ki n $ \ x -> do - - let finish t mcxt = local (addContext $ maybe cxt id mcxt) $ do - t <- setDefaultPolarity A.Param $ scopeCheckExpr $ C.teleToType tel t - t <- adjustTopDecsM defaultToParam t - addAName ki (C.Qual d n) x - let dummyDom = A.Domain A.Irr A.NoKind $ A.Dec Param - mtel = fmap (map (\ (n,x) -> A.TBind x dummyDom)) mcxt - ps = [] -- patterns computed during type checking - return $ A.Constructor x (fmap ((,ps) . A.Telescope) mtel) t - - case mt of - - -- no target given, then add the data tel to the scope - Nothing -> finish t0 Nothing - - -- target given, then the target binds the parameter names - Just t -> do - -- get the final target - let (_, target) = C.typeToTele t - - fallback = finish t Nothing - continue d' es = do - -- unless (d == d') $ errorWrongTarget n d d' - if (d /= d') then fallback else do - -- get the parameters of target - let (pars, inds) = splitAt (length cxt) es - unless (length pars == length cxt) $ errorNotEnoughParameters n target - -- if parameters are just data parameters, do it old style - if and (zipWith isTelPar cxt pars) then fallback else do - -- scopeCheck the parameters as patterns - finish t . Just =<< parameterVariables pars - - case target of - C.Ident (C.QName d') -> continue d' [] - C.App (C.Ident (C.QName d')) es -> continue d' es - _ -> fallback -- errorTargetMustBeAppliedName n target - -{- OLD CODE -scopeCheckConstructor :: C.Telescope -> A.Telescope -> Co -> C.Type -> C.Constructor -> ScopeCheck A.Constructor -scopeCheckConstructor ctel atel co t0 a@(C.Constructor n tel mt) = addTel ctel atel $ checkInSig a n $ \ x -> do - let t = maybe t0 id mt - t <- setDefaultPolarity A.Param $ scopeCheckExpr $ C.teleToType tel t - t <- adjustTopDecsM defaultToParam t - addAName (ConK $ A.coToConK co) n x - return $ A.TypeSig x t --} - where isTelPar (c,_) (C.Ident (C.QName x)) = c == x - isTelPar _ _ = False - defaultToParam dec = case (A.polarity dec) of - A.Default -> return $ setPol A.Param dec - A.Param -> return dec - A.Const -> return dec - A.PVar{} -> return dec - _ -> throwErrorMsg $ "illegal polarity " ++ show (polarity dec) ++ " in type of constructor " ++ show a - --- | Allow shadowing of previous locals. --- Always if we enter a subexpression which is not the body --- of a binder. -scopeCheckExprN :: C.Expr -> ScopeCheck A.Expr -scopeCheckExprN = newLevel . scopeCheckExpr - -scopeCheckExpr :: C.Expr -> ScopeCheck A.Expr -scopeCheckExpr e = setConstraintAllowed False $ scopeCheckExpr' e - -scopeCheckExpr' :: C.Expr -> ScopeCheck A.Expr -scopeCheckExpr' e = - case e of - -- replace underscore by next meta-variable - C.Unknown -> nextMVar (return . A.Meta) - C.Set e -> A.Sort . A.Set <$> scopeCheckExprN e - C.CoSet e -> A.Sort . A.CoSet <$> scopeCheckExprN e - C.Size -> return $ A.Sort (A.SortC A.Size) - C.Succ e1 -> A.Succ <$> scopeCheckExprN e1 - C.Zero -> return A.Zero - C.Infty -> return A.Infty - C.Plus e1 e2 -> do - e1 <- scopeCheckExprN e1 - e2 <- scopeCheckExprN e2 - return $ A.Plus [e1, e2] - C.Pair e1 e2 -> A.Pair <$> scopeCheckExprN e1 <*> scopeCheckExprN e2 - C.Sing e1 et -> A.Sing <$> scopeCheckExprN e1 <*> scopeCheckExprN et - C.App C.Max el -> do - el' <- mapM scopeCheckExprN el - when (length el' < 2) $ throwErrorMsg "max expects at least 2 arguments" - return $ A.Max el' - C.App e1 el -> foldl A.App <$> scopeCheckExprN e1 <*> mapM scopeCheckExprN el - C.Case e mt cl -> do - e' <- scopeCheckExprN e - mt' <- mapM scopeCheckExprN mt - cl' <- mapM (scopeCheckClause Nothing) cl - return $ A.Case e' mt' cl' - - -- measure & bound - -- measures can only appear in fun sigs! - C.Quant pisig [C.TMeasure mu] e1 -> do - throwErrorMsg $ "measure not allowed in expression " ++ show e - - -- measure bound mu < mu' - C.Quant A.Pi [C.TBound beta] e1 -> do - unlessM (asks constraintAllowed) $ errorConstraintNotAllowed beta - beta' <- scopeCheckBound beta - e1' <- scopeCheckExpr' e1 - return $ A.pi (A.TBound beta') e1' - - C.Quant A.Sigma [C.TBound beta] e1 -> throwErrorMsg $ - "measure bound not allowed in expression " ++ show e - - C.Quant pisig tel e -> do - tel <- generalizeTel tel - pol <- asks defaultPolarity - (A.Telescope tel, e) <- setDefaultPolarity A.Rec $ setConstraintAllowed False $ scopeCheckTele tel $ - setDefaultPolarity pol $ scopeCheckExpr' e - return $ quant pisig tel e where --- quant A.Sigma [tb] = A.Quant A.Sigma tb - quant A.Sigma tel e = foldr (A.Quant A.Sigma) e tel - quant A.Pi tel e = A.teleToType (A.Telescope tel) e - - C.Lam n e1 -> do - (n, e1') <- addBind e n $ scopeCheckExpr e1 - return $ A.Lam A.defaultDec n e1' -- dec. in Lam is ignored in t.c. - - C.LLet letdef e2 -> do - let dec = C.letDefDec letdef - (tel, mt, e1) <- scopeCheckLetDef letdef - (x, e2) <- addBind e (C.letDefName letdef) $ scopeCheckExpr e2 - return $ A.LLet (A.TBind x $ A.Domain mt A.defaultKind dec) tel e1 e2 - - C.Record rs -> do - let fields = map fst rs - if (hasDuplicate fields) then (errorDuplicateField e) else do - rs <- mapM scopeCheckRecordLine rs - return $ A.Record A.AnonRec rs - - C.Proj n -> A.Proj Post <$> scopeCheckProj n - - C.Ident n@C.Qual{} -> scopeCheckGlobalVar n - - C.Ident n@C.QName{} -> do - res <- lookupLocal (C.name n) - case res of - Just x -> return $ A.Var x - Nothing -> scopeCheckGlobalVar n - - _ -> throwErrorMsg $ "NYI: scopeCheckExpr " ++ show e - -scopeCheckGlobalVar :: C.QName -> ScopeCheck A.Expr -scopeCheckGlobalVar n = do - res <- lookupGlobal n - case res of - Just (DefI k x) -> case k of - (ConK co) -> return $ A.con co x - LetK -> return $ A.letdef (A.unqual x) - -- references to recursive functions are coded differently - -- outside the mutual block - FunK True -> return $ A.fun x -- A.letdef x -- A.mkExtRef x - FunK False -> return $ A.fun x - DataK -> return $ A.dat x - ProjK -> return $ A.Proj A.Pre (A.unqual x) -- errorProjectionUsedAsExpression n - Nothing -> errorIdentifierUndefined n - -scopeCheckLocalVar :: C.Name -> ScopeCheck A.Name -scopeCheckLocalVar n = maybe (errorIdentifierUndefined n) return =<< do - lookupLocal n - -scopeCheckRecordLine :: ([C.Name], C.Expr) -> ScopeCheck (A.Name, A.Expr) -scopeCheckRecordLine (n : ns, e) = do - x <- scopeCheckProj n - (x,) <$> scopeCheckExprN (foldr C.Lam e ns) - -scopeCheckProj :: C.Name -> ScopeCheck A.Name -scopeCheckProj n = do - sig <- getSig - case lookupSigU n sig of - Just (DefI ProjK x) -> return $ A.unqual x - _ -> errorNotAField n - - --- | @isProjIdent n = n@ if defined and the name of a projection. -isProjIdent :: C.QName -> ScopeCheck (Maybe A.Name) -isProjIdent n = do - sig <- getSig - return $ - case lookupSig n sig of - Just (DefI ProjK x) -> Just $ A.unqual x - _ -> Nothing - -isProjection :: C.Expr -> ScopeCheck (Maybe A.Name) -isProjection (C.Ident n) = isProjIdent n -isProjection _ = return Nothing - -scopeCheckMeasure :: A.Measure C.Expr -> ScopeCheck (A.Measure A.Expr) -scopeCheckMeasure (A.Measure es) = do - es' <- mapM scopeCheckExprN es - return $ A.Measure es' - -scopeCheckBound :: A.Bound C.Expr -> ScopeCheck (A.Bound A.Expr) -scopeCheckBound (A.Bound ltle e1 e2) = do - [e1',e2'] <- mapM scopeCheckMeasure [e1,e2] - return $ A.Bound ltle e1' e2' - -checkPatternLength :: [C.Clause] -> Maybe Int -checkPatternLength [] = Just 0 -- arity 0 -checkPatternLength (C.Clause _ pl _:cl) = cpl (length pl) cl - where - cpl k [] = Just k - cpl k (C.Clause _ pl _ : cl) = if (length pl == k) then (cpl k cl) else Nothing - -scopeCheckClause :: Maybe C.Name -> C.Clause -> ScopeCheck A.Clause -scopeCheckClause mname' (C.Clause mname pl mrhs) = do - when (mname /= mname') $ errorClauseIdentifier mname mname' - (pl, delta) <- runStateT (mapM scopeCheckPattern pl) emptyCtx - local (addContext delta) $ do - pl <- mapM scopeCheckDotPattern pl - case mrhs of - Nothing -> return $ A.clause pl Nothing - Just rhs -> A.clause pl . Just <$> scopeCheckExprN rhs - - -type PatCtx = Context -type SPS = StateT PatCtx ScopeCheck - -scopeCheckPatVar :: C.QName -> SPS (A.Pat C.Expr) -scopeCheckPatVar n = do - sig <- lift $ getSig - case lookupSig n sig of - Just (DefI (ConK co) n) -> return $ A.ConP (A.PatternInfo co False False) n [] - -- a nullary constructor - Just _ -> errorPatternNotConstructor n - Nothing -> A.VarP <$> addUnique (C.unqual n) - -scopeCheckPattern :: C.Pattern -> SPS (A.Pat C.Expr) -scopeCheckPattern p = - case p of - - -- case n - C.IdentP n -> scopeCheckPatVar n - C.ConP False n [] -> scopeCheckPatVar n - - -- case (i > j): - C.SizeP m n -> do - -- m <- lift $ scopeCheckLocalVar m - A.SizeP m <$> addUnique n - - -- case $p - C.SuccP p2 -> A.SuccP <$> scopeCheckPattern p2 - - -- case (p1,p2) - C.PairP p1 p2 -> A.PairP <$> scopeCheckPattern p1 <*> scopeCheckPattern p2 - - -- case .n - C.ConP True n [] -> do - -- try projection - ifJustM (lift $ isProjIdent n) (return . A.ProjP) $ do - -- try constructor - sig <- lift $ getSig - case lookupSig n sig of - Just (DefI (ConK co) n) -> - return $ A.ConP (A.PatternInfo co False True) n [] - -- fallback: dot pattern - _ -> return $ A.DotP (C.Ident n) - - -- case [.]c ps - C.ConP dotted n pl -> do - sig <- lift $ getSig - case lookupSig n sig of - Just (DefI (ConK co) x) -> - A.ConP (A.PatternInfo co False dotted) x <$> mapM scopeCheckPattern pl - _ -> errorPatternNotConstructor n - - -- case .e - C.DotP e -> do - isProj <- lift $ isProjection e - case isProj of - Just n -> return $ A.ProjP n - Nothing -> return $ A.DotP e -- dot patterns checked later - - -- case () - C.AbsurdP -> return $ A.AbsurdP - --- | Add pattern variable to pattern context, must not be present yet. -addUnique :: C.Name -> SPS A.Name -addUnique = addPatVar True - -addNonUnique :: C.Name -> SPS A.Name -addNonUnique = addPatVar False - -addPatVar :: Bool -> C.Name -> SPS A.Name -addPatVar linear n = do - delta <- get - case retrieve n delta of - Just x -> if linear then errorPatternNotLinear n else return x - Nothing -> do - let (x, delta') = newLocal n delta - put delta' - return x - -scopeCheckDotPattern :: A.Pat C.Expr -> ScopeCheck A.Pattern -scopeCheckDotPattern p = - case p of - A.DotP e -> A.DotP <$> scopeCheckExprN e - A.PairP p1 p2 -> A.PairP <$> scopeCheckDotPattern p1 <*> scopeCheckDotPattern p2 - A.SuccP p -> A.SuccP <$> scopeCheckDotPattern p - A.ConP co n pl -> A.ConP co n <$> mapM scopeCheckDotPattern pl --- A.SizeP m n -> flip A.SizeP n <$> scopeCheckLocalVar m -- return $ A.SizeP m n - A.SizeP e n -> flip A.SizeP n <$> scopeCheckExprN e - A.VarP n -> return $ A.VarP n -- even though p = A.VarP n, it has wrong type!! - A.ProjP n -> return $ A.ProjP n - A.AbsurdP -> return $ A.AbsurdP - -- impossible cases: ErasedP, UnusableP - - --- * Scope checking parameters - -parameterVariables :: [C.Expr] -> ScopeCheck Context -parameterVariables es = do - execStateT (mapM_ scopeCheckParameter es) emptyCtx - --- | Extract variables bound by data parameters. --- We consider a more liberal set of patterns, everything --- that is injective and does not bind variables. -scopeCheckParameter :: C.Expr -> SPS () -scopeCheckParameter e = - case e of - C.Set e' -> scopeCheckParameter e' - C.CoSet e' -> scopeCheckParameter e' - C.Size -> return () - C.Succ e' -> scopeCheckParameter e' - C.Zero -> return () - C.Infty -> return () - C.Pair e1 e2 -> scopeCheckParameter e1 >> scopeCheckParameter e2 - C.Record fs -> mapM_ (scpField e) fs - C.Ident n -> scpApp e n [] - C.App (C.Ident n) es -> scpApp e n es - C.App C.App{} es -> throwErrorMsg $ "scopeCheckParameter " ++ show e ++ ": internal invariant violated" - _ -> errorInvalidParameter e - where - -- we can only treat a record expression as pattern - -- if it does not bind any variables - scpField :: C.Expr -> ([C.Name], C.Expr) -> SPS () - scpField e ([f], e') = scopeCheckParameter e' - scpField e _ = errorInvalidParameter e - - scpApp :: C.Expr -> C.QName -> [C.Expr] -> SPS () - scpApp e n es = do - sig <- lift $ getSig - case lookupSig n sig of - Just (DefI ConK{} n) -> mapM_ scopeCheckParameter es - Just (DefI DataK n) -> mapM_ scopeCheckParameter es - Just _ -> errorInvalidParameter e - Nothing -> void $ addNonUnique (C.unqual n) -- allow non-linearity - --- * Scope checking errors - -errorAlreadyInSignature s n = throwErrorMsg $ show s ++ ": Identifier " ++ show n ++ " already in signature" - -errorAlreadyInContext s n = throwErrorMsg $ show s ++ ": Identifier " ++ show n ++ " already in context" - --- errorPatternNotVariable n = throwErrorMsg $ "pattern " ++ n ++ ": Identifier expected" - -errorPatternNotConstructor n = throwErrorMsg $ "pattern " ++ show n ++ " is not a constructor" - -errorNotAField n = throwErrorMsg $ "record field " ++ show n ++ " unknown" --- errorUnknownProjection n = throwErrorMsg $ "projection " ++ n ++ " unknown" - -errorDuplicateField r = throwErrorMsg $ show r ++ " assigns a field twice" - - -errorProjectionUsedAsExpression n = throwErrorMsg $ "projection " ++ show n ++ " used as expression" - -errorIdentifierUndefined n = throwErrorMsg $ "Identifier " ++ show n ++ " undefined" - -errorPatternNotLinear n = throwErrorMsg $ "pattern not linear: " ++ show n - -errorClauseIdentifier (Just n) (Just n') = throwErrorMsg $ "Expected identifier " ++ show n' ++ " as clause head, found " ++ show n - -errorOnlyOneMeasure = throwErrorMsg "only one measure allowed in a function type" - -errorConstraintNotAllowed beta = throwErrorMsg $ - show beta ++ ": constraints must follow a quantifier" - -errorTargetMustBeAppliedName n t = throwErrorMsg $ - "constructor " ++ show n ++ ": target must be data/record type applied to parameters and indices; however, I found " ++ show t - -errorWrongTarget c d d' = throwErrorMsg $ - "constructor " ++ show c ++ " should target data/record type " ++ show d ++ "; however, I found " ++ show d' - -errorNotEnoughParameters c t = throwErrorMsg $ - "constructor " ++ show c ++ ": target " ++ show t ++ " is missing parameters" - -errorInvalidParameter e = throwErrorMsg $ - "expression " ++ show e ++ " is not valid in a parameter" diff --git a/Semiring.hs b/Semiring.hs deleted file mode 100644 --- a/Semiring.hs +++ /dev/null @@ -1,101 +0,0 @@ --- {-# LANGUAGE UndecidableInstances #-} - --- | Semirings. Original: Agda.Terminatio.Semiring - -module Semiring - ( HasZero(..), SemiRing(..) - , Semiring(..) --- , semiringInvariant - , integerSemiring - , boolSemiring - ) where - -import Data.Monoid - - -{- | SemiRing type class. Additive monoid with multiplication operation. -Inherit addition and zero from Monoid. -} - -class (Eq a, Monoid a) => SemiRing a where --- isZero :: a -> Bool - multiply :: a -> a -> a - - --- | @HasZero@ is needed for sparse matrices, to tell which is the element --- that does not have to be stored. --- It is a cut-down version of @SemiRing@ which is definable --- without the implicit @?cutoff@. -class Eq a => HasZero a where - zeroElement :: a - --- | Semirings. - -data Semiring a - = Semiring { add :: a -> a -> a -- ^ Addition. - , mul :: a -> a -> a -- ^ Multiplication. - , zero :: a -- ^ Zero. --- The one is never used in matrix multiplication --- , one :: a -- ^ One. - } - --- | Semiring invariant. - --- I think it's OK to use the same x, y, z triple for all the --- properties below. - -{- -semiringInvariant :: (Arbitrary a, Eq a, Show a) - => Semiring a - -> a -> a -> a -> Bool -semiringInvariant (Semiring { add = (+), mul = (*) - , zero = zero --, one = one - }) = \x y z -> - associative (+) x y z && - identity zero (+) x && - commutative (+) x y && - associative (*) x y z && --- identity one (*) x && - leftDistributive (*) (+) x y z && - rightDistributive (*) (+) x y z && - isZero zero (*) x --} - ------------------------------------------------------------------------- --- Specific semirings - --- | The standard semiring on 'Integer's. - -instance HasZero Integer where - zeroElement = 0 - -instance Monoid Integer where - mempty = 0 - mappend = (+) - -instance SemiRing Integer where - multiply = (*) - - -integerSemiring :: Semiring Integer -integerSemiring = Semiring { add = (+), mul = (*), zero = 0 } -- , one = 1 } - --- prop_integerSemiring = semiringInvariant integerSemiring - --- | The standard semiring on 'Bool's. - -boolSemiring :: Semiring Bool -boolSemiring = - Semiring { add = (||), mul = (&&), zero = False } --, one = True } - --- prop_boolSemiring = semiringInvariant boolSemiring - ------------------------------------------------------------------------- --- All tests - -{- -tests :: IO Bool -tests = runTests "Agda.Termination.Semiring" - [ quickCheck' prop_integerSemiring - , quickCheck' prop_boolSemiring - ] --} diff --git a/SparseMatrix.hs b/SparseMatrix.hs deleted file mode 100644 --- a/SparseMatrix.hs +++ /dev/null @@ -1,459 +0,0 @@ -{- | Sparse matrices. Original: Agda.Termination.SparseMatrix - -We assume the matrices to be very sparse, so we just implement them as -sorted association lists. - - -} - -module SparseMatrix - ( -- * Basic data types - Matrix(M) - , matrixInvariant - , Size(..) - , sizeInvariant - , MIx (..) - , mIxInvariant - -- * Generating and creating matrices - , fromLists - , fromIndexList - , toLists --- , matrix --- , matrixUsingRowGen - -- * Combining and querying matrices - , size - , square - , isEmpty - , isSingleton - , SparseMatrix.all, SparseMatrix.any - , add, intersectWith, SparseMatrix.zip - , mul - , transpose - , diagonal - -- * Modifying matrices - , addRow - , addColumn - -- * Tests - ) where - -import Data.Array -import qualified Data.List as List -import Data.Monoid - --- import Test.QuickCheck - -import Semiring (HasZero(..), SemiRing, Semiring) -import qualified Semiring as Semiring - - - ------------------------------------------------------------------------- --- Basic data types - --- | This matrix type is used for tests. - -type TM = Matrix Integer Integer - --- | Size of a matrix. - -data Size i = Size { rows :: i, cols :: i } - deriving (Eq, Ord, Show) - -sizeInvariant :: (Ord i, Num i) => Size i -> Bool -sizeInvariant sz = rows sz >= 0 && cols sz >= 0 - -{- -instance (Arbitrary i, Integral i) => Arbitrary (Size i) where - arbitrary = do - r <- natural - c <- natural - return $ Size { rows = fromInteger r, cols = fromInteger c } - -instance CoArbitrary i => CoArbitrary (Size i) where - coarbitrary (Size rs cs) = coarbitrary rs . coarbitrary cs - -prop_Arbitrary_Size :: Size Integer -> Bool -prop_Arbitrary_Size = sizeInvariant --} - --- | Converts a size to a set of bounds suitable for use with --- the matrices in this module. - -toBounds :: Num i => Size i -> (MIx i, MIx i) -toBounds sz = (MIx { row = 1, col = 1 }, MIx { row = rows sz, col = cols sz }) - --- | Type of matrix indices (row, column). - -data MIx i = MIx { row, col :: i } - deriving (Eq, Show, Ix, Ord) - -{- -instance (Arbitrary i, Integral i) => Arbitrary (MIx i) where - arbitrary = do - r <- positive - c <- positive - return $ MIx { row = r, col = c } - -instance CoArbitrary i => CoArbitrary (MIx i) where - coarbitrary (MIx r c) = coarbitrary r . coarbitrary c --} - --- | No nonpositive indices are allowed. - -mIxInvariant :: (Ord i, Num i) => MIx i -> Bool -mIxInvariant i = row i >= 1 && col i >= 1 - -prop_Arbitrary_MIx :: MIx Integer -> Bool -prop_Arbitrary_MIx = mIxInvariant - --- | Type of matrices, parameterised on the type of values. - -data Matrix i b = M { size :: Size i, unM :: [(MIx i, b)] } - deriving (Ord) - -instance (Ord i, Eq a, HasZero a) => Eq (Matrix i a) where - m1 == m2 = size m1 == size m2 && - SparseMatrix.all (uncurry (==)) (SparseMatrix.zip m1 m2) - -instance Functor (Matrix i) where - fmap f (M sz m) = M sz (map (\ (i,a) -> (i, f a)) m) - -matrixInvariant :: (Num i, Ix i) => Matrix i b -> Bool -matrixInvariant m = List.all (\ (MIx i j, b) -> 1 <= i && i <= rows sz - && 1 <= j && j <= cols sz) (unM m) - && strictlySorted (MIx 0 0) (unM m) - && sizeInvariant sz - where sz = size m - --- matrix indices are lexicographically sorted with no duplicates --- Ord MIx should be the lexicographic one already (Haskell report) - -strictlySorted :: (Ord i) => i -> [(i, b)] -> Bool -strictlySorted i [] = True -strictlySorted i ((i', b) : l) = i < i' && strictlySorted i' l -{- -strictlySorted (MIx i j) [] = True -strictlySorted (MIx i j) ((MIx i' j', b) : l) = - (i < i' || i == i' && j < j' ) && strictlySorted (MIx i' j') b --} - -instance (Ord i, Integral i, Enum i, Show i, Show b, HasZero b) => Show (Matrix i b) where - showsPrec _ m = - showString "SparseMatrix.fromLists " . shows (size m) . - showString " " . shows (toLists m) - -{- -instance (Integral i, HasZero b, Pretty b) => - Pretty (Matrix i b) where - pretty = vcat . map (hsep . map pretty) . toLists - -instance (Arbitrary i, Num i, Integral i, Arbitrary b, HasZero b) - => Arbitrary (Matrix i b) where - arbitrary = matrix =<< arbitrary - -instance (Ord i, Integral i, Enum i, CoArbitrary b, HasZero b) => CoArbitrary (Matrix i b) where - coarbitrary m = coarbitrary (toLists m) - - -prop_Arbitrary_Matrix :: TM -> Bool -prop_Arbitrary_Matrix = matrixInvariant --} - ------------------------------------------------------------------------- --- Generating and creating matrices - --- | Generates a matrix of the given size, using the given generator --- to generate the rows. - -{- -matrixUsingRowGen :: (Arbitrary i, Integral i, Arbitrary b, HasZero b) - => Size i - -> (i -> Gen [b]) - -- ^ The generator is parameterised on the size of the row. - -> Gen (Matrix i b) -matrixUsingRowGen sz rowGen = do - rows <- vectorOf (fromIntegral $ rows sz) (rowGen $ cols sz) - return $ fromLists sz rows --} - --- | Generates a matrix of the given size. - -{- -matrix :: (Arbitrary i, Integral i, Arbitrary b, HasZero b) - => Size i -> Gen (Matrix i b) -matrix sz = matrixUsingRowGen sz (\n -> vectorOf (fromIntegral n) arbitrary) - -prop_matrix sz = forAll (matrix sz :: Gen TM) $ \m -> --- matrixInvariant m && - size m == sz --} - --- | Constructs a matrix from a list of (index, value)-pairs. - --- compareElt = (\ (i,_) (j,_) -> compare i j) --- normalize = filter (\ (i,b) -> b /= zeroElement) - -fromIndexList :: (Ord i, HasZero b) => Size i -> [(MIx i, b)] -> Matrix i b -fromIndexList sz = M sz . List.sortBy (\ (i,_) (j,_) -> compare i j) . filter (\ (i,b) -> b /= zeroElement) - -prop_fromIndexList :: TM -> Bool -prop_fromIndexList m = matrixInvariant m' && m' == m - where vs = unM m - m' = fromIndexList (size m) vs - --- | @'fromLists' sz rs@ constructs a matrix from a list of lists of --- values (a list of rows). --- --- Precondition: @'length' rs '==' 'rows' sz '&&' 'all' (('==' 'cols' sz) . 'length') rs@. - -fromLists :: (Ord i, Num i, Enum i, HasZero b) => Size i -> [[b]] -> Matrix i b -fromLists sz bs = fromIndexList sz $ - List.zip ([ MIx i j | i <- [1..rows sz] , j <- [1..cols sz]]) (concat bs) - --- | Converts a sparse matrix to a sparse list of rows - -toSparseRows :: (Num i, Enum i, Eq i) => Matrix i b -> [(i,[(i,b)])] -toSparseRows m = aux 1 [] (unM m) - where aux i' [] [] = [] - aux i' row [] = [(i', reverse row)] - aux i' row ((MIx i j, b) : m) - | i' == i = aux i' ((j,b):row) m - | otherwise = (i', reverse row) : aux i [(j,b)] m - --- sparse vectors cannot have two entries in one column -blowUpSparseVec :: (Eq i, Ord i, Num i, Enum i, Show i) => b -> i -> [(i,b)] -> [b] -blowUpSparseVec zero n l = aux 1 l - where aux i [] | i > n = [] - | otherwise = zero : aux (i+1) [] - aux i ((j,b):l) | i <= n && j == i = b : aux (succ i) l - aux i ((j,b):l) | i <= n && j >= i = zero : aux (succ i) ((j,b):l) - aux i l = error $ "blowUpSparseVec (n = " ++ show n ++ ") aux i=" ++ show i ++ " j=" ++ show (fst (head l)) ++ " length l = " ++ show (length l) --- __IMPOSSIBLE__ - --- | Converts a matrix to a list of row lists. - -toLists :: (Ord i, Integral i, Enum i, HasZero b, Show i) => Matrix i b -> [[b]] -toLists m = blowUpSparseVec emptyRow (rows sz) $ - map (\ (i,r) -> (i, blowUpSparseVec zeroElement (cols sz) r)) $ toSparseRows m --- [ [ maybe zeroElement id $ lookup (MIx { row = r, col = c }) (unM m) --- | c <- [1 .. cols sz] ] | r <- [1 .. rows sz] ] - where sz = size m - emptyRow = take (fromIntegral (cols sz)) $ repeat zeroElement - -prop_fromLists_toLists :: TM -> Bool -prop_fromLists_toLists m = fromLists (size m) (toLists m) == m - ------------------------------------------------------------------------- --- Combining and querying matrices - --- | The size of a matrix. - -{- -size :: Ix i => Matrix i b -> Size i -size m = Size { rows = row b, cols = col b } - where (_, b) = bounds $ unM m --} - -prop_size :: TM -> Bool -prop_size m = sizeInvariant (size m) - - -prop_size_fromIndexList :: Size Int -> Bool -prop_size_fromIndexList sz = - size (fromIndexList sz ([] :: [(MIx Int, Integer)])) == sz - --- | 'True' iff the matrix is square. - -square :: Ix i => Matrix i b -> Bool -square m = rows (size m) == cols (size m) - --- | Returns 'True' iff the matrix is empty. - -isEmpty :: (Num i, Ix i) => Matrix i b -> Bool -isEmpty m = rows sz <= 0 || cols sz <= 0 - where sz = size m - --- | Returns 'Just b' iff it is a 1x1 matrix with just one entry 'b'. - -isSingleton :: (Num i, Ix i, HasZero b) => Matrix i b -> Maybe b -isSingleton m = if (rows sz == 1 || cols sz == 1) then - case unM m of - [(_,b)] -> Just b - [] -> Just zeroElement - else Nothing - where sz = size m - --- | Transposition -transposeSize (Size { rows = n, cols = m }) = Size { rows = m, cols = n } -transpose m = M { size = transposeSize (size m) - , unM = List.sortBy (\ (i,a) (j,b) -> compare i j) $ - map (\(MIx i j, b) -> (MIx j i, b)) $ unM m } - -all :: (a -> Bool) -> Matrix i a -> Bool -all p m = List.all (\ (i,a) -> p a) (unM m) - -any :: (a -> Bool) -> Matrix i a -> Bool -any p m = List.any (\ (i,a) -> p a) (unM m) - --- | @'zip' m1 m2@ zips @m1@ and @m2@. --- --- Precondition: @'size' m1 == 'size' m2@. - -zip :: (Ord i, HasZero a) => Matrix i a -> Matrix i a -> Matrix i (a,a) -zip m1 m2 = M (size m1) $ zips (unM m1) (unM m2) where - zips [] m = map (\ (i,b) -> (i,(zeroElement,b))) m - zips l [] = map (\ (i,a) -> (i,(a,zeroElement))) l - zips l@((i,a):l') m@((j,b):m') - | i < j = (i,(a,zeroElement)) : zips l' m - | i > j = (j,(zeroElement,b)) : zips l m' - | otherwise = (i,(a,b)) : zips l' m' - --- | @'add' (+) m1 m2@ adds @m1@ and @m2@. Uses @(+)@ to add values. --- --- Precondition: @'size' m1 == 'size' m2@. - -add :: (Ord i) => (a -> a -> a) -> Matrix i a -> Matrix i a -> Matrix i a -add plus m1 m2 = M (size m1) $ mergeAssocWith plus (unM m1) (unM m2) - --- | assoc list union -mergeAssocWith :: (Ord i) => (a -> a -> a) -> [(i,a)] -> [(i,a)] -> [(i,a)] -mergeAssocWith f [] m = m -mergeAssocWith f l [] = l -mergeAssocWith f l@((i,a):l') m@((j,b):m') - | i < j = (i,a) : mergeAssocWith f l' m - | i > j = (j,b) : mergeAssocWith f l m' - | otherwise = (i, f a b) : mergeAssocWith f l' m' - --- | @'intersectWith' f m1 m2@ build the pointwise conjunction @m1@ and @m2@. --- Uses @f@ to combine non-zero values. --- --- Precondition: @'size' m1 == 'size' m2@. - -intersectWith :: (Ord i) => (a -> a -> a) -> Matrix i a -> Matrix i a -> Matrix i a -intersectWith f m1 m2 = M (size m1) $ interAssocWith f (unM m1) (unM m2) - --- | assoc list intersection -interAssocWith :: (Ord i) => (a -> a -> a) -> [(i,a)] -> [(i,a)] -> [(i,a)] -interAssocWith f [] m = [] -interAssocWith f l [] = [] -interAssocWith f l@((i,a):l') m@((j,b):m') - | i < j = interAssocWith f l' m - | i > j = interAssocWith f l m' - | otherwise = (i, f a b) : interAssocWith f l' m' - -{- -prop_add sz = - forAll (three (matrix sz :: Gen TM)) $ \(m1, m2, m3) -> - let m' = add (+) m1 m2 in - associative (add (+)) m1 m2 m3 && - commutative (add (+)) m1 m2 && - matrixInvariant m' && - size m' == size m1 --} - --- | @'mul' semiring m1 m2@ multiplies @m1@ and @m2@. Uses the --- operations of the semiring @semiring@ to perform the --- multiplication. --- --- Precondition: @'cols' ('size' m1) == rows ('size' m2)@. - -{- mul A B works as follows: -* turn A into a list of sparse rows and the transposed B as well -* form the crossproduct using the inner vector product to compute els -* the inner vector product is summing up - after intersecting with the muliplication op of the semiring --} - -mul :: (Enum i, Num i, Ix i, Eq a) - => Semiring a -> Matrix i a -> Matrix i a -> Matrix i a -mul semiring m1 m2 = M (Size { rows = rows (size m1), cols = cols (size m2) }) $ - filter (\ (i,b) -> b /= Semiring.zero semiring) $ - [ (MIx i j, foldl (Semiring.add semiring) (Semiring.zero semiring) $ - map snd $ interAssocWith (Semiring.mul semiring) v w) - | (i,v) <- toSparseRows m1 - , (j,w) <- toSparseRows $ transpose m2 ] - -{- -prop_mul sz = - sized $ \n -> resize (n `div` 2) $ - forAll (two natural) $ \(c2, c3) -> - forAll (matrix sz :: Gen TM) $ \m1 -> - forAll (matrix (Size { rows = cols sz, cols = c2 })) $ \m2 -> - forAll (matrix (Size { rows = c2, cols = c3 })) $ \m3 -> - let m' = mult m1 m2 in - associative mult m1 m2 m3 && - matrixInvariant m' && - size m' == Size { rows = rows sz, cols = c2 } - where mult = mul Semiring.integerSemiring --} - --- | @'diagonal' m@ extracts the diagonal of @m@. --- --- Precondition: @'square' m@. - -diagonal :: (Enum i, Num i, Ix i, Show i, HasZero b) => Matrix i b -> [b] -diagonal m = blowUpSparseVec zeroElement (rows sz) $ - map (\ ((MIx i j),b) -> (i,b)) $ filter (\ ((MIx i j),b) -> i==j) (unM m) - where sz = size m - -{- -diagonal :: (Enum i, Num i, Ix i, HasZero b) => Matrix i b -> Array i b -diagonal m = listArray (1, rows sz) $ blowUpSparseVec zeroElement (rows sz) $ - map (\ ((MIx i j),b) -> (i,b)) $ filter (\ ((MIx i j),b) -> i==j) (unM m) - where sz = size m --} - -{- -prop_diagonal = - forAll natural $ \n -> - forAll (matrix (Size n n) :: Gen TM) $ \m -> - bounds (diagonal m) == (1, n) --} - ------------------------------------------------------------------------- --- Modifying matrices - --- | @'addColumn' x m@ adds a new column to @m@, after the columns --- already existing in the matrix. All elements in the new column get --- set to @x@. - -addColumn :: (Num i, HasZero b) => b -> Matrix i b -> Matrix i b -addColumn x m | x == zeroElement = m { size = (size m) { cols = cols (size m) + 1 }} --- | otherwise = __IMPOSSIBLE__ - -{- -prop_addColumn :: TM -> Bool -prop_addColumn m = - matrixInvariant m' - && - map init (toLists m') == toLists m - where - m' = addColumn zeroElement m --} - --- | @'addRow' x m@ adds a new row to @m@, after the rows already --- existing in the matrix. All elements in the new row get set to @x@. - -addRow :: (Num i, HasZero b) => b -> Matrix i b -> Matrix i b -addRow x m | x == zeroElement = m { size = (size m) { rows = rows (size m) + 1 }} --- | otherwise = __IMPOSSIBLE__ - -prop_addRow :: TM -> Bool -prop_addRow m = - matrixInvariant m' - && - init (toLists m') == toLists m - where - m' = addRow zeroElement m - ------------------------------------------------------------------------- --- Zipping (assumes non-empty matrices) - -{- use mergeAssocList or interAssocList instead -zipWith :: (a -> b -> c) -> - Matrix Integer a -> Matrix Integer b -> Matrix Integer c -zipWith f m1 m2 - = fromLists (Size { rows = toInteger $ length ll, - cols = toInteger $ length (head ll) }) ll - where ll = List.zipWith (List.zipWith f) (toLists m1) (toLists m2) --} - diff --git a/TCM.hs b/TCM.hs deleted file mode 100644 --- a/TCM.hs +++ /dev/null @@ -1,1494 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, PatternGuards, FlexibleContexts, NamedFieldPuns, DeriveFunctor, DeriveFoldable, DeriveTraversable, TupleSections #-} - -module TCM where - -import Prelude hiding (null) - -import Control.Monad -import Control.Monad.Identity -import Control.Monad.State -import Control.Monad.Except -import Control.Monad.Reader - -import Control.Applicative -import Data.Foldable (Foldable) -import qualified Data.Foldable as Foldable -import Data.Traversable (Traversable) -import qualified Data.Traversable as Traversable -import Data.Monoid - -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe - -import Debug.Trace - -import Abstract -import Polarity -import Value -import {-# SOURCE #-} Eval -- (up,whnf') -import PrettyTCM - --- import CallStack -import TraceError - -import TreeShapedOrder (TSO) -import qualified TreeShapedOrder as TSO - -import Util - -import Warshall - --- traceSig msg a = trace msg a -traceSig msg a = a - -traceRew msg a = a -- trace msg a -traceRewM msg = return () -- traceM msg -{- -traceRew msg a = trace msg a -traceRewM msg = traceM msg --} - --- metavariables and constraints - -traceMeta msg a = a -- trace msg a -traceMetaM msg = return () -- traceM msg -{- -traceMeta msg a = trace msg a -traceMetaM msg = traceM msg --} - - --- type checking monad ----------------------------------------------- - -class (MonadCxt m, MonadSig m, MonadMeta m, MonadError TraceError m) => - MonadTCM m where - - --- lists of exactly one or two elements ------------------------------ - --- this would have been better implemented by just lists and a view --- type OneOrTwo a = [a] --- data View12 a = One a | Two a a --- fromList12 --- then one could still get completeness of pattern matching! --- now we have lots of boilerplate code - -data OneOrTwo a = One a | Two a a deriving (Eq, Ord, Functor, Foldable, Traversable) - -instance Show a => Show (OneOrTwo a) where - show (One a) = show a - show (Two a b) = show a ++ "||" ++ show b - -name12 :: OneOrTwo Name -> Name -name12 (One n) = n -name12 (Two n1 n2) - | null (suggestion n2) = n1 - | null (suggestion n1) = n2 - | suggestion n1 == suggestion n2 = n1 - | otherwise = fresh (suggestion n1 ++ "||" ++ suggestion n2) - -{- -instance Functor OneOrTwo where - fmap f (One a) = One (f a) - fmap f (Two a b) = Two (f a) (f b) - -instance Foldable OneOrTwo where - foldMap f (One a) = f a - foldMap f (Two a b) = f a `mappend` f b - --- traverse :: Applicative f => (a -> f b) -> t a -> f (t b) -instance Traversable OneOrTwo where - traverse f (One a) = One <$> f a - traverse f (Two a b) = Two <$> f a <*> f b --} - --- eliminator -oneOrTwo :: (a -> b) -> (a -> a -> b) -> OneOrTwo a -> b -oneOrTwo f g (One a) = f a -oneOrTwo f g (Two a1 a2) = g a1 a2 - -fromOne :: OneOrTwo a -> a -fromOne (One a) = a - -toTwo :: OneOrTwo a -> OneOrTwo a -toTwo = oneOrTwo (\ a -> Two a a) Two - -first12 :: OneOrTwo a -> a -first12 (One a) = a -first12 (Two a1 a2) = a1 - -second12 :: OneOrTwo a -> a -second12 (One a) = a -second12 (Two a1 a2) = a2 - -mapSecond12 :: (a -> a) -> OneOrTwo a -> OneOrTwo a -mapSecond12 f (One a) = One (f a) -mapSecond12 f (Two a1 a2) = Two a1 (f a2) - -zipWith12 :: (a -> b -> c) -> OneOrTwo a -> OneOrTwo b -> OneOrTwo c -zipWith12 f (One a) (One b) = One (f a b) -zipWith12 f (Two a a') (Two b b') = Two (f a b) (f a' b') - -zipWith123 :: (a -> b -> c -> d) -> - OneOrTwo a -> OneOrTwo b -> OneOrTwo c -> OneOrTwo d -zipWith123 f (One a) (One b) (One c) = One (f a b c) -zipWith123 f (Two a a') (Two b b') (Two c c') = Two (f a b c) (f a' b' c') - -toList12 :: OneOrTwo a -> [a] -toList12 (One a) = [a] -toList12 (Two a1 a2) = [a1,a2] - -fromList12 :: Show a => [a] -> OneOrTwo a -fromList12 [a] = One a -fromList12 [a1,a2] = Two a1 a2 -fromList12 l = error $ "fromList12 " ++ show l - -toMaybe12 :: Show a => [a] -> Maybe (OneOrTwo a) -toMaybe12 [] = Nothing -toMaybe12 [a] = Just $ One a -toMaybe12 [a1,a2] = Just $ Two a1 a2 -toMaybe12 l = error $ "toMaybe12 " ++ show l - - --- reader monad for local environment - -data TCContext = TCContext - { context :: SemCxt - , renaming :: Ren -- assigning de Bruijn Levels to names - , naming :: Map Int Name -- assigning names to de Bruijn levels --- , nameVariants :: Map Name Int -- how many variants of the name - , environ :: Env2 - , rewrites :: Rewrites - , sizeRels :: TSO Int -- relations of universal (rigid) size variables - -- collected from size patterns (x > y) - , belowInfty:: [Int] -- list of size variables < # - , bounds :: [Bound Val] -- bound hyps that do not fit in sizeRels - , consistencyCheck :: Bool -- ^ Do we need to check that new size relations are consistent with every valuation of the current @sizeRels@? [See ICFP 2013 paper] - , checkingConType :: Bool -- different PTS rules for constructor types (parametric function space!) - , assertionHandling :: AssertionHandling -- recover from errors? - , impredicative :: Bool -- use impredicative PTS rules - -- checking measured functions - , funsTemplate :: Map Name (Kinded Fun) -- types of mutual funs with measures checking body - , mutualFuns :: Map Name SigDef -- types of mutual funs while checking body - , mutualCo :: Co -- mutual block (co)recursive ? - , mutualNames :: [Name] -- ^ The defined names of the current mutual block (and parents). - , checkingMutualName :: Maybe DefId -- which body of a mutual block am I checking? - , callStack :: [QName] -- ^ Used to avoid looping when going into recursive data definitions. - } - -instance Show TCContext where - show ce = show (environ ce) ++ "; " ++ show (context ce) - -emptyContext = TCContext - { context = cxtEmpty - , renaming = Map.empty - , naming = Map.empty - , environ = emptyEnv - , rewrites = emptyRewrites - , sizeRels = TSO.empty - , belowInfty = [] - , bounds = [] - , consistencyCheck = False -- initially, no consistency check, turned on when entering rhs - , checkingConType = False - , assertionHandling = Failure -- default is not to ignore any errors - , impredicative = False - , funsTemplate = Map.empty - , mutualFuns = Map.empty - , mutualCo = Ind - , mutualNames = [] - , checkingMutualName = Nothing - , callStack = [] - } - --- state monad for global signature - -data TCState = TCState - { signature :: Signature - , metaVars :: MetaVars - , constraints :: Constraints - , positivityGraph :: PositivityGraph - -- , dots :: Dots -- UNUSED - } - -type MetaVars = Map MVar MetaVar -emptyMetaVars = Map.empty - -type MScope = [Name] -- ^ names of size variables which are in scope of mvar -data MetaVar = MetaVar - { mscope :: MScope - , solution :: Maybe Val - } - -type PosConstrnt = Constrnt PPoly DefId () -type PositivityGraph = [PosConstrnt] -emptyPosGraph = [] - --- type TypeCheck = StateT TCState (ReaderT TCContext (CallStackT String IO)) -type TypeCheck = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) - -instance MonadAssert TypeCheck where - assert b s = do - h <- asks assertionHandling - assert' h b s - newAssertionHandling h = local ( \ ce -> ce { assertionHandling = h }) - -{- mtl-2 provides these instances --- TypeCheck is applicative since every monad is. --- I do not know why this ain't in the libraries... -instance Applicative TypeCheck where - pure = return - mf <*> ma = mf >>= \ f -> ma >>= \ a -> pure (f a) --} - -{- NOT NEEDED - --- | Dotted constructors (the top one in the pattern). -type Dots = [(Dotted,Pattern)] - -emptyDots = [] - -class LensDots a where - getDots :: a -> Dots - setDots :: Dots -> a -> a - setDots = mapDots . const - mapDots :: (Dots -> Dots) -> a -> a - mapDots f a = setDots (f (getDots a)) a - -instance LensDots TCState where - getDots = dots - setDots d st = st { dots = d } - -newDotted :: Pattern -> TypeCheck Dotted -newDotted p = do - d <- mkDotted True - modify $ mapDots $ ((d,p):) - return d - -clearDots :: TypeCheck () -clearDots = modify $ setDots emptyDots - -openDots :: TypeCheck [Pattern] -openDots = map snd . filter (isDotted . fst) <$> gets dots --} - --- rewriting rules ----------------------------------------------- - -data Rewrite = Rewrite { lhs :: Val, rhs :: Val } -type Rewrites = [Rewrite] - -emptyRewrites = [] - -instance Show Rewrite where - show rr = show (lhs rr) ++ " --> " ++ show (rhs rr) - -{- renaming ------------------------------------------------------ - - A renaming maps names to de Bruijn levels (= generic values). --} - -type Ren = Map Name Int - -type Env2 = Environ (OneOrTwo Val) - -type Context a = Map Int a -type Context2 a = Context (OneOrTwo a) - -{- context ------------------------------------------------------- - -A context maps generic values to their type value. - -During type checking, named variables are mapped to -generic values via a renaming. Thus, looking up the type of a -name involves first looking up the generic value, and then its type. - --} - -{- --- data Domain = Domain { typ :: TVal, decor :: Dec } -data Domain = Domain { typ :: TVal, kind :: Class, decor :: Dec } - -mapTyp :: (TVal -> TVal) -> Domain -> Domain -mapTyp f dom = dom { typ = f (typ dom) } - -mapTypM :: Monad m => (TVal -> m TVal) -> Domain -> m Domain -mapTypM f dom = do - t' <- f (typ dom) - return $ dom { typ = t' } - -instance Show Domain where - show item = (if erased (decor item) then brackets else id) (show (typ item)) --} - --- During heterogeneous equality, a variable might have --- two different types, one on the left and one on the right. --- We implement this as Two tl tr. - -data CxtE a = CxtEntry { domain :: a, upperDec :: UDec } -type CxtEntry = CxtE (OneOrTwo Domain) -type CxtEntry1 = CxtE Domain - -data SemCxt = SemCxt - { len :: Int - , cxt :: Context2 Domain -- fixed part of context - , upperDecs :: Context UDec -- the "should be below" decoration for each var.; this is updated by resurrection - } -{- invariant: length (cxt delta) = length (upperDecs delta) = len - cxt(i) = Two ... iff upperDecs(i) = Two ... - -} - -instance Show SemCxt where - show delta = - show $ zip (Map.elems (cxt delta)) - (Map.elems (upperDecs delta)) -{- - show delta = show $ zip ( - zipWith3 (zipWith12 Domain) --- zipWith (\ entry dec -> fmap ((flip Domain) dec) entry) - (Map.elems (cxt delta)) - (Map.elems (kinds delta)) - (Map.elems (decs delta)) - ) (Map.elems (upperDecs delta)) --} -cxtEmpty = SemCxt - { len = 0 - , cxt = Map.empty --- , kinds = Map.empty --- , decs = Map.empty - , upperDecs = Map.empty - } - --- push a new type declaration on context -cxtPush' :: OneOrTwo Domain -> SemCxt -> SemCxt -cxtPush' entry delta = - delta { len = k + 1 - , cxt = Map.insert k entry (cxt delta) --- , cxt = Map.insert k (fmap typ entry) (cxt delta) --- , decs = Map.insert k (fmap decor entry) (decs delta) - , upperDecs = Map.insert k defaultUpperDec (upperDecs delta) - } - where k = len delta -{- -cxtPush' (tv12, dec) delta = - delta { len = k + 1 - , cxt = Map.insert k tv12 (cxt delta) - , decs = Map.insert k dec (decs delta) } - where k = len delta --} -{- -cxtPush :: Dec -> TVal -> SemCxt -> (Int, SemCxt) -cxtPush dec v delta = (len delta, cxtPush' (One (Domain v dec)) delta) --- cxtPush dec v delta = (len delta, cxtPush' (One v, dec) delta) --} - -cxtPushEntry :: OneOrTwo Domain -> SemCxt -> (Int, SemCxt) -cxtPushEntry ce delta = (len delta, cxtPush' ce delta) - -cxtPush :: Domain -> SemCxt -> (Int, SemCxt) -cxtPush dom delta = cxtPushEntry (One dom) delta --- cxtPush dec v delta = (len delta, cxtPush' (One v, dec) delta) - --- push a variable with a left and a right type -cxtPush2 :: Domain -> Domain -> SemCxt -> (Int, SemCxt) -cxtPush2 doml domr delta = cxtPushEntry (Two doml domr) delta --- (len delta, cxtPush' (Two doml domr) delta) - -{- --- push a variable with a left and a right type -cxtPush2 :: Dec -> TVal -> TVal -> SemCxt -> (Int, SemCxt) -cxtPush2 dec tvl tvr delta = - (len delta, cxtPush' (Two tvl tvr, dec) delta) --} - -cxtPushGen :: Name -> SemCxt -> (Int, SemCxt) -cxtPushGen x delta = cxtPush bot delta - where bot = error $ "IMPOSSIBLE: name " ++ show x ++ " is not bound to any type" - --- only defined for single bindings -cxtSetType :: Int -> Domain -> SemCxt -> SemCxt -cxtSetType k dom delta = - delta { cxt = Map.insert k (One dom) (cxt delta) - -- upperDecs need not be updated - } - --- | Version of 'Map.lookup' that throws 'TraceError'. -lookupM :: (MonadError TraceError m, Show k, Ord k) => k -> Map k v -> m v -lookupM k m = maybe (throwErrorMsg $ "lookupM: unbound key " ++ show k) return $ Map.lookup k m - -cxtLookupGen :: MonadError TraceError m => SemCxt -> Int -> m CxtEntry -cxtLookupGen delta k = do - dom12 <- lookupM k (cxt delta) - udec <- lookupM k (upperDecs delta) - return $ CxtEntry dom12 udec - -cxtLookupName :: MonadError TraceError m => SemCxt -> Ren -> Name -> m CxtEntry -cxtLookupName delta ren x = do - i <- lookupM x ren - cxtLookupGen delta i - --- apply decoration, possibly resurrecting (see Pfenning, LICS 2001) --- and changing polarities (see Abel, MSCS 2008) -cxtApplyDec :: Dec -> SemCxt -> SemCxt -cxtApplyDec dec delta = delta { upperDecs = Map.map (compDec dec) (upperDecs delta) } --- cxtApplyDec dec delta = delta { decs = Map.map (fmap $ invCompDec dec) (decs delta) } - -{- RETIRED, use cxtApplyDec instead --- clear all "erased" flags (see Pfenning, LICS 2001) --- UPDATE: resurrection sets "target" status to erased --- (as opposed to setting "source" status to non-erased) -cxtResurrect :: SemCxt -> SemCxt -cxtResurrect delta = delta { upperDecs = Map.map (\ dec -> dec { erased = True}) (upperDecs delta) } --- cxtResurrect delta = delta { decs = Map.map (fmap resurrectDec) (decs delta) } --} - --- manipulating the context ------------------------------------------ - -{- --- | Size decrements in bounded quantification do not count for termination -data LamPi - = LamBind -- ^ add a lambda binding to the context - | PiBind -- ^ add a pi binding to the context --} - -class Monad m => MonadCxt m where --- bind :: Name -> Domain -> Val -> m a -> m a --- new performs eta-expansion "up" of new gen - -- adding types (Two t1 t2) returns values (Two (Up t1 vi) (Up t2 vi)) - newVar :: Name -> OneOrTwo Domain -> (Int -> OneOrTwo Val -> m a) -> m a - newWithGen :: Name -> Domain -> (Int -> Val -> m a) -> m a - newWithGen x d k = newVar x (One d) - (\ i (One v) -> k i v) - new2WithGen:: Name -> (Domain, Domain) -> (Int -> (Val, Val) -> m a) -> m a - new2WithGen x (doml, domr) k = newVar x (Two doml domr) - (\ i (Two vl vr) -> k i (vl, vr)) - new :: Name -> Domain -> (Val -> m a) -> m a - new x d cont = newWithGen x d (\ _ -> cont) - new2 :: Name -> (Domain, Domain) -> ((Val, Val) -> m a) -> m a - new2 x d cont = new2WithGen x d (\ _ -> cont) -{- - new2 :: Name -> (TVal, TVal, Dec) -> ((Val, Val) -> m a) -> m a - new2 x d cont = new2WithGen x d (\ _ -> cont) --} - new' :: Name -> Domain -> m a -> m a - new' x d cont = new x d (\ _ -> cont) - newIrr :: Name -> m a -> m a -- only add binding x = VIrr to env - addName :: Name -> (Val -> m a) -> m a -{- RETIRED - addTypeSigs :: [TySig TVal] -> m a -> m a - addTypeSigs [] k = k - addTypeSigs (TypeSig n tv : tss) k = - new' n (defaultDomain tv) $ addTypeSigs tss k --} - addKindedTypeSigs :: [Kinded (TySig TVal)] -> m a -> m a - addKindedTypeSigs [] k = k - addKindedTypeSigs (Kinded ki (TypeSig n tv) : ktss) k = - new' n (Domain tv ki defaultDec) $ addKindedTypeSigs ktss k --- addName x = new x dontCare - setType :: Int -> Domain -> m a -> m a - setTypeOfName :: Name -> Domain -> m a -> m a - genOfName :: Name -> m Int - nameOfGen :: Int -> m Name --- nameTaken :: Name -> m Bool - uniqueName :: Name -> Int -> m Name - uniqueName x _ = return x -- $ freshen x -- TODO! now freshen causes problems in extraction -{- - uniqueName x k = ifM (nameTaken x) (return $ show x ++ "~" ++ show k) (return x) --} - lookupGen :: Int -> m CxtEntry - lookupGenType2 :: Int -> m (TVal, TVal) - lookupGenType2 i = do - entry <- lookupGen i - case domain entry of - One d1 -> return (typ d1, typ d1) - Two d1 d2 -> return (typ d1, typ d2) - lookupName :: Name -> m CxtEntry - lookupName1 :: Name -> m CxtEntry1 - lookupName1 x = do - e <- lookupName x - return $ CxtEntry (fromOne (domain e)) (upperDec e) - - getContextTele :: m TeleVal -- return context as telescope of type values - getLen :: m Int -- return length of the context - getEnv :: m Env -- return current environment - getRen :: m Ren -- return current renaming - applyDec :: Dec -> m a -> m a -- resurrect/adjust polarities - resurrect :: m a -> m a -- resurrect all erased variables in context - resurrect = applyDec irrelevantDec - addRewrite :: Rewrite -> [Val] -> ([Val] -> m a) -> m a - addPattern :: TVal -> Pattern -> Env -> (TVal -> Val -> Env -> m a) -> m a -- step under pat - addPatterns:: TVal -> [Pattern] -> Env -> (TVal -> [Val] -> Env -> m a) -> m a - addSizeRel :: Int -> Int -> Int -> m a -> m a - addBelowInfty :: Int -> m a -> m a - addBoundHyp :: Bound Val -> m a -> m a - isBelowInfty :: Int -> m Bool - sizeVarBelow :: Int -> Int -> m (Maybe Int) --- getSizeDiff :: Int -> Int -> m (Maybe Int) - getMinSize :: Int -> m (Maybe Int) - getSizeVarsInScope :: m [Name] - checkingCon :: Bool -> m a -> m a - checkingDom :: m a -> m a -- check domain A of Pi x:A.B (takes care of polarities) - setCo :: Co -> m a -> m a -- entering a recursive or corecursive function? - installFuns :: Co -> [Kinded Fun] -> m a -> m a - setMeasure :: Measure Val -> m a -> m a - activateFuns :: m a -> m a -- create instance of mutually recursive functions bounded by measure - goImpredicative :: m a -> m a - checkingMutual :: Maybe DefId -> m a -> m a - -dontCare = error "Internal error: tried to retrieve unassigned type of variable" - -instance MonadCxt TypeCheck where - - newIrr x = local (\ ce -> ce { environ = update (environ ce) x (One VIrr) }) - - -- UPDATE to 2? - addName x f = enter ("new " ++ show x ++ " : _") $ do - cxtenv <- ask - let (k, delta) = cxtPushGen x (context cxtenv) - let v = VGen k - let rho = update (environ cxtenv) x (One v) - x' <- uniqueName x k - local (\ cxt -> cxt { context = delta - , renaming = Map.insert x k (renaming cxtenv) - , naming = Map.insert k x' (naming cxt) - , environ = rho }) (f v) - - - newVar x dom12@(One (Domain (VBelow ltle v) ki dec)) f = do - enter ("new " ++ show x ++ " " ++ show ltle ++ " " ++ show v) $ do - cxtenv <- ask - let (k, delta) = cxtPushEntry (One (Domain vSize kSize dec)) (context cxtenv) - let xv = VGen k - let v12 = One xv - let rho = update (environ cxtenv) x v12 - let beta = Bound ltle (Measure [xv]) (Measure [v]) - x' <- uniqueName x k - local (\ cxt -> cxt { context = delta - , renaming = Map.insert x k (renaming cxtenv) - , naming = Map.insert k x' (naming cxtenv) - , environ = rho }) $ - addBoundHyp beta $ (f k v12) - - - newVar x dom12 f = do - let tv12 = fmap typ dom12 - enter ("new " ++ show x ++ " : " ++ show tv12) $ do - cxtenv <- ask - let (k, delta) = cxtPushEntry dom12 (context cxtenv) - v12 <- Traversable.mapM (up False (VGen k)) tv12 - let rho = update (environ cxtenv) x v12 - x' <- uniqueName x k - local (\ cxt -> cxt { context = delta - , renaming = Map.insert x k (renaming cxtenv) - , naming = Map.insert k x' (naming cxtenv) - , environ = rho }) (f k v12) -{- - newVar x (tv12, dec) f = enter ("new " ++ x ++ " : " ++ show tv12) $ do - cxtenv <- ask - let (k, delta) = cxtPushEntry (tv12, dec) (context cxtenv) - v12 <- Traversable.mapM (up (VGen k)) tv12 - let rho = update (environ cxtenv) x v12 - local (\ cxt -> cxt { context = delta - , renaming = Map.insert x k (renaming cxtenv) - , environ = rho }) (f k v12) --} - setType k dom = - local (\ ce -> ce { context = cxtSetType k dom (context ce) }) - - setTypeOfName x dom cont = do - ce <- ask - let Just k = Map.lookup x (renaming ce) - setType k dom cont - - genOfName x = do - ce <- ask - case Map.lookup x (renaming ce) of - Nothing -> throwErrorMsg $ "internal error: variable not bound: " ++ show x - Just k -> return k - - nameOfGen k = do - ce <- ask - case Map.lookup k (naming ce) of - Nothing -> return $ fresh $ "error_unnamed_gen" ++ show k - -- throwErrorMsg $ "internal error: no name for variable " ++ show k - Just x -> return x - -{- - nameTaken "" = return True - nameTaken x = do - ce <- ask - st <- get - return (Map.member x (renaming ce) || Map.member x (signature st)) --} - - lookupGen k = do - ce <- ask - cxtLookupGen (context ce) k - - lookupName x = do - ce <- ask - cxtLookupName (context ce) (renaming ce) x - - -- does not work with shadowing! - getContextTele = do - ce <- ask - let cxt = context ce - let ren = renaming ce - let env = envMap $ environ ce - let mkTBind (x,_) = (TBind x .fromOne . domain) <$> cxtLookupName cxt ren x - mapM mkTBind env - - getLen = do - ce <- ask - return $ len (context ce) - - getRen = do - ce <- ask - return $ renaming ce - - -- since we only use getEnv during type checking, no case for Two - -- (during equality/subtype checking, we have values) - getEnv = do - ce <- ask - let (Environ rho mmeas) = environ ce - return $ Environ (map (\ (x, One v) -> (x, v)) rho) mmeas - - applyDec dec = local (\ ce -> ce { context = cxtApplyDec dec (context ce) }) --- applyDec dec = local (\ ce -> ce { upperDecs = Map.map (compDec dec) (upperDecs ce) }) - - -- resurrection sets "target" status to erased - -- (as opposed to setting "source" status to non-erased) -{- - resurrect = local (\ ce -> ce { upperDecs = - Map.map (\ dec -> dec { erased = True }) (upperDecs ce) }) --} -{- - resurrect = local (\ ce -> ce { context = cxtResurrect (context ce) }) --} - - - -- PROBABLY TOO INEFFICIENT - addRewrite rew vs cont = traceRew ("adding rewrite " ++ show rew) $ - -- add rewriting rule - local (\ cxt -> cxt { rewrites = rew : (rewrites cxt) }) $ do - ce <- ask - -- normalize all types in context - traceRewM "normalizing types in context" - cx' <- mapMapM (Traversable.mapM (Traversable.mapM reval)) (cxt (context ce)) -- LOOP! - -- normalize environment - traceRewM "normalizing environment" - let Environ rho mmeas = environ ce - rho' <- mapM (\ (x,v12) -> Traversable.mapM reval v12 >>= \ v12' -> return (x, v12')) rho - let en' = Environ rho' mmeas -- no need to rewrite in measure since only size expressions - -- normalize given values - vs' <- mapM reval vs - -- continue in updated context - local (\ ce -> ce { context = (context ce) { cxt = cx' } - , environ = en' }) $ cont vs' - - -- addPattern :: TVal -> Pattern -> (TVal -> Val -> Env -> m a) -> m a - addPattern tv@(VQuant Pi x dom fv) p rho cont = - case p of - VarP y -> underAbs y dom fv $ \ _ xv bv -> do - cont bv xv (update rho y xv) - - SizeP e y -> underAbs y dom fv $ \ j xv bv -> do - ve <- whnf' e - addBoundHyp (Bound Lt (Measure [xv]) (Measure [ve])) $ - cont bv xv (update rho y xv) -{- - SizeP z y -> newWithGen y dom $ \ j xv -> do - bv <- whnf (update env x xv) b - VGen k <- whnf' (Var z) - addSizeRel j 1 k $ - cont bv xv (update rho y xv) --} - ConP pi n pl -> do - sige <- lookupSymbQ n - vc <- conLType n (typ dom) - addPatterns vc pl rho $ \ vc' vpl rho -> do -- apply dom to pl? - pv0 <- mkConVal notDotted (coPat pi) n vpl vc - pv <- up False pv0 (typ dom) - vb <- app fv pv - cont vb pv rho -{- - ConP pi n pl -> do - sige <- lookupSymb n - let vc = symbTyp sige - addPatterns vc pl rho $ \ vc' vpl rho -> do -- apply dom to pl? - pv0 <- foldM app (vCon (coPat pi) n) vpl - pv <- up False pv0 (typ dom) - vb <- whnf (update env x pv) b - cont vb pv rho --} - SuccP p2 -> do - addPattern (vSize `arrow` vSize) p2 rho $ \ _ vp2 rho -> do - let pv = succSize vp2 - vb <- app fv pv - cont vb pv rho - - ErasedP p -> addPattern tv p rho cont - --- for dot patterns, we have to do something smart, because they might --- contain identifiers which are not yet in scope, only after adding --- other patterns --- the following trivial solution only works for trivial dot patterns, i.e., --- such that do not use yet undeclared identifiers - - DotP e -> do - v <- whnf rho e - vb <- app fv v - cont vb v rho -- [(x,v)] - - - addPatterns tv [] rho cont = cont tv [] rho - addPatterns tv (p:ps) rho cont = - addPattern tv p rho $ \ tv' v env -> - addPatterns tv' ps env $ \ tv'' vs env' -> - cont tv'' (v:vs) env' -- (env' ++ env) - - addSizeRel son dist father k = do - let s = "v" ++ show son ++ " + " ++ show dist ++ " <= v" ++ show father - enter -- enterTrace - ("adding size rel. " ++ s) $ do - let modBI belowInfty = if father `elem` belowInfty || dist > 0 then son : belowInfty else belowInfty - whenM (asks consistencyCheck `andLazy` do - TSO.increasesHeight son (dist, father) <$> asks sizeRels) $ do - recoverFail $ "cannot add hypothesis " ++ s ++ " because it is not satisfyable under all possible valuations of the current hypotheses" - -- if the new son is an ancestor of the father, we are cyclic - whenJustM (TSO.isAncestor father son <$> asks sizeRels) $ \ n -> -- n steps from father up to son - when (dist > - n) $ -- still ok if dist == n == 0, otherwise fail - recoverFail$ "cannot add hypothesis " ++ s ++ " because it makes the set of hyptheses unsatisfiable" - local (\ cxt -> cxt - { sizeRels = TSO.insert son (dist, father) (sizeRels cxt) - , belowInfty = modBI (belowInfty cxt) - }) k - - addBelowInfty i = local $ \ cxt -> cxt { belowInfty = i : belowInfty cxt } - - addBoundHyp beta@(Bound ltle (Measure mu) (Measure mu')) cont = - case (ltle, mu, mu') of - (Le, _, [VInfty]) -> cont --- (Lt, _, [VInfty]) -> failure -- handle j < # - (ltle, [v], [v']) -> loop (if ltle==Lt then 1 else 0) v v' - _ -> failure - where failure = do --- recoverFail $ "adding hypothetical constraint " ++ show beta ++ " not supported" - assertDoc' Warning False (text "hypothetical constraint" <+> prettyTCM beta <+> text "ignored") - cont - - loop n (VGen i) VInfty = addBelowInfty i cont - loop n (VGen i) (VGen j) | n >= 0 = addSizeRel i n j cont - | otherwise = addIrregularBound i j (-n) cont - loop n (VSucc v) v' = loop (n + 1) v v' - loop n v (VSucc v') = loop (n - 1) v v' - loop _ _ _ = failure - - addIrregularBound i j n = local (\ ce -> ce { bounds = beta : bounds ce }) where - v' = iterate VSucc (VGen j) !! n - beta = Bound Le (Measure [VGen i]) (Measure [v']) - - isBelowInfty i = (i `elem`) <$> asks belowInfty - -{- - isBelowInfty i = do - belowInfty <- asks belowInfty - if (i `elem` belowInfty) then return True else do - tso <- asks sizeRels - loop $ parents i tso where - loop [] = return False - loop [(_,j)] = return $ j `elem` belowInfty - loop (x:xs) = loop xs --} - - sizeVarBelow son ancestor = do - cxt <- ask - return $ TSO.isAncestor son ancestor (sizeRels cxt) -{- - getSizeDiff son ancestor = do - cxt <- ask - return $ TSO.diff son ancestor (sizeRels cxt) --} - getMinSize parent = do - cxt <- ask - return $ TSO.height parent (sizeRels cxt) - - getSizeVarsInScope = do - TCContext { context = delta, naming = nam } <- ask - -- get all the size variables with positive or mixed polarity - let fSize (i, tv12) = - case tv12 of - One dom -> isVSize $ typ dom - _ -> -- trace ("not a size variable " ++ show i ++ " : " ++ show tv12) $ - False - -- create a list of key (gen) and Domain pairs for the size variables - let idl = filter fSize $ Map.toAscList (cxt delta) - let udecs = upperDecs delta - let fPos (i, One dom) = - case fromPProd (polarity (Maybe.fromJust (Map.lookup i udecs))) of - Just p -> leqPol (polarity (decor dom)) p - Nothing -> False - let fName (i, _) = Maybe.fromJust $ Map.lookup i nam - return $ map fName $ filter fPos idl - - - checkingCon b = local (\ cxt -> cxt { checkingConType = b}) - -{- - checkingDom = local $ \ cxt -> - if checkingConType cxt then cxt - else cxt { context = cxtApplyDec (Dec False Neg) (context cxt) } --} - -- check domain A of (x : A) -> B - checkingDom k = do - b <- asks checkingConType - if b then k else applyDec (Dec Neg) k - - setCo co = local (\ cxt -> cxt { mutualCo = co }) - - -- install functions for checking function clauses - -- ==> use internal names - installFuns co kfuns k = do - let funt = foldl (\ m fun@(Kinded _ (Fun (TypeSig n _) n' _ _)) -> Map.insert n fun m) - Map.empty - kfuns - local (\ cxt -> cxt { mutualCo = co, funsTemplate = funt }) k - - setMeasure mu k = do - rho0 <- getEnv - let rho = rho0 { envBound = Just mu } - local (\ cxt -> cxt - { environ = (environ cxt) { envBound = Just mu } - }) k - - activateFuns k = do - rho <- getEnv - case (envBound rho) of - Nothing -> k - Just mu -> - local (\ cxt -> cxt - { mutualFuns = - Map.map (boundFun rho (mutualCo cxt)) (funsTemplate cxt) - }) k - where boundFun :: Env -> Co -> Kinded Fun -> SigDef - boundFun rho co (Kinded ki (Fun (TypeSig n t) n' ar cls)) = - FunSig co (VClos rho t) ki ar cls False undefined - -{- - activateFuns mu k = do - rho0 <- getEnv - let rho = rho0 { envBound = Just mu } - local (\ cxt -> cxt - { environ = (environ cxt) { envBound = Just mu } - , mutualFuns = - Map.map (boundFun rho (mutualCo cxt)) (funsTemplate cxt) - }) k - where boundFun :: Env -> Co -> Fun -> SigDef - boundFun rho co (TypeSig n t, (ar, cls)) = - FunSig co (VClos rho t) ar cls False - -} - - goImpredicative = local (\ cxt -> cxt { impredicative = True }) - - checkingMutual mn = local (\ cxt -> cxt { checkingMutualName = mn }) - --- | Go into the codomain of a Pi-type or open an abstraction. -underAbs :: Name -> Domain -> FVal -> (Int -> Val -> Val -> TypeCheck a) -> TypeCheck a -underAbs x dom fv cont = newWithGen x dom $ \ i xv -> cont i xv =<< app fv xv - --- | Do not check consistency preservation of context. -underAbs_ :: Name -> Domain -> FVal -> (Int -> Val -> Val -> TypeCheck a) -> TypeCheck a -underAbs_ x dom fv cont = noConsistencyChecking $ underAbs x dom fv cont - -noConsistencyChecking = local $ \ cxt -> cxt { consistencyCheck = False } - --- | No eta, no hypotheses. First returned val is a @VGen i@. -underAbs' :: Name -> FVal -> (Val -> Val -> TypeCheck a) -> TypeCheck a -underAbs' x fv cont = addName x $ \ xv -> cont xv =<< app fv xv - --- addBind :: MonadTCM m => TBind -> m a -> m a -addBind :: TBind -> TypeCheck a -> TypeCheck a -addBind (TBind x dom) cont = do - dom' <- (Traversable.mapM whnf' dom) - new' x dom' cont - -addBinds :: Telescope -> TypeCheck a -> TypeCheck a -addBinds tel k0 = foldr addBind k0 $ telescope tel - --- introduce patterns into context and environment ------------------- --- DOES NOT ETA-EXPAND VARIABLES!! ----------------------------------- - -introPatterns :: [Pattern] -> TVal -> ([(Pattern,Val)] -> TVal -> TypeCheck a) -> TypeCheck a -introPatterns ps tv cont = -- Problem: NO ETA EXPANSION! - introPatVars ps $ do -- first bind pattern variables - vs <- mapM (whnf' . patternToExpr) ps -- now we can evaluate patterns - let pvs = zip ps vs - introPatTypes pvs tv (cont pvs) -- now we can assign types to pvars - --- introduce variables bound in pattern into the environment --- extend delta by generic values but do not introduce their types --- this is to deal with dot patterns -introPatVar :: Pattern -> TypeCheck a -> TypeCheck a -introPatVar p cont = - case p of - VarP n -> addName n $ \ _ -> cont - SizeP m n -> addName n $ \ _ -> cont - ConP co n pl -> introPatVars pl cont - PairP p1 p2 -> introPatVars [p1,p2] cont - SuccP p -> introPatVar p cont - ProjP{} -> cont - DotP e -> cont - AbsurdP -> cont - ErasedP p -> introPatVar p cont - -introPatVars :: [Pattern] -> TypeCheck a -> TypeCheck a -introPatVars [] cont = cont -introPatVars (p:ps) cont = introPatVar p $ introPatVars ps $ cont - --- if the bindings name->gen are already in the environment --- we can now bind the gen to their types -introPatType :: (Pattern,Val) -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a -introPatType (p,v) tv cont = do - case tv of - VGuard beta bv -> addBoundHyp beta $ introPatType (p,v) bv cont - VApp (VDef (DefId DatK d)) vl -> - case p of - ProjP n -> cont =<< projectType tv n VIrr -- no record value here - _ -> throwErrorMsg $ "introPatType: internal error, expected projection pattern, found " ++ show p ++ " at type " ++ show tv - VQuant Pi x dom fv -> do - v <- whnfClos v - matchPatType (p,v) dom . cont =<< app fv v - _ -> throwErrorMsg $ "introPatType: internal error, expected Pi-type, found " ++ show tv - -introPatTypes :: [(Pattern,Val)] -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a -introPatTypes pvs tv f = do - case pvs of - [] -> f tv - (pv:pvs') -> introPatType pv tv $ \ tv' -> introPatTypes pvs' tv' f - -matchPatType :: (Pattern, Val) -> Domain -> TypeCheck a -> TypeCheck a -matchPatType (p,v) dom cont = - case (p,v) of - -- erasure does not matter! - (VarP y, VGen k) -> setType k dom $ cont - - (SizeP z y, VGen k) -> setType k dom $ cont - - (ConP co n [], _) -> cont - - (ConP co n pl, VApp (VDef (DefId ConK{} _)) vl) -> do -{- - sige <- lookupSymb n - let vc = symbTyp sige --} - vc <- conType n =<< force (typ dom) - introPatTypes (zip pl vl) vc $ \ _ -> cont - - (SuccP p2, VSucc v2) -> matchPatType (p2, v2) (defaultDomain vSize) $ cont - - (PairP p1 p2, VPair v1 v2) -> do - av <- force (typ dom) - case av of - VQuant Sigma x dom1@(Domain av1 ki dec) fv -> do - matchPatType (p1,v1) dom1 $ do - bv <- app fv v1 - matchPatType (p2,v2) (Domain bv ki dec) cont - _ -> throwErrorMsg $ "matchPatType: IMPOSSIBLE " ++ show p ++ " : " ++ show dom - - (DotP e, _) -> cont - (AbsurdP, _) -> cont - (ErasedP p,_) -> matchPatType (p,v) dom cont - _ -> throwErrorMsg $ "matchPatType: IMPOSSIBLE " ++ show (p,v) - - --- Signature ----------------------------------------------------- - --- input to and output of the type-checker - -type Signature = Map QName SigDef - --- a signature entry is either --- * a fun/cofun, --- * a defined constant, --- * a constructor, or --- * a data type id with its kind --- they share "symbTyp", the type signature of the definition -data SigDef - = FunSig { isCo :: Co - , symbTyp :: TVal - , symbolKind :: Kind - , arity :: Arity - , clauses :: [Clause] - , isTypeChecked :: Bool - , extrTyp :: Expr -- ^ Fomega type. - } - | LetSig { symbTyp :: TVal - , symbolKind :: Kind - , definingVal :: Val --- , definingExpr :: Expr - , extrTyp :: Expr -- ^ Fomega type. - } - | PatSig { patVars :: [Name] - , definingPat :: Pattern - , definingVal :: Val - } - | ConSig { conPars :: ConPars - -- ^ Parameter patterns and no. of variable they bind. - -- @Nothing@ if old-style parameters. - , lhsTyp :: LHSType - -- ^ LHS type of constructor for pattern matching, e.g. - -- rhs @cons : [A : Set] [i : Size] -> A -> List A i -> List A $i@ - -- lhs @cons : [A : Set] [i : Size] [j < i] -> A -> List A j -> List A i@ - -- @Name@ is the name of the size parameter. - , recOccs :: [Bool] - -- ^ @True@ if argument contains rec.occs.of the (co)data type? - , symbTyp :: TVal -- ^ (RHS) type, includs parameter tel. - , dataName :: Name -- ^ Its datatype. - , dataPars :: Int -- ^ No. of parameters of its datatype. - , extrTyp :: Expr -- ^ Fomega type. - } - | DataSig { numPars :: Int - , positivity :: [Pol] - , isSized :: Sized - , isCo :: Co - , symbTyp :: TVal - , symbolKind :: Kind - -- the following information is only needed for eta-expansion - -- hence it is only provided for suitable ind.fams. - , constructors :: [ConstructorInfo] - , etaExpand :: Bool -- non-overlapping pattern inductive family - -- with at least one eta-expandable constructor - , isTuple :: Bool -- each constructor is irrefutable - -- must be (NEW: non-overlapping) pattern inductive family - -- qualifies for target of corecursive fun - -- NO LONGER: exactly one constructor - -- NOW: at least one constructor - -- can be recursive - , extrTyp :: Expr -- Fomega kind -{- - , destructors :: Maybe [Name] -- Nothing if not a record - , isFamily :: Bool --} - } -- # parameters, positivity of parameters , sized , co , type - deriving (Show) - --- | Parameter patterns and no. of variables they bind. -type ConPars = Maybe ([Name], [Pattern]) - --- | LHS type plus name of size index. -type LHSType = Maybe (Name, TVal) - -isEmptyData :: QName -> TypeCheck Bool -isEmptyData n = do - sig <- lookupSymbQ n - case sig of - DataSig { constructors } -> return $ null constructors - _ -> throwErrorMsg $ "internal error: isEmptyData " ++ show n ++ ": name of data type expected" - -isUnitData :: QName -> TypeCheck Bool -isUnitData n = do - sig <- lookupSymbQ n - case sig of - DataSig { constructors = [c], isTuple } -> return $ - isTuple && null (cFields c) && cPatFam c == (LinearPatterns, []) - DataSig { constructors } -> return False - _ -> throwErrorMsg $ "internal error: isUnitData " ++ show n ++ ": name of data type expected" - - -undefinedFType :: QName -> Expr -undefinedFType n = Irr --- undefinedFType n = error $ "no extracted type for " ++ show n - -symbKind :: SigDef -> Kind -symbKind ConSig{} = kTerm -- constructors are always terms -symbKind d = symbolKind d -- else: lookup -{- Data types can be big!! -symbKind DataSig{} = kType -- data types are never universes --} - -emptySig = Map.empty - --- Handling constructor types ------------------------------------------ - -data DataView - = Data Name [Clos] - | NoData - --- | Check if type @tv@ is a datatype @D vs@. -dataView :: TVal -> TypeCheck DataView -dataView tv = do - tv <- force tv - case tv of -{- 2012-01-31 EVIL, LEADS TO UNBOUND VARS: - VQuant Pi x dom env b -> do - new x dom $ \ xv -> dataView =<< whnf (update env x xv) b --} - VApp (VDef (DefId DatK n)) vs -> return $ Data (unqual n) vs - VSing v dv -> dataView =<< whnfClos dv - _ -> return $ NoData - --- | Disambiguate possibly overloaded constructor @c@ at given type @tv@. -disambigCon :: QName -> TVal -> TypeCheck QName -disambigCon c tv = - case c of - Qual{} -> return c - QName n -> do - dv <- dataView tv - case dv of - Data d _ -> return $ Qual d n - _ -> throwErrorMsg $ "cannot resolve constructor " ++ show n - --- | @conType c tv@ returns the type of constructor @c@ at datatype @tv@ --- with parameters instantiated. -conType :: QName -> TVal -> TypeCheck TVal -conType c tv = do - c <- disambigCon c tv - ConSig { conPars, symbTyp, dataName, dataPars } <- lookupSymbQ c - instConType c conPars symbTyp dataName dataPars tv - --- | Get LHS type of constructor. --- --- Constructors or sized data types internally have a lhs type --- that differs from its rhs type. E.g., --- rhs @suc : [i : Size] -> Nat i -> Nat $i@ --- lhs @suc : [i : Size] [j < i] -> Nat j -> Nat i@. --- In the lhs type, @i@ turns into an additional parameter. -conLType :: QName -> TVal -> TypeCheck TVal -conLType c tv = do - c <- disambigCon c tv - ConSig { conPars, lhsTyp, symbTyp, dataName, dataPars } <- lookupSymbQ c - case lhsTyp of - Nothing -> instConType c conPars symbTyp dataName dataPars tv - Just (x, lTyp) -> instConType c (fmap (inc x) conPars) lTyp dataName (dataPars+1) tv - where inc x (xs, ps) = (xs ++ [x], ps ++ [VarP x]) - --- | Instantiate type of constructor to parameters obtained from --- the data type. --- --- @instConType c n symbTyp dataName tv@ --- instantiates type @symbTyp@ of constructor @c@ with first @n@ arguments --- that @dataName@ is applied to in @tv@. --- @@ --- instConType c n ((x1:A1..xn:An) -> B) d (d v1..vn ws) = B[vs/xs] --- @@ -instConType :: QName -> ConPars -> TVal -> Name -> Int -> TVal -> TypeCheck TVal -instConType c conPars symbTyp dataName dataPars tv = - instConLType' c conPars symbTyp Nothing (Just dataName) dataPars tv -{- -instConType c numPars symbTyp dataName tv = do - dv <- dataView tv - case dv of - NoData -> failDoc (text ("conType " ++ show c ++ ": expected") - <+> prettyTCM tv <+> text "to be a data type") - Data d vs -> do - unless (d == dataName) $ throwErrorMsg $ "expected constructor of datatype " ++ show d ++ ", but found one of datatype " ++ show dataName - let (pars, inds) = splitAt numPars vs - unless (length pars == numPars) $ - failDoc (text ("conType " ++ show c ++ ": expected") - <+> prettyTCM tv - <+> text ("to be a data type applied to all of its " ++ - show numPars ++ " parameters")) - piApps symbTyp pars --} - --- | Get correct lhs type for constructor pattern. --- --- @instConLType c numPars symbTyp Nothing isFlex tv@ behaves like --- @instConLType c numPars symbType _ tv@. --- --- But if the data types is sized and the constructor has a lhs type, --- @instConLType c numPars symbTyp (Just ltv) isFlex tv@ --- uses the lhs type @ltv@ unless the variable instantiated for --- the size argument is flexible (because then it wants to be --- unified with the successor pattern of the rhs type. -instConLType :: QName -> ConPars -> TVal -> LHSType -> (Val -> Bool) -> Int -> TVal -> TypeCheck TVal -instConLType c conPars rhsTyp lhsTyp isFlex dataPars dataTyp = - instConLType' c conPars rhsTyp (fmap (,isFlex) lhsTyp) Nothing dataPars dataTyp - --- | The common pattern behind @instConType@ and @instConLType@. -instConLType' :: QName -> ConPars -> TVal -> Maybe ((Name, TVal), Val -> Bool) -> Maybe Name -> Int -> TVal -> TypeCheck TVal -instConLType' c conPars symbTyp isSized md dataPars tv = - enter ("instConLType'") $ do - let failure = failDoc (text ("conType " ++ show c ++ ": expected") - <+> prettyTCM tv - <+> text ("to be a data type applied to all of its " ++ - show dataPars ++ " parameters")) - dv <- dataView tv - case dv of - NoData -> failDoc (text ("conType " ++ show c ++ ": expected") - <+> prettyTCM tv <+> text "to be a data type") - Data d vs -> do - whenJust md $ \ d' -> - unless (d == d') $ throwErrorMsg $ "expected constructor of datatype " ++ show d ++ ", but found one of datatype " ++ show d' - -- whenJust conPars $ throwErrorMsg $ "NYI: constructor with pattern parameters" - let (pars, inds) = splitAt dataPars vs - unless (length pars == dataPars) failure - case (isSized, inds) of - (Just _, []) -> failure - -- if size index not flexible, use lhs type - (Just ((x,ltv), isFlex), sizeInd:_) | not (isFlex sizeInd) -> - continue d [x] ltv (pars ++ [sizeInd]) - -- otherwise, use rhs type - _ -> continue d [] symbTyp pars - where - continue d ys tv pars = case conPars of - Nothing -> piApps tv pars - Just (xs, ps) -> do - let failure = failDoc $ sep - [ text "instConType:" - , text "cannot match parameters" <+> prettyList (map prettyTCM pars) - , text "against patterns" <+> prettyList (map prettyTCM ps) - , text "when instantiating type" <+> prettyTCM tv - , text ("of constructor " ++ show c) - ] - -- clear dots here: - mst <- nonLinMatchList' True True (emptyEnv, []) ps pars =<< lookupSymbTyp d - case mst of - Nothing -> failure - Just (Environ{ envMap = env0 }, psub) -> do - let env = env0 ++ [ (x, VGen i) | (i, VarP x) <- psub ] - -- if length env /= length xs then failure else do - vs <- forM (xs ++ ys) $ \ x -> maybe failure return $ lookup x env - piApps tv vs -{- - menv <- matchList emptyEnv ps pars - case menv of - Nothing -> failure - Just Environ{ envMap = env } -> if length env /= length xs then failure else do - vs <- forM (xs ++ ys) $ \ x -> maybe failure return $ lookup x env - piApps tv vs --} - -{- - case isSized of - Nothing -> piApps symbTyp pars - Just ltv -> do - when (null inds) failure - let sizeInd = head inds - if isFlex sizeInd then piApps symbTyp pars else piApps ltv (pars ++ [sizeInd]) --} - --- Signature specification ------------------------------------------- - -class MonadCxt m => MonadSig m where - lookupSymbTypQ :: QName -> m TVal - lookupSymbQ :: QName -> m SigDef - addSigQ :: QName -> SigDef -> m () - modifySigQ :: QName -> (SigDef -> SigDef) -> m () - setExtrTypQ :: QName -> Expr -> m () - - lookupSymbTyp :: Name -> m TVal - lookupSymbTyp = lookupSymbTypQ . QName - - lookupSymb :: Name -> m SigDef - lookupSymb = lookupSymbQ . QName - - addSig :: Name -> SigDef -> m () - addSig = addSigQ . QName - - modifySig :: Name -> (SigDef -> SigDef) -> m () - modifySig = modifySigQ . QName - - setExtrTyp :: Name -> Expr -> m () - setExtrTyp = setExtrTypQ . QName - --- Signature implementation ------------------------------------------ - -instance MonadSig TypeCheck where - - -- first in context, then in signature - -- lookupSymbTyp :: Name -> TypeCheck TVal - lookupSymbTyp n = do - mdom <- errorToMaybe $ lookupName1 n - case mdom of - Just (CxtEntry dom udec) -> return (typ dom) - Nothing -> symbTyp <$> lookupSymb n - - lookupSymbTypQ (QName n) = lookupSymbTyp n - lookupSymbTypQ n@Qual{} = symbTyp <$> lookupSymbQ n - - -- lookupSymb :: Name -> TypeCheck SigDef - lookupSymb n = do - cxt <- ask - case Map.lookup n (mutualFuns cxt) of - Just k -> return $ k - Nothing -> lookupSymbInSig (QName n) - - lookupSymbQ (QName n) = lookupSymb n - lookupSymbQ n@Qual{} = lookupSymbInSig n - - -- addSig :: Name -> SigDef -> TypeCheck () - addSigQ n def = traceSig ("addSig: " ++ show n ++ " is bound to " ++ show def) $do - st <- get - put $ st { signature = Map.insert n def $ signature st } - - -- modifySig :: Name -> (SigDef -> SigDef) -> TypeCheck () - modifySigQ n f = do - st <- get - put $ st { signature = Map.adjust f n $ signature st } - - -- setExtrTyp :: Name -> Expr -> TypeCheck () - setExtrTypQ n t = modifySigQ n (\ d -> d { extrTyp = t }) - -lookupSymbInSig :: QName -> TypeCheck SigDef -lookupSymbInSig n = lookupSig n =<< gets signature - where - -- lookupSig :: Name -> Signature -> TypeCheck SigDef - lookupSig n sig = - case (Map.lookup n sig) of - Nothing -> throwErrorMsg $ "identifier " ++ show n ++ " not in signature " ++ show (Map.keys sig) - Just k -> return k - - --- more on the type checking monad ------------------------------- - -initSt :: TCState -initSt = TCState emptySig emptyMetaVars emptyConstraints emptyPosGraph -- emptyDots - -initWithSig :: Signature -> TCState -initWithSig sig = initSt { signature = sig } - --- Meta-variable and constraint handling specification --------------- - -class Monad m => MonadMeta m where - resetConstraints :: m () - mkConstraint :: Val -> Val -> m (Maybe Constraint) - addMeta :: Ren -> MVar -> m () - addLeq :: Val -> Val -> m () - - addLe :: LtLe -> Val -> Val -> m () - addLe Le v1 v2 = addLeq v1 v2 - addLe Lt v1 v2 = addLeq (succSize v1) v2 -- broken for # - - solveConstraints :: m Solution - - -- solve constraints and substitute solution into the analyzed expressions - solveAndModify :: [Expr] -> Env -> m [Expr] - solveAndModify es rho = do - sol <- solveConstraints - let es' = map (subst (solToSubst sol rho)) es - resetConstraints - return es' - --- Constraints implementation ---------------------------------------- - -instance MonadMeta TypeCheck where - - --resetConstraints :: TypeCheck () - resetConstraints = do - st <- get - put $ st { constraints = emptyConstraints } - - -- mkConstraint :: Val -> Val -> TypeCheck (Maybe Constraint) - mkConstraint v (VMax vs) = do - bs <- mapM (errorToBool . leqSize' v) vs - if any id bs then return Nothing else - throwErrorMsg $ "cannot handle constraint " ++ show v ++ " <= " ++ show (VMax vs) - mkConstraint w@(VMax vs) v = throwErrorMsg $ "cannot handle constraint " ++ show w ++ " <= " ++ show v - mkConstraint (VMeta i rho n) (VMeta j rho' m) = retret $ arc (Flex i) (m-n) (Flex j) - mkConstraint (VMeta i rho n) VInfty = retret $ arc (Flex i) 0 (Rigid (RConst Infinite)) - mkConstraint (VMeta i rho n) v = retret $ arc (Flex i) (m-n) (Rigid (RVar j)) - where (j,m) = vGenSuccs v 0 - mkConstraint VInfty (VMeta i rho n) = retret $ arc (Rigid (RConst Infinite)) 0 (Flex i) - mkConstraint v (VMeta j rho m) = retret $ arc (Rigid (RVar i)) (m-n) (Flex j) - where (i,n) = vGenSuccs v 0 - mkConstraint v1 v2 = throwErrorMsg $ "mkConstraint undefined for " ++ show (v1,v2) - - -- addMeta k x adds a metavariable which can refer to VGens < k - -- addMeta :: Ren -> MVar -> TypeCheck () - addMeta ren i = do - scope <- getSizeVarsInScope - traceMetaM ("addMeta " ++ show i ++ " scope " ++ show scope) - st <- get - put $ st { metaVars = Map.insert i (MetaVar scope Nothing) (metaVars st) - , constraints = NewFlex i (\ k' -> True) -- k' < k) - -- DO NOT ADD constraints of form <= infty !! - -- : arc (Flex i) 0 (Rigid (RConst Infinite)) - : constraints st } - - -- addLeq :: Val -> Val -> TypeCheck () - addLeq v1 v2 = traceMeta ("Constraint: " ++ show v1 ++ " <= " ++ show v2) $ - do mc <- mkConstraint v1 v2 - case mc of - Nothing -> return () - Just c -> do - st <- get - put $ st { constraints = c : constraints st } - - -- solveConstraints :: TypeCheck Solution - solveConstraints = do - cs <- gets constraints - if null cs then return emptySolution - else case solve cs of - Just subst -> traceMeta ("solution" ++ show subst) $ - return subst - Nothing -> throwErrorMsg $ "size constraints " ++ show cs ++ " unsolvable" - - -nameOf :: EnvMap -> Int -> Maybe Name -nameOf [] j = Nothing -nameOf ((x,VGen i):rho) j | i == j = Just x -nameOf (_:rho) j = nameOf rho j - -vGenSuccs (VGen k) m = (k,m) -vGenSuccs (VSucc v) m = vGenSuccs v (m+1) -vGenSuccs v m = error $ "vGenSuccs fails on " ++ Util.parens (show v) ++ " " ++ show m - -retret = return . return - -sizeExprToExpr :: Env -> SizeExpr -> Expr -sizeExprToExpr rho (SizeConst Infinite) = Infty -sizeExprToExpr rho (SizeVar i n) | Just x <- nameOf (envMap rho) i = add (Var x) n - where add e n | n <= 0 = e - | otherwise = add (Succ e) (n-1) -sizeExprToExpr rho e@(SizeVar i n) | Nothing <- nameOf (envMap rho) i = error $ "panic: sizeExprToExpr " ++ Util.parens (show e) ++ ": variable v" ++ show i ++ " not in scope " ++ show (envMap rho) - - -maxExpr :: [Expr] -> Expr -maxExpr [] = Infty -maxExpr [e] = e -maxExpr l = if Infty `elem` l then Infty else Max l - -solToSubst :: Solution -> Env -> Subst -solToSubst sol rho = Map.map (maxExpr . map (sizeExprToExpr rho)) sol - - -{- -solToSubst :: Solution -> Env -> Subst -solToSubst sol rho = Map.foldWithKey step Map.empty sol - where step k (SizeVar i n) sub | Just x <- nameOf rho i = - Map.insert k (add (Var x) n) sub - step k (SizeConst Infinite) sub = Map.insert k Infty sub - step _ _ sub = sub - - add e n | n <= 0 = e - | otherwise = add (Succ e) (n-1) --} - --- pattern to Value ---------------------------------------------- - -{- RETIRED -patternToVal :: Pattern -> TypeCheck Val -patternToVal p = do - k <- getLen - return $ fst (p2v k p) - --- turn a pattern into a value --- dot patterns get variables corresponding to their flexible generic value -p2v :: Int -> Pattern -> (Val,Int) -p2v k p = - case p of - VarP n -> (VGen k,k+1) - ConP co n [] -> (VCon co n,k) - ConP co n pl -> let (vl,k') = ps2vs k pl - in (VApp (VCon co n) vl,k') - SuccP p -> let (v,k') = p2v k p - in (VSucc v,k') - DotP e -> (VGen k,k+1) - -ps2vs :: Int -> [Pattern] -> ([Val],Int) -ps2vs k [] = ([],k) -ps2vs k (p:pl) = let (v,k') = p2v k p - (vl,k'') = ps2vs k' pl - in - (v:vl,k'') --} diff --git a/TCM.hs-boot b/TCM.hs-boot deleted file mode 100644 --- a/TCM.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -module TCM where - --- import CallStack -import TraceError - -import Control.Monad.Identity -import Control.Monad.State -import Control.Monad.Except -import Control.Monad.Reader - -data OneOrTwo a = One a | Two a a - -data TCContext -data TCState - --- type TypeCheck = StateT TCState (ReaderT TCContext (CallStackT String IO)) -type TypeCheck = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) diff --git a/Termination.hs b/Termination.hs deleted file mode 100644 --- a/Termination.hs +++ /dev/null @@ -1,896 +0,0 @@ -{-# LANGUAGE ImplicitParams, PatternGuards #-} - -module Termination where - -import Prelude hiding (null) - -import Data.Monoid -import Control.Monad.Writer -- (Writer, runWriter, tell, listen, Any(..), ...) - -import Data.List as List hiding (null) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Foldable (Foldable, foldMap) -import qualified Data.Foldable as Foldable - -import Debug.Trace - ---import System - -import Abstract -import TraceError -import Util - -import Semiring -import qualified SparseMatrix as M - -import TreeShapedOrder (TSO) -import qualified TreeShapedOrder as TSO - -traceTerm msg a = a -- trace msg a -traceTermM msg = return () -- traceM msg -{- -traceTerm msg a = trace msg a -traceTermM msg = traceM msg --} - - -traceProg msg a = a -traceProgM msg = return () -{- -traceProg msg a = trace msg a -traceProgM msg = traceM msg --} - --- cutoff: How far can we count? --- cutoff = 0 : decrease of -infty,0,1 (original SCT) --- cutoff = 1 : " -infty,-1,0,1,2 --- etc. --- this is a parameter to the termination checker - -cutoff :: Int -cutoff = 2 -- we can trace descend of 3, ascend of 2 - - -type Matrix a = M.Matrix Int a - -empty :: Matrix a -empty = M.M (M.Size 0 0) [] - --- greater numbers shall mean more information for the term.checker. -data Order = Decr Int -- positive numbers: decrease, neg. numbers: increase - | Un -- infinite increase (- infty) - | Mat (Matrix Order) -- square matrices only (rows = call arguments, cols = parameters of caller) - deriving (Show,Eq,Ord) - -instance HasZero Order where - zeroElement = Un - --- smart constructor -orderMat :: Matrix Order -> Order -orderMat m | M.isEmpty m = Decr 0 - | Just o <- M.isSingleton m = o - | otherwise = Mat m -{- -orderMat [] = Decr 0 -- 0x0 Matrix = neutral element -orderMat [[o]] = o -- 1x1 Matrix -orderMat oss = Mat oss -- nxn Matrix --} - --- smart constructor -decr :: (?cutoff :: Int) => Int -> Order -decr i | i < - ?cutoff = Un - | i > ?cutoff = Decr (?cutoff + 1) - | otherwise = Decr i - --- present order in terms of <,<=,? -abstract :: Order -> Order -abstract (Decr k) | k > 0 = Decr 1 - | k == 0 = Decr 0 - | k < 0 = Un -abstract Un = Un -abstract (Mat m) = Mat $ absCM m - -absCM :: Matrix Order -> Matrix Order -absCM = fmap abstract --- absCM = map (map abstract) - --- the one is never needed for matrix multiplication -ordRing :: (?cutoff :: Int) => Semiring Order -ordRing = Semiring { add = maxO , mul = comp , zero = Un } -- , one = Decr 0 } - --- composition = sequence of calls -comp :: (?cutoff :: Int) => Order -> Order -> Order -comp _ Un = Un -comp Un _ = Un -comp (Decr k) (Decr l) = decr (k + l) -comp (Mat m1) (Mat m2) = if (composable m1 m2) then - Mat $ M.mul ordRing m1 m2 - else - comp (collapse m1) (collapse m2) -comp (Decr 0) (Mat m) = Mat m -comp (Mat m) (Decr 0) = Mat m -comp o (Mat m) = comp o (collapse m) -comp (Mat m) o = comp (collapse m) o - -maxO :: (?cutoff :: Int) => Order -> Order -> Order -maxO o1 o2 = case (o1,o2) of - (Un,_) -> o2 - (_,Un) -> o1 - (Decr k, Decr l) -> Decr (max k l) -- cutoff not needed - (Mat m1, Mat m2) -> if (sameSize m1 m2) then - Mat $ M.add maxO m1 m2 - else - maxO (collapse m1) (collapse m2) - (Mat m1,_) -> maxO (collapse m1) o2 - (_,Mat m2) -> maxO o1 (collapse m2) - -minO :: (?cutoff :: Int) => Order -> Order -> Order -minO o1 o2 = case (o1,o2) of - (Un,_) -> Un - (_,Un) -> Un - (Decr k, Decr l) -> decr (min k l) - (Mat m1, Mat m2) -> if (sameSize m1 m2) then - Mat $ minM m1 m2 - else - minO (collapse m1) (collapse m2) - (Mat m1,_) -> minO (collapse m1) o2 - (_,Mat m2) -> minO o1 (collapse m2) - -{- --- for non empty lists: -minimumO :: (?cutoff :: Int) => [Order] -> Order -minimumO = foldl1 minO --} - --- | pointwise minimum -minM :: (?cutoff :: Int) => Matrix Order -> Matrix Order -> Matrix Order -minM = M.intersectWith minO -{- -minM m1 m2 = [ minV x y | (x,y) <- zip m1 m2] - where - minV :: Vector Order -> Vector Order -> Vector Order - minV v1 v2 = [ minO x y | (x,y) <- zip v1 v2] --} - -maxL :: (?cutoff :: Int) => [Order] -> Order -maxL = foldl1 maxO - -minL :: (?cutoff :: Int) => [Order] -> Order -minL = foldl1 minO - -{- collapse m - -We assume that m codes a permutation: each row has at most one column -that is not Un. - -To collapse a matrix into a single value, we take the best value of -each column and multiply them. That means if one column is all Un, -i.e., no argument relates to that parameter, than the collapsed value -is also Un. - -This makes order multiplication associative. - - -collapse :: (?cutoff :: Int) => Matrix Order -> Order -collapse m = foldl1 comp (map maxL (M.transpose m)) - --} - - -{- collapse m - -We assume that m codes a permutation: each row has at most one column -that is not Un. - -To collapse a matrix into a single value, we take the best value of -each column and multiply them. That means if one column is all Un, -i.e., no argument relates to that parameter, than the collapsed value -is also Un. - -This makes order multiplication associative. - --} -collapse :: (?cutoff :: Int) => Matrix Order -> Order -collapse m = case M.toLists (M.transpose m) of --- [] -> __IMPOSSIBLE__ -- This can never happen if order matrices are generated by the smart constructor - m' -> foldl1 comp $ map (foldl1 maxO) m' - - - -type Vector a = [a] -type NaiveMatrix a = [Vector a] - ---- --- matrix stuff - -{- -data Semiring a = Semiring { add :: (a -> a -> a) , mul :: (a -> a -> a) , one :: a , zero :: a } --} - -ssum :: Semiring a -> Vector a -> a -ssum sem v = foldl (add sem) (zero sem) v - -vadd :: Semiring a -> Vector a -> Vector a -> Vector a -vadd sem v1 v2 = [ (add sem) x y | (x,y) <- zip v1 v2] - -scalarProdukt :: Semiring a -> Vector a -> Vector a -> a -scalarProdukt sem xs ys = ssum sem [(mul sem) x y | (x,y) <- zip xs ys] - -madd :: Semiring a -> NaiveMatrix a -> NaiveMatrix a -> NaiveMatrix a -madd sem m1 m2 = [ vadd sem x y | (x,y) <- zip m1 m2] - -transp :: NaiveMatrix a -> NaiveMatrix a -transp [] = [] -transp y = [[ z!!j | z<-y] | j<-[0..s]] - where - s = length (head y)-1 - -mmul :: Show a => Semiring a -> NaiveMatrix a -> NaiveMatrix a -> NaiveMatrix a -mmul sem m1 m2 = let m = - [[scalarProdukt sem r c | c <- transp m2] | r<-m1 ] - in m -diag :: NaiveMatrix a -> Vector a -diag [] = [] -diag m = [ (m !! j) !! j | j <- [ 0..s] ] - where - s = length (head m) - 1 - -elems :: NaiveMatrix a -> Vector a -elems m = concat m - -{- -ok :: Matrix a -> Matrix a -> Bool -ok m1 m2 = (length m1) == length m2 --} - -sameSize :: Matrix a -> Matrix a -> Bool -sameSize m1 m2 = M.size m1 == M.size m2 - -composable :: Matrix a -> Matrix a -> Bool -composable m1 m2 = M.rows (M.size m1) == M.cols (M.size m2) - ---- - --- create a call matrix --- each row is for one argument of the callee --- each column for one parameter of the caller -compareArgs :: (?cutoff :: Int) => TSO Name -> [Pattern] -> [Expr] -> Arity -> Matrix Order -compareArgs tso _ [] _ = empty -compareArgs tso [] _ _ = empty -compareArgs tso pl el ar_g = - M.fromLists (M.Size { M.rows = fullArity ar_g , M.cols = length pl }) $ - map (\ e -> map (\ p -> --traceTerm ("comparing " ++ show e ++ " to " ++ show p) $ - compareExpr tso e p) pl) el -{- -compareArgs tso pl el ar_g = - let - diff = ar_g - length el - fill = if diff > 0 then - replicate diff (replicate (length pl) Un) - else [] - cmp = map (\ e -> (map (\ p -> --traceTerm ("comparing " ++ show e ++ " to " ++ show p) $ - compareExpr tso e p) pl)) el - in - cmp ++ fill --} - -{- -compareExpr :: (?cutoff :: Int) => Expr -> Pattern -> Order -compareExpr e p = - case (e,p) of - (_,UnusableP _) -> Un - (_,DotP e') -> case exprToPattern e' of - Nothing -> if e == e' then Decr 0 else Un - Just p' -> compareExpr e p' - (Var i,p) -> traceTerm ("compareVar " ++ show i ++ " " ++ show p) $ compareVar i p - (App (Var i) _,p) -> compareVar i p - (Con _ n1,ConP _ n2 []) | n1 == n2 -> Decr 0 - (App (Con _ n1) [e1],ConP _ n2 [p1]) | n1 == n2 -> compareExpr e1 p1 - (App (Con _ n1) args,ConP _ n2 pl) | n1 == n2 && length args == length pl -> - Mat (map (\ e -> (map (compareExpr e) pl)) args) - -- without extended order : minL $ zipWith compareExpr args pl - (Succ e2,SuccP p2) -> compareExpr e2 p2 - -- new cases for counting constructors - (Succ e2,p) -> Decr (-1) `comp` compareExpr e2 p - (App (Con _ n1) args@(_:_), p) -> Decr (-1) `comp` minL (map (\e -> compareExpr e p) args) - _ -> Un --} - - - -compareExpr :: (?cutoff :: Int) => TSO Name -> Expr -> Pattern -> Order -compareExpr tso e p = - let ret o = traceTerm ("comparing expression " ++ show e ++ " to pattern " ++ show p ++ " returns " ++ show o) o in - ret $ compareExpr' tso e p - -compareExpr' :: (?cutoff :: Int) => TSO Name -> Expr -> Pattern -> Order -compareExpr' tso (Ann e) p = compareExpr' tso (unTag e) p -compareExpr' tso e p = - case (conView $ spineView e, p) of - (_,UnusableP _) -> Un --- (Erased e,_) -> compareExpr' tso e p - (_,ErasedP p) -> compareExpr' tso e p - (_,DotP e') -> case exprToPattern e' of - Nothing -> if e == e' then Decr 0 else Un - Just p' -> compareExpr' tso e p' - ((Var i,_), p) -> -- traceTerm ("compareVar " ++ show i ++ " " ++ show p) $ - compareVar tso i p --- (Con _ n1,ConP _ n2 []) | n1 == n2 -> Decr 0 --- (App (Con _ n1) [e1],ConP _ n2 [p1]) | n1 == n2 -> compareExpr' tso e1 p1 - ((Def (DefId (ConK _) n1),args),ConP _ n2 pl) | n1 == n2 && length args == length pl -> - let os = zipWith (compareExpr' tso) args pl - in trace ("compareExpr (con/con case): os = " ++ show os) $ - if null os then Decr 0 else minL os -{- 2011-12-16 deactivate structured (matrix) orders - orderMat $ - M.fromLists (M.Size { M.rows = length args, M.cols = length pl }) $ - map (\ e -> map (compareExpr' tso e) pl) args - -- without extended order : minL $ zipWith compareExpr' tso args pl --} - ((Succ e2,_),SuccP p2) -> compareExpr' tso e2 p2 - -- new cases for counting constructors - ((Succ e2,_),p) -> Decr (-1) `comp` compareExpr' tso e2 p - ((Def (DefId (ConK Cons) n1),args@(_:_)), p) -> Decr (-1) `comp` minL (map (\e -> compareExpr' tso e p) args) - ((Proj Post n1,[]), ProjP n2) | n1 == n2 -> Decr 0 - _ -> Un - -conView (Record (NamedRec co n _ _) rs, es) = (Def (DefId (ConK co) n), map snd rs ++ es) -conView p = p - -compareVar :: (?cutoff :: Int) => TSO Name -> Name -> Pattern -> Order -compareVar tso n p = - let ret o = o in -- traceTerm ("comparing variable " ++ n ++ " to " ++ show p ++ " returns " ++ show o) o in - case p of - UnusableP _ -> ret Un - ErasedP p -> compareVar tso n p - VarP n2 -> if n == n2 then Decr 0 else - case TSO.diff n n2 tso of -- if n2 is the k-th father of n, then it is a decrease by k - Nothing -> ret Un - Just k -> ret $ decr k - SizeP n1 n2 -> if n == n2 then Decr 0 else - case TSO.diff n n2 tso of -- if n2 is the k-th father of n, then it is a decrease by k - Nothing -> ret Un - Just k -> ret $ decr k - PairP p1 p2 -> maxL (map (compareVar tso n) [p1,p2]) - -- no decrease in pair: ALT: comp (Decr 1) (...) - ConP pi c (p:pl) | coPat pi == Cons -> - comp (Decr 1) (maxL (map (compareVar tso n) (p:pl))) - ConP{} -> ret Un - ProjP{} -> ret Un - SuccP p2 -> comp (Decr 1) (compareVar tso n p2) - DotP e -> case (exprToPattern e) of - Nothing -> ret $ Un - Just p' -> compareVar tso n p' - _ -> error $ "NYI: compareVar " ++ show n ++ " to " ++ show p -- ret $ Un - ---- - -type Index = Name - -data Call = Call { source :: Index , target :: Index , matrix :: CallMatrix } - deriving (Eq,Show,Ord) - --- call matrix: --- each row is for one argument of the callee (target) --- each column for one parameter of the caller (source) - -type CallMatrix = Matrix Order - --- for two matrices m m' of the same dimensions, --- m `subsumes` m' if pointwise the entries of m are smaller than of m' -subsumes :: Matrix Order -> Matrix Order -> Bool -subsumes m m' = M.all (uncurry leq) mm' - where mm' = M.zip m m' -- create one matrix of pairs -{- -subsumes m m' = all (all (uncurry leq)) mm' - where mm' = zipWith zip m m' -- create one matrix of pairs --} - --- Order forms itself a partial order -leq :: Order -> Order -> Bool -leq Un _ = True -leq (Decr k) (Decr l) = k <= l -leq (Mat m) (Mat m') = subsumes m m' -leq _ _ = False - --- for two matrices m m' such that m `subsumes` m' --- m `progress` m' any positive entry in m' is smaller in m -progress :: Matrix Order -> Matrix Order -> Bool -progress m m' = M.any (uncurry decrToward0) mm' - where mm' = M.zip m m' -- create one matrix of pairs -{- -progress m m' = any (any (uncurry decrToward0)) mm' - where mm' = zipWith zip m m' -- create one matrix of pairs --} - -decrToward0 :: Order -> Order -> Bool -decrToward0 Un (Decr l) = True && l >= 0 -decrToward0 (Decr k) (Decr l) = k < l && l >= 0 -decrToward0 (Mat m) (Mat m') = progress m m' -decrToward0 _ _ = False - - -{- call pathes - - are lists of names of length >=2 - - [f,g,h] = f --> g --> h --} - -newtype CallPath = CallPath { getCallPath :: [Name] } deriving Eq - -instance Show CallPath where - show (CallPath [g]) = show g - show (CallPath (f:l)) = show f ++ "-->" ++ show (CallPath l) - -emptyCP :: CallPath -emptyCP = CallPath [] - -mkCP :: Name -> Name -> CallPath -mkCP src tgt = CallPath [src, tgt] - -mulCP :: CallPath -> CallPath -> CallPath -mulCP cp1@(CallPath one) cp2@(CallPath (g:two)) = - if last one == g then CallPath (one ++ two) - else error ("internal error: Termination.mulCP: trying to compose callpath " ++ show cp1 ++ " with " ++ show cp2) - -compatibleCP :: CallPath -> CallPath -> Bool -compatibleCP (CallPath one) (CallPath two) = head one == head two && last one == last two - -{- -addCP :: CallPath -> CallPath -> CallPath -addCP (CallPath []) cp = cp -addCP cp (CallPath []) = cp -addCP cp1 cp2 = if cp1 == cp2 then cp1 else error ("internal error: Termination.addCP: trying to blend non-equal callpathes " ++ show cp1 ++ " and " ++ show cp2) - -cpRing :: Semiring CallPath -cpRing = Semiring { add = addCP , mul = mulCP , one = undefined , zero = emptyCP } --} - --- composed calls - -type CompCall = (CallPath, CallMatrix) - -mulCC :: (?cutoff :: Int) => CompCall -> CompCall -> CompCall -mulCC cc1@(cp1, m1) cc2@(cp2, m2) = zipPair mulCP (flip (M.mul ordRing)) cc1 cc2 - -subsumesCC :: CompCall -> CompCall -> Bool -subsumesCC cc1@(cp1, m1) cc2@(cp2, m2) = - if compatibleCP cp1 cp2 then m1 `subsumes` m2 - else error ("internal error: Termination.subsumesCC: trying to compare composed call " ++ show cc2 ++ " with " ++ show cc1) - -progressCC :: CompCall -> CompCall -> Bool -progressCC cc1@(cp1, m1) cc2@(cp2, m2) = progress m1 m2 - - -{- call graph completion - -organize call graph as a square matrix - - Name * Name -> Set CallMatrix - -the completion process finds new calls by composing old calls. -There are two qualities of new calls. - - 1) a completely new call or a call matrix in which one cell - progressed from (Decr k | k > 0) towards -infty, i.e. a positive - entry got smaller - - 2) a negative entry got smaller - -As long as 1-calls are found, continue completion. -[ I think 2-calls can be ignored when deciding whether to cont. ] - - -} - --- sets of call matrices - -type CMSet = [CompCall] -- normal form: no CM subsumes another - -cmRing :: (?cutoff :: Int) => Semiring CMSet -cmRing = Semiring { add = unionCMSet , mul = mulCMSet , zero = [] } -- one = undefined , - -type Progress = Writer Any -type ProgressH = Writer (Any, Any) - -firstHalf = (Any True, Any False) -secondHalf = (Any False, Any True) - --- fullProgress = Sum 2 --- halfProgress = Sum 1 - --- we keep CMSets always in normal form --- progress reported if m is "better" than one of ms --- progress can only be reported if m is being added, i.e., not subsumed -addCMh :: CompCall -> CMSet -> ProgressH CMSet -addCMh m [] = traceProg ("adding new call " ++ show m) $ do - tell firstHalf - return $ [m] -addCMh m (m':ms) = - if m' `subsumesCC` m then traceTerm ("discarding new call " ++ show m) $ - return $ m':ms -- terminate early - else do (ms', (Any h1, Any h2)) <- listen $ addCMh m ms - when (h1 && not h2 && m `progressCC` m') $ do - traceProgM ("progress made by " ++ show m ++ " over " ++ show m') - tell secondHalf -- $ Any True - if m `subsumesCC` m' then traceTerm ("discarding old call " ++ show m') $ - return ms' - else return $ m' : ms' - -addCM' :: CompCall -> CMSet -> Progress CMSet -addCM' m ms = mapWriter (\(ms, (Any h1, Any h2)) -> (ms, Any $ h1 && h2)) (addCMh m ms) - --- progress is reported if one of ms is "better" than ms' --- or if the oldset was empty and is no longer --- unionCMSet' addition oldset -unionCMSet' :: CMSet -> CMSet -> Progress CMSet -unionCMSet' [] [] = return [] -unionCMSet' ms [] = tell (Any True) >> return ms -unionCMSet' ms ms' = foldM (flip addCM') ms' ms - --- non-monadic versions -addCM :: CompCall -> CMSet -> CMSet -addCM m ms = fst $ runWriter (addCM' m ms) - -unionCMSet :: CMSet -> CMSet -> CMSet -unionCMSet ms ms' = fst $ runWriter (unionCMSet' ms ms') - -mulCMSet :: (?cutoff :: Int) => CMSet -> CMSet -> CMSet -mulCMSet ms ms' = foldl (flip addCM) [] $ [ mulCC m m' | m <- ms, m' <- ms' ] - -{- call graph entries - -type CGEntry = (CallPath, CMSet) - -cgeRing :: Semiring CGEntry -cgeRing = Semiring { add = zipPair addCP unionCMSet, - mul = zipPair mulCP mulCMSet, - one = undefined, - zero = (emptyCP, []) } - -addCGEntry' :: CGEntry -> CGEntry -> Progress CGEntry -addCGEntry' (cp1, ms1) (cp2, ms2) = do - let cp = addCP cp1 cp2 - traceTermM ("call") - ms <- unionCMSet' ms1 ms2 - return $ (cp, ms) --} - --- call graphs - -type CallGraph = NaiveMatrix CMSet -- CGEntry - -stepCG :: (?cutoff :: Int) => CallGraph -> Progress CallGraph -stepCG cg = do - traceProgM ("next iteration") - traceProgM ("old cg " ++ show cg) - traceProgM ("composed calls " ++ show cg') - traceProgM ("adding new calls to callgraph...") - zipWithM (zipWithM unionCMSet') cg' cg - where cg' = mmul cmRing cg cg - -{- "each idempotent call f->f has a decreasing arg" is an invariant - of good call graphs. Thus, we can stop call graph completion - as soon as we see it violated. - - "idempotent" is defined on abstracted call matrices, i.e., - those that only have <, <=, ? and are not counting. - -} -complCGraph :: (?cutoff :: Int) => CallGraph -> CallGraph -complCGraph cg = - let (cg', Any prog) = runWriter $ stepCG cg - in if prog && checkAll cg' then complCGraph cg' else cg' - -checkAll :: (?cutoff :: Int) => CallGraph -> Bool -checkAll cg = all (all (checkIdem . snd)) $ diag cg - --- each idempotent call needs a decreasing diagonal entry -checkIdem :: (?cutoff :: Int) => CallMatrix -> Bool -checkIdem cm = - let cm' = M.mul ordRing cm cm - eqAbs = (absCM cm) == (absCM cm') - d = M.diagonal cm - in traceTerm ("checkIdem: cm = " ++ show cm ++ " cm' = " ++ show cm ++ " eqAbs = " ++ show eqAbs ++ " d = " ++ show d) $ - -- if cm `subsumes` cm' - if eqAbs - then any isDecr d else True - -{- generate a call graph from a list of names and list of calls -1. group calls by source, obtaining a list of row --} - -{- THIS IS WRONG: -makeCG :: [Name] -> [Call] -> CallGraph -makeCG names calls = map (\ tgt -> mkRow tgt [ c | c <- calls, target c == tgt ]) names - where mkRow tgt calls = map (\ src -> unionCMSet [ (mkCP src tgt, matrix c) | c <- calls, source c == src ] []) names --} - -makeCG :: [Name] -> [Call] -> CallGraph -makeCG names calls = map (\ src -> mkRow src [ c | c <- calls, source c == src ]) names - where mkRow src calls = map (\ tgt -> unionCMSet [ (mkCP src tgt, matrix c) | c <- calls, target c == tgt ] []) names - -{- -callComb :: Call -> Call -> Call -callComb (Call s1 t1 m1) (Call s2 t2 m2) = Call s2 t1 (mmul ordRing m1 m2) - -cgComb :: [Call] -> [Call] -> [Call] -cgComb cg1 cg2 = [ callComb c1 c2 | c1 <- cg1 , c2 <- cg2 , (source c1 == target c2)] - -complete :: [Call] -> [Call] -complete cg = traceTerm ("call graph: " ++ show cg) $ - let cg' = complete' cg -- $ Set.fromList cg - in -- traceTerm ("complete " ++ show cg') - cg' -- Set.toList cg' - -complete' :: [Call] -> [Call] -- Set Call -> Set Call -complete' cg = - let cgs = Set.fromList cg - cgs' = Set.union cgs (Set.fromList $ cgComb cg cg ) - cg' = Set.toList cgs' - in - if (cgs == cgs') then cg else complete' cg' - -checkAll :: [Call] -> Bool -checkAll x = all checkIdem x - --- each idempotent call needs a decreasing diagonal entry -checkIdem :: Call -> Bool -checkIdem c = let cc = callComb c c - d = diag (matrix cc) - containsDecr = any isDecr d - in (not (c == cc)) || containsDecr --} -isDecr :: Order -> Bool -isDecr o = case o of - (Decr k) -> k > 0 - (Mat m) -> any isDecr (M.diagonal m) - _ -> False - - -------------------- - --- top level function -terminationCheck :: MonadAssert m => [Fun] -> m () -terminationCheck funs = do - let ?cutoff = cutoff - traceTermM $ "terminationCheck " ++ show funs - let tl = terminationCheckFuns funs - let nl = map fst tl - let bl = map snd tl - let nl2 = [ n | (n,b) <- tl , b == False ] - case (and bl) of - True -> return () - False -> case nl of - [f] -> recoverFail ("Termination check for function " ++ show f ++ " fails ") - _ -> recoverFail ("Termination check for mutual block " ++ show nl ++ " fails for " ++ show nl2) - - -terminationCheckFuns :: (?cutoff :: Int) => [Fun] -> [(Name,Bool)] -terminationCheckFuns funs = - let namar = map (\ (Fun (TypeSig n _) _ ar _) -> (n, ar)) funs - -- collectNames funs - names = map fst namar - cg0 = collectCGFunDecl namar funs - in sizeChangeTermination names cg0 - -sizeChangeTermination :: (?cutoff :: Int) => [Name] -> [Call] -> [(Name,Bool)] -sizeChangeTermination names cg0 = - let cg1 = makeCG names cg0 - cg = complCGraph $ cg1 - beh = zip names $ map (all (checkIdem . snd)) $ diag cg - in traceTerm ("collected names: " ++ show names) $ - traceTerm ("call graph: " ++ show cg0) $ - traceTerm ("normalized call graph: " ++ show cg1) $ - traceTerm ("completed call graph: " ++ show cg) $ - traceTerm ("recursion behaviours" ++ show beh) $ - beh - - -{- -terminationCheckFuns :: [ (TypeSig,[Clause]) ] -> [(Name,Bool)] -terminationCheckFuns funs = - let beh = recBehaviours funs - in - traceTerm ("recursion behaviours" ++ show beh) $ - zip (map fst beh) (map (checkAll . snd ) beh ) - --- This is the main driver. -recBehaviours :: [ (TypeSig,[Clause]) ] -> [(Name,[Call])] -recBehaviours funs = let names = map fst $ collectNames funs - cg0 = collectCGFunDecl funs - cg = complete cg0 - in traceTerm ("collected names: " ++ show names) $ - traceTerm ("call graph: " ++ show cg0) $ - groupCalls names [ c | c <- cg , (target c == source c) ] - - -groupCalls :: [Name] -> [Call] -> [(Name,[Call])] -groupCalls [] _ = [] -groupCalls (n:nl) cl = (n, [ c | c <- cl , (source c == n) ]) : groupCalls nl cl --} - -{- -ccFunDecl :: [ ( TypeSig,[Clause]) ] -> [Call] -ccFunDecl funs = complete $ collectCGFunDecl funs --} - -collectCGFunDecl :: (?cutoff :: Int) => [(Name,Arity)] -> [Fun] -> [Call] -collectCGFunDecl names funs = - concatMap (collectClauses names) funs - where - collectClauses :: [(Name,Arity)] -> Fun -> [Call] - collectClauses names (Fun (TypeSig n _) _ ar cll) = collectClause names n cll - collectClause :: [(Name,Arity)] -> Name -> [Clause] -> [Call] - collectClause names n ((Clause _ pl Nothing):rest) = collectClause names n rest - collectClause names n ((Clause _ pl (Just rhs)):rest) = - traceTerm ("collecting calls in " ++ show rhs) $ - (collectCallsExpr names n pl rhs) ++ (collectClause names n rest) - collectClause names n [] = [] - -{- RETIRED -arity :: [Clause] -> Int -arity [] = 0 -arity (Clause pl e:l) = length pl --} - -{- RETIRED (map) -collectNames :: [Fun] -> [(Name,Arity)] -collectNames [] = [] -collectNames (Fun (TypeSig n _) ar cls : rest) = (n,ar) : (collectNames rest) --} - --- | harvest i > j from case i { $ j -> ...} -tsoCase :: TSO Name -> Expr -> [Clause] -> TSO Name -tsoCase tso (Var x) [Clause _ [SuccP (VarP y)] _] = TSO.insert y (1,x) tso -tsoCase tso _ _ = tso - --- | harvest i < j from (i < j) -> ... or (i < j) & ... -tsoBind :: TSO Name -> TBind -> TSO Name -tsoBind tso (TBind x (Domain (Below ltle (Var y)) _ _)) = TSO.insert x (n ltle,y) tso - where n Lt = 1 - n Le = 0 -tsoBind tso _ = tso - -collectCallsExpr :: (?cutoff :: Int) => [(Name,Arity)] -> Name -> [Pattern] -> Expr -> [Call] -collectCallsExpr nl f pl e = traceTerm ("collectCallsExpr " ++ show e) $ - loop tso e where - tso = tsoFromPatterns pl - loop tso (Ann e) = loop tso (unTag e) - loop tso e = headcalls ++ argcalls where - (hd, args) = spineView e -- $ ignoreTopErasure e - argcalls = concatMap (loop tso) args - headcalls = case hd of - (Def (DefId FunK (QName g))) -> - case lookup g nl of - Nothing -> [] - Just ar_g -> - traceTerm ("found call from " ++ show f ++ " to " ++ show g) $ - let (Just ar_f) = lookup f nl - (Just f') = List.elemIndex (f,ar_f) nl - (Just g') = List.elemIndex (g,ar_g) nl - m = compareArgs tso pl args ar_g - cg = Call { source = f - , target = g - , matrix = m } - in - traceTerm ("found call " ++ show cg) $ - [cg] - (Case e _ cls) -> loop tso e ++ concatMap (loop (tsoCase tso e cls)) (map (maybe Irr id . clExpr) cls) - (Lam _ _ e1) -> loop tso e1 - (LLet tb tel e1 e2) | null tel-> - (loop tso e1) ++ -- type won't get evaluated - (loop tso e2) - (Quant _ tb@(TBind x dom) e2) -> (loop tso (typ dom)) ++ (loop (tsoBind tso tb) e2) - (Quant _ (TMeasure mu) e2) -> Foldable.foldMap (loop tso) mu ++ (loop tso e2) - (Quant _ (TBound beta) e2) -> Foldable.foldMap (loop tso) beta ++ (loop tso e2) - (Below ltle e) -> loop tso e - (Sing e1 e2) -> (loop tso e1) ++ (loop tso e2) - (Pair e1 e2) -> (loop tso e1) ++ (loop tso e2) - (Succ e) -> loop tso e - (Max es) -> concatMap (loop tso) es - (Plus es) -> concatMap (loop tso) es - Sort (SortC{}) -> [] - Sort (Set e) -> loop tso e - Sort (CoSet e) -> loop tso e - Var{} -> [] - Zero{} -> [] - Infty{} -> [] - Def{} -> [] - Irr{} -> [] - Proj{} -> [] - Record ri rs -> Foldable.foldMap (loop tso . snd) rs - Ann e1 -> loop tso (unTag e1) --- Con{} -> [] --- Let{} -> [] - Meta{} -> error $ "collect calls in unresolved meta variable " ++ show e - _ -> error $ "NYI: collect calls in " ++ show e - -{- -collectCallsExpr :: (?cutoff :: Int) => [(Name,Int)] -> Name -> [Pattern] -> Expr -> [Call] -collectCallsExpr nl f pl e = - traceTerm ("collectCallsExpr " ++ show e) $ - case e of - (App (Def g) args) -> - let calls = concatMap (collectCallsExpr nl f pl) args - gIn = lookup g nl - in - traceTerm ("found call from " ++ f ++ " to " ++ g) $ - case gIn of - Nothing -> calls - Just ar_g -> let (Just ar_f) = lookup f nl - (Just f') = List.elemIndex (f,ar_f) nl - (Just g') = List.elemIndex (g,ar_g) nl - m = compareArgs pl args ar_g - cg = Call { source = f - , target = g - , matrix = m } - in - traceTerm ("found call " ++ show cg) $ - cg:calls - (Def g) -> collectCallsExpr nl f pl (App (Def g) []) - (App e args) -> concatMap (collectCallsExpr nl f pl) (e:args) - (Case e cls) -> concatMap (collectCallsExpr nl f pl) (e:map clExpr cls) - (Lam _ _ e1) -> collectCallsExpr nl f pl e1 - (LLet _ e1 t1 e2) -> (collectCallsExpr nl f pl e1) ++ -- type won't get evaluated - (collectCallsExpr nl f pl e2) - (Pi _ _ e1 e2) -> (collectCallsExpr nl f pl e1) ++ - (collectCallsExpr nl f pl e2) - (Sing e1 e2) -> (collectCallsExpr nl f pl e1) ++ - (collectCallsExpr nl f pl e2) - (Succ e1) -> collectCallsExpr nl f pl e1 - Sort{} -> [] - Var{} -> [] - Infty{} -> [] - Con{} -> [] - Let{} -> [] - Meta{} -> error $ "collect calls in unresolved meta variable " ++ show e - _ -> error $ "NYI: collect calls in " ++ show e --} - ----------------------------------------------------------------------- -{- Foetus II - Counting Lexicographic Termination (delta-Foetus) - -delta-SCT [Ben-Amram 2006] is too inefficient, at least with the bound -given in the paper. - - B(G) = (k + 1)2^k · m^2 · 2^(2k+1) (m∆)^(3k+1) (k + 1)^(3k^2+3k+1) - -is an upper bound on the length of the longest path to be looked at to -exclude non-termination. - -I guess that both argument permutation and counting is not very -common. So an approach would be - -- try to show termination with SCT -- try to show termination with delta-Foetus - -Call graph completion in delta-Foetus - -1. Iterate as long new simple cycles show up (i.e. cycles with no subcycles) - -2. Find the possible lexicographic termination orders to for each function - -3. Continue iterating while any of the arguments involved in any of the termination orders gets worse. Some termination order hypotheses might collapse. - -4. Stop when all hypotheses have collapsed (FAIL) or when no standing hypotheses gets any worse (SUCCESS). - -Implementation: - -After 1. save for each function and each of its arguments the worst -recursive behavior in any of the calls. This map will be used to -monitor progress. - - -Careful: - - f x = f (x-1) | g (x - 100) - g x = g (x+1) | f (x - 100) - -Bad call f->f only found after 201 iterations of g! - -Idea: regular expressions over call matrices! - - (m1 + m2^*)^* - --} diff --git a/ToHaskell.hs b/ToHaskell.hs deleted file mode 100644 --- a/ToHaskell.hs +++ /dev/null @@ -1,292 +0,0 @@ -module ToHaskell where - -{- type-directed extraction of Haskell programs with a lot of unsafeCoerce - -Examples: ---------- - -MiniAgda - - data Vec (A : Set) : Nat -> Set - { vnil : Vec A zero - ; vcons : [n : Nat] -> (head : A) -> (tail : Vec A n) -> Vec A (suc n) - } - - fun length : [A : Set] -> [n : Nat] -> Vec A n -> - { length .A .zero (vnil A) = zero - ; length .A .(suc n) (vcons A n a as) = suc (length A n as) - } - -Haskell - - {-# LANGUAGE NoImplicitPrelude #-} - module Main where - import qualified Text.Show as Show - - data Vec (a :: *) - = Vec_vnil - | Vec_vcons { vec_head :: a , vec_tail :: Vec a } - deriving Show.Show - - length :: forall a. Vec a -> Nat - length Vec_vnil = Nat_zero - length (Vec_vcons a as) = Nat_suc (length as) - -Components: ------------ - -Translation from MiniAgda identifiers to Haskell identifiers - --} - -import Prelude hiding (null) - -import Data.Char - -import Control.Applicative -import Control.Monad -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State - -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Traversable as Trav - -import qualified Language.Haskell.Exts.Syntax as H -import Text.PrettyPrint - -import Polarity -import Abstract -import Extract -import qualified HsSyntax as H -import TraceError -import Util - --- translation monad - -type Translate = StateT TState (ReaderT TContext (ExceptT TraceError IO)) - -{- no longer needed with mtl-2 -instance Applicative Translate where - pure = return - mf <*> ma = do { f <- mf; a <- ma; return (f a) } --} - -data TState = TState - -initSt :: TState -initSt = TState - -data TContext = TContext - -initCxt :: TContext -initCxt = TContext - -runTranslate :: Translate a -> IO (Either TraceError a) -runTranslate t = runExceptT (runReaderT (evalStateT t initSt) initCxt) - --- translation - -translateModule :: [EDeclaration] -> Translate (H.Module) -translateModule ds = do - hs <- translateDecls ds - return $ H.mkModule hs - -translateDecls :: [EDeclaration] -> Translate [H.Decl] -translateDecls ds = concat <$> mapM translateDecl ds - -translateDecl :: EDeclaration -> Translate [H.Decl] -translateDecl d = - case d of - MutualDecl _ ds -> translateDecls ds - OverrideDecl{} -> throwErrorMsg $ "translateDecls internal error: overrides impossible" - MutualFunDecl _ _ funs -> translateFuns funs - FunDecl _ fun -> translateFun fun - LetDecl _ x tel (Just t) e | null tel -> translateLet x t e - DataDecl n _ _ _ tel fkind cs _ -> translateDataDecl n tel fkind cs - -translateFuns :: [Fun] -> Translate [H.Decl] -translateFuns funs = concat <$> mapM translateFun funs - -translateFun :: Fun -> Translate [H.Decl] -translateFun (Fun ts@(TypeSig n t) n' ar cls) = do - ts@(H.TypeSig _ [n] t) <- translateTypeSig ts - cls <- concat <$> mapM (translateClause n) cls - return [ts, H.FunBind cls] - -translateLet :: Name -> Type -> FExpr -> Translate [H.Decl] -translateLet n t e - | isEtaAlias n = return [] -- skip internal decls - | otherwise = do - ts <- translateTypeSig $ TypeSig n t - e <- translateExpr e - n <- hsName (DefId LetK $ QName n) - return [ ts, H.mkLet n e ] - -translateTypeSig :: TypeSig -> Translate H.Decl -translateTypeSig (TypeSig n t) = do - n <- hsName (DefId LetK $ QName n) - t <- translateType t - return $ H.mkTypeSig n t - -translateDataDecl :: Name -> FTelescope -> FKind -> [FConstructor] -> Translate [H.Decl] -translateDataDecl n tel k cs = do - n <- hsName (DefId DatK $ QName n) - tel <- translateTelescope tel - let k' = translateKind k - cs <- mapM translateConstructor cs - return [H.mkDataDecl n tel k' cs] - -translateConstructor :: FConstructor -> Translate H.GadtDecl -translateConstructor (Constructor n pars t) = do - n <- hsName (DefId (ConK Cons) n) - t' <- translateType t - return $ H.mkConDecl n t' - -translateClause :: H.Name -> Clause -> Translate [H.Match] -translateClause n (Clause _ ps (Just rhs)) = do - ps <- mapM translatePattern ps - rhs <- translateExpr rhs - return [H.mkClause n ps rhs] - -translateTelescope :: FTelescope -> Translate [H.TyVarBind] -translateTelescope (Telescope tel) = mapM translateTBind tel' - -- throw away erasure marks - where tel' = filter (\ tb -> not $ erased $ decor $ boundDom tb) tel - -translateTBind :: TBind -> Translate H.TyVarBind -translateTBind (TBind x dom) = do - x <- hsVarName x - return $ H.KindedVar x $ translateKind (typ dom) - -translateKind :: FKind -> H.Kind -translateKind k = - case k of - k | k == star -> H.KindStar - Quant Pi (TBind _ dom) k' | erased (decor dom) -> translateKind k' - Quant Pi (TBind _ dom) k' -> - translateKind (typ dom) `H.mkKindFun` translateKind k' - -translateType :: FType -> Translate H.Type -translateType t = - case t of - - Irr -> return $ H.unit_tycon - - Quant piSig (TBind _ dom) b | not (erased (decor dom)) -> - H.mkTyPiSig piSig <$> translateType (typ dom) <*> translateType b - - Quant Pi (TBind _ dom) b | typ dom == Irr -> translateType b - - Quant Pi (TBind x dom) b -> do - x <- hsVarName x - let k = translateKind (typ dom) - -- todo: add x to context - t <- translateType b - return $ H.mkForall x k t - - App f a -> H.mkTyApp <$> translateType f <*> translateType a - - Def d@(DefId DatK n) -> (H.TyCon . H.UnQual) <$> hsName d - - Var x -> H.TyVar <$> hsVarName x - - _ -> return H.unit_tycon - -{- TODO: - _ -> throwErrorMsg $ "no Haskell representation for type " ++ show t - -} - -translateExpr :: FExpr -> Translate H.Exp -translateExpr e = - case e of - - Var x -> H.mkVar <$> hsVarName x - - -- constructors - Def f@(DefId (ConK{}) n) -> H.mkCon <$> hsName f - - -- function identifiers - Def f@(DefId _ n) -> H.mkVar <$> hsName f - - -- discard type arguments - App f e0 -> do - f <- translateExpr f - let (er, e) = isErasedExpr e0 - if er then return f else H.mkApp f <$> translateExpr e - - -- discard type lambdas - Lam dec y e -> do - y <- hsVarName y - e <- translateExpr e - return $ if erased dec then e else H.mkLam y e - - LLet (TBind x dom) tel e1 e2 | null tel-> do - x <- hsVarName x - e2 <- translateExpr e2 - if erased (decor dom) then return e2 else do - t <- Trav.mapM translateType (typ dom) - e1 <- translateExpr e1 - return $ H.mkLLet x t e1 e2 - - Pair e1 e2 -> H.mkPair <$> translateExpr e1 <*> translateExpr e2 - - -- TODO - - Ann (Tagged [Cast] e) -> H.mkCast <$> translateExpr e - - _ -> return $ H.unit_con - -translatePattern :: Pattern -> Translate H.Pat -translatePattern p = - case p of - VarP y -> H.PVar <$> hsVarName y - PairP p1 p2 -> H.PTuple H.Boxed <$> mapM translatePattern [p1,p2] - ConP pi n ps -> - H.PApp <$> (H.UnQual <$> hsName (DefId (ConK $ coPat pi) n)) - <*> mapM translatePattern ps - -{- -Name translation - - data names : check capitalization, identity translation - constructor names : prefix with Dataname_ - destructor names : ditto - type-valued lets : check capitalization, identity - type-valued funs : reject! - lets : check lowercase - funs/cofuns : check lowercase --} - -hsVarName :: Name -> Translate H.Name -hsVarName x = return $ H.Ident $ show x - -hsName :: DefId -> Translate H.Name -hsName id = enter ("error translating identifier " ++ show id) $ - case id of - (DefId DatK (QName x)) -> do - let n = suggestion x - unless (isUpper $ head n) $ - throwErrorMsg $ "data names need to be capitalized" - return $ H.Ident n - (DefId (ConK co) (Qual d x)) -> do - let n = suggestion x - m = suggestion d - return $ H.Ident $ m ++ "_" ++ n - -- dataName <- getDataName x - -- return $ H.Ident $ dataName ++ "_" ++ n - -- lets, funs, cofuns. TODO: type-valued funs! --- (DefId Let ('_':n)) | -> return $ H.Ident n - (DefId _ x) -> do - let n = suggestion $ unqual x -{- ignore for now - unless (isLower $ head n) $ - throwErrorMsg $ "function names need to start with a lowercase letter" - -} - return $ H.Ident n - --- getDataName constructorName = return dataNamec -getDataName :: Name -> Translate String -getDataName n = return "DATA" diff --git a/Tokens.hs b/Tokens.hs deleted file mode 100644 --- a/Tokens.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Tokens where - -data Token - = Id String - | Data - | Fun - | Def - | Mutual - | Pattern - | Set - | Case - -- size type - | Size - | Infty - | Succ - -- - | BrOpen - | BrClose - | PrOpen - | PrClose - | Sem - | Col - | Arrow - | Eq - | Lam - | UScore - | NotUsed -- so happy doesn't generate overlap case pattern warning - deriving (Eq,Ord,Show) - diff --git a/TraceError.hs b/TraceError.hs deleted file mode 100644 --- a/TraceError.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} - -module TraceError where - -import Control.Monad.Except -import Debug.Trace - -import Util -import Text.PrettyPrint - -data TraceError = Err String | TrErr String TraceError - --- instance Error TraceError where --- noMsg = Err "no message" --- strMsg s = Err s - -instance Show TraceError where - show (Err str) = str - show (TrErr str err) = str ++ "\n/// " ++ show err - -throwErrorMsg m = throwError (Err m) - --- newErrorMsg :: (MonadError TraceError m) => m a -> String -> m a -newErrorMsg c s = c `catchError` (\ _ -> throwErrorMsg s) --- addErrorMsg c s = c `catchError` (\ s' -> throwErrorMsg (s' ++ "\n" ++ s)) - --- extend the current error message by n -throwTrace x n = x `catchError` ( \e -> throwError $ TrErr n e) -enter n x = throwTrace x n -enterTrace n x = trace n $ throwTrace x n -enterShow n = enter (show n) - -enterDoc :: (MonadError TraceError m, Pretty d) => m d -> m a -> m a -enterDoc md cont = do - d <- md - enter (render (pretty d)) cont - -failDoc :: (MonadError TraceError m) => m Doc -> m a -failDoc d = throwErrorMsg . render =<< d - -newErrorDoc :: (MonadError TraceError m) => m a -> m Doc -> m a -newErrorDoc c d = c `catchError` (\ _ -> failDoc d) - -errorToMaybe :: (MonadError e m) => m a -> m (Maybe a) -errorToMaybe m = (m >>= return . Just) `catchError` (const $ return Nothing) - -errorToBool :: (MonadError e m) => m () -> m Bool -errorToBool m = (m >> return True) `catchError` (\ _ -> return False) - -boolToErrorDoc :: (MonadError TraceError m) => m Doc -> Bool -> m () -boolToErrorDoc d True = return () -boolToErrorDoc d False = failDoc d - -boolToError :: (MonadError TraceError m) => String -> Bool -> m () -boolToError msg True = return () -boolToError msg False = throwErrorMsg msg - -instance MonadError () Maybe where - catchError Nothing k = k () - catchError (Just a) k = Just a - throwError () = Nothing - -orM :: (MonadError e m) => m a -> m a -> m a -orM m1 m2 = m1 `catchError` (const m2) - --- recoverable errors - -data AssertionHandling = Failure | Warning | Ignore - deriving (Eq,Ord,Show) - -assert' :: (MonadError TraceError m, MonadIO m) => AssertionHandling -> Bool -> String -> m () -assert' Ignore b s = return () -assert' h True s = return () -assert' Warning False s = liftIO $ putStrLn $ "warning: ignoring error: " ++ s -assert' Failure False s = throwErrorMsg s - -assertDoc' :: (MonadError TraceError m, MonadIO m) => AssertionHandling -> Bool -> m Doc -> m () -assertDoc' h b md = assert' h b . render =<< md - -class Monad m => MonadAssert m where - assert :: Bool -> String -> m () - assertDoc :: Bool -> m Doc -> m () - assertDoc b md = assert b . render =<< md - newAssertionHandling :: AssertionHandling -> m a -> m a - recoverFail :: String -> m () - recoverFail = assert False - recoverFailDoc :: m Doc -> m () - recoverFailDoc = assertDoc False - -{- -assert' :: (MonadIO m) => AssertionHandling -> Bool -> String -> m a -> m a -assert' Ignore b s k = k -assert' h True s k = k -assert' Warning False s k = do - liftIO $ putStrLn s - k -assert' Failure False s k = fail s - -class Monad m => MonadAssert m where - assert :: Bool -> String -> m a -> m a - newAssertionHandling :: AssertionHandling -> m a -> m a --} diff --git a/TreeShapedOrder.hs b/TreeShapedOrder.hs deleted file mode 100644 --- a/TreeShapedOrder.hs +++ /dev/null @@ -1,164 +0,0 @@ -{- A data structure to represent a forest of upside down trees, -similar to union-find. The idea is to manage a tree-shaped form of -strict inequations - - i1 > i2 > i3 - > j2 > j3 > j4 > j5 - > k3 - > l3 > l4 - - m1 > m2 - - n1 - -Checking inequalty x < y is then performed by just enumerating the -parents of x and checking wether y is a member of it. - -2010-11-12 UPDATE: We generalize this to ">=" and more by attaching to -each link a non-negative number. - - 0 means >= - 1 means > - n means at least n units greater --} - -module TreeShapedOrder where - -import Prelude hiding (null) -import Data.List hiding (insert, null) -- groupBy - -import Data.Map (Map) -import qualified Data.Map as Map - -import Data.Tree (Tree(..), Forest) -- rose trees -import qualified Data.Tree as Tree - -import Util -- headM - --- | Tree-structured partial orders. --- Represented as maps from children to parents plus a non-negative distance. -newtype TSO a = TSO { unTSO :: Map a (Int,a) } deriving (Eq, Ord) - --- | Empty TSO. -empty :: TSO a -empty = TSO $ Map.empty - --- | @insert a b o@ inserts a with parent b into order o. --- It does not check whether the tree structure is preserved. -insert :: (Ord a, Eq a) => a -> (Int, a) -> TSO a -> TSO a -insert a b (TSO o) = TSO $ Map.insert a b o - --- | Construction from a list of child-distance-parent tuples. -fromList :: (Ord a, Eq a) => [(a,(Int,a))] -> TSO a -fromList l = foldl (\ o (a,b) -> insert a b o) empty l - --- | @parents a0 o = [(d1,a1),..,(dn,an)]@ lists the parents of @a0@ in order, --- i.e., a(i+1) is parent of a(i) with distance d(i+1). -parents :: (Ord a, Eq a) => a -> TSO a -> [(Int,a)] -parents a (TSO o) = loop (Map.lookup a o) where - loop Nothing = [] - loop (Just (n,b)) = (n,b) : loop (Map.lookup b o) - --- | @parent a o@ returns the immediate parent, if it exists. -parent :: (Ord a, Eq a) => a -> TSO a -> Maybe (Int,a) -parent a t = headMaybe $ parents a t - --- | @isAncestor a b o = Just n@ if there are n steps up from a to b. -isAncestor :: (Ord a, Eq a) => a -> a -> TSO a -> Maybe Int -isAncestor a b o = loop 0 ((0,a) : parents a o) - where loop acc [] = Nothing - loop acc ((n,a) : ps) | a == b = Just (acc + n) - | otherwise = loop (acc + n) ps - --- | @diff a b o = Just k@ if there are k steps up from a to b --- or (-k) steps down from b to a. -diff :: (Ord a, Eq a) => a -> a -> TSO a -> Maybe Int -diff a b o = maybe (fmap (\ k -> -k) $ isAncestor b a o) Just $ isAncestor a b o - --- | create a map from parents to list of sons, leaves have an empty list -invert :: (Ord a, Eq a) => TSO a -> Map a [(Int,a)] -invert (TSO o) = Map.foldrWithKey step Map.empty o where - step son (dist, parent) m = Map.insertWith (++) son [] $ - Map.insertWith (++) parent [(dist, son)] m - --- | @height a t = Just k@ if $k$ is the length of the --- longest path from @a@ to a leaf. @Nothing@ if @a@ not in @t@. -height :: (Ord a, Eq a) => a -> TSO a -> Maybe Int -height a t = do - let m = invert t - let loop parent = do - sons <- Map.lookup parent m - return $ if null sons then 0 else - maximum $ map (\ (n,son) -> maybe 0 (n +) $ loop son) sons - loop a - --- | @increasesHeight a (n,b) t = True@ if @n > height b t@, i.e., if --- the insertion of a with parent b will destroy an existing --- minimal valuation of @t@ -increasesHeight :: (Ord a, Eq a) => a -> (Int, a) -> TSO a -> Bool -increasesHeight a (n,b) t = n > maybe 0 id (height b t) - --- | get the leaves of the TSO forest -leaves :: (Ord a, Eq a) => TSO a -> [a] -leaves o = map fst $ filter (\ (parent,sons) -> null sons) $ Map.toList (invert o) - -{- FLAWED BOTTOM-UP-ATTEMPT, DOES NOT WORK -{- How to invert a TSO? - -1. Create a Map from parents to their list of children. - -2. Keep a working set of nodes. - Find the leafs in this working set (nodes that do not have children). - Cluster them by their parents. - Turn their parents into trees, - Continue with the parents. --} --- | invert a tree shaped order into a forest. This can be used for printing -toForest :: (Ord a, Eq a) => TSO a -> Forest a -toForest o = loop (step initialTrees) where - initialTrees = map (flip Node []) $ leaves o - -- step :: (Ord a, Eq a) => Forest a -> [(Maybe a, Forest a)] - step ts = map (\ l -> (fst (head l), map snd l)) $ - groupBy (\ (p,t) (p',t') -> p == p') $ - sortBy (\ (p,t) (p',t') -> compare p p') $ - map (\ t -> (parent (rootLabel t) o, t)) ts - -- loop :: (Ord a, Eq a) => [(Maybe a, Forest a)] -> Forest a - loop [] = [] - -- the trees whose roots have no parents are parts of the final forest - loop ((Nothing, roots) : nonroots) = roots ++ loop nonroots - -- the trees whose roots have a parent are iterated - loop nonroots = loop $ step $ map (\ (Just p, ts) -> Node p ts) nonroots --} - --- take a lexicographically sorted list of pathes --- and turn it into a forest by --- gathering the lists by common prefixes -pathesToForest :: (Ord a, Eq a) => [[(Int,a)]] -> Forest (Int, a) -pathesToForest [] = [] -pathesToForest ll = - map (\ l -> Node (head (head l)) - (pathesToForest $ filter (not . null) $ map tail l)) $ - groupBy (\ l l' -> head l == head l') ll - --- | invert a tree shaped order into a forest. This can be used for printing. -toForest :: (Ord a, Eq a) => TSO a -> Forest (Int,a) -toForest o = pathesToForest $ sort $ map (\ a -> reverse ((0,a) : parents a o)) $ leaves o -- lex. sort - -instance (Ord a, Eq a, Show a) => Show (TSO a) where - show o = Tree.drawForest $ map (fmap show) $ toForest o - -{- -draw :: (Ord a, Eq a, Show a) => TSO a -> String -draw o = Tree.drawForest $ map (fmap show) $ toForest o --} - --- test - -l1 = map (\ (k,l) -> ("i" ++ show k, (1, "i" ++ show l))) [(0,1),(1,2),(2,3),(3,4)] - ++ [("j2",(1,"i3"))] -o1 = fromList l1 -t1 = diff "i2" "i1" o1 -t2 = diff "i2" "j2" o1 -t3 = height "i2" o1 -t4 = height "i4" o1 -t5 = height "k" o1 diff --git a/TypeChecker.hs b/TypeChecker.hs deleted file mode 100644 --- a/TypeChecker.hs +++ /dev/null @@ -1,3301 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, - PatternGuards, TupleSections, NamedFieldPuns #-} - -module TypeChecker where - -import Prelude hiding (null) - -import Control.Applicative hiding (Const) -- ((<$>)) -import Control.Monad -import Control.Monad.Identity -import Control.Monad.State -import Control.Monad.Except -import Control.Monad.Reader - -import qualified Data.List as List -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import qualified Data.Foldable as Foldable -import qualified Data.Traversable as Traversable - -import Debug.Trace - -import qualified Text.PrettyPrint as PP - -import Util -import qualified Util as Util - -import Abstract hiding (Substitute) -import Polarity as Pol -import Value -import TCM -import Eval -import Extract --- import SPos (nocc) -- RETIRED --- import CallStack -import PrettyTCM -import TraceError - -import Warshall hiding (Flex) -- size constraint checking - -import Termination - --- import Completness - - -traceCheck msg a = a -- trace msg a -traceCheckM msg = return () -- traceM msg -{- -traceCheck msg a = trace msg a -traceCheckM msg = traceM msg --} - -traceSing msg a = a -- trace msg a -traceSingM msg = return () -- traceM msg -{- -traceSing msg a = trace msg a -traceSingM msg = traceM msg --} - -traceAdm msg a = a -- trace msg a -traceAdmM msg = return () -- traceM msg -{- -traceAdm msg a = trace msg a -traceAdmM msg = traceM msg --} - -{- DEAD CODE -runWhnf :: Signature -> TypeCheck a -> IO (Either TraceError (a,Signature)) -runWhnf sig tc = (runExceptT (runStateT tc sig)) --} - -doNf sig e = runExceptT (runReaderT (runStateT (whnf emptyEnv e >>= reify) (initWithSig sig)) emptyContext) -doWhnf sig e = runExceptT (runReaderT (runStateT (whnf emptyEnv e >>= whnfClos) (initWithSig sig)) emptyContext) - - --- top-level functions ------------------------------------------- - -runTypeCheck :: TCState -> TypeCheck a -> IO (Either TraceError (a,TCState)) -runTypeCheck st tc = runExceptT (runReaderT (runStateT tc st) emptyContext) --- runTypeCheck st tc = runCallStackT (runReaderT (runStateT tc st) emptyContext) [] - -typeCheck dl = runTypeCheck initSt (typeCheckDecls dl) - --- checking top-level declarations ------------------------------- - -echo :: MonadIO m => String -> m () -echo = liftIO . putStrLn - -echoR = echo --- echoR s = echo $ "R> " ++ s - -echoTySig :: (Show n, MonadIO m) => n -> Expr -> m () -echoTySig n t = return () -- echo $ "I> " ++ n ++ " : " ++ show t - -echoKindedTySig :: (Show n, MonadIO m) => Kind -> n -> Expr -> m () -echoKindedTySig ki n t = echo $ prettyKind ki ++ " " ++ show n ++ " : " ++ show t - -echoKindedDef :: (Show n, MonadIO m) => Kind -> n -> Expr -> m () -echoKindedDef ki n t = echo $ prettyKind ki ++ " " ++ show n ++ " = " ++ show t - -echoEPrefix = "E> " - -echoTySigE :: (Show n, MonadIO m) => n -> Expr -> m () -echoTySigE n t = echo $ echoEPrefix ++ show n ++ " : " ++ show t - -echoDefE :: (Show n, MonadIO m) => n -> Expr -> m () -echoDefE n t = echo $ echoEPrefix ++ show n ++ " = " ++ show t - --- the type checker returns pruned (extracted) terms --- with irrelevant subterms replaced by Irr -typeCheckDecls :: [Declaration] -> TypeCheck [EDeclaration] -typeCheckDecls [] = return [] -typeCheckDecls (d:ds) = do - de <- typeCheckDeclaration d - dse <- typeCheckDecls ds - return (de ++ dse) - --- since a data declaration generates destructor declarations --- we need to return a list here -typeCheckDeclaration :: Declaration -> TypeCheck [EDeclaration] -typeCheckDeclaration (OverrideDecl Check ds) = do - st <- get - typeCheckDecls ds - put st -- forget the effect of these decls - return [] -typeCheckDeclaration (OverrideDecl Fail ds) = do - st <- get - r <- (typeCheckDecls ds >> return True) `catchError` - (\ s -> do liftIO $ putStrLn ("block fails as expected, error message:\n" ++ show s) - return False) - if r then throwErrorMsg "unexpected success" else do - put st - return [] - -typeCheckDeclaration (OverrideDecl TrustMe ds) = - newAssertionHandling Warning $ typeCheckDecls ds - -typeCheckDeclaration (OverrideDecl Impredicative ds) = - goImpredicative $ typeCheckDecls ds - -typeCheckDeclaration (RecordDecl n tel t0 c fields) = - -- just one "mutual" declaration - checkingMutual (Just $ DefId DatK $ QName n) $ do - result <- typeCheckDataDecl n NotSized CoInd [] tel t0 [c] fields - checkPositivityGraph - return result - -typeCheckDeclaration (DataDecl n sz co pos0 tel t0 cs fields) = - -- just one "mutual" declaration - checkingMutual (Just $ DefId DatK $ QName n) $ do - result <- typeCheckDataDecl n sz co pos0 tel t0 cs fields - checkPositivityGraph - return result - -typeCheckDeclaration (LetDecl eval n tel mt e) = enter (show n) $ do -{- MOVED to checkLetDef - (tel, (vt, te, Kinded ki ee)) <- checkTele tel $ checkOrInfer neutralDec e mt - te <- return $ teleToType tel te - ee <- return $ teleLam tel ee - vt <- whnf' te --} - (vt, te, Kinded ki ee) <- checkLetDef neutralDec tel mt e - rho <- getEnv -- is emptyEnv - -- TODO: solve size constraints - -- does not work with emptyEnv - -- [te, ee] <- solveAndModify [te, ee] rho -- solve size constraints - let v = mkClos rho ee -- delay whnf computation - -- v <- whnf' ee -- WAS: whnf' e' - addSig n (LetSig vt ki v $ undefinedFType $ QName n) -- late (var -> expr) binding, but ok since no shadowing --- addSig n (LetSig vt e') -- late (var -> expr) binding, but ok since no shadowing - echoKindedTySig ki n te --- echoTySigE n te --- echoDefE n ee - echoKindedDef ki n ee - return [LetDecl eval n emptyTel (Just te) ee] - -typeCheckDeclaration d@(PatternDecl x xs p) = do -{- WHY DOES THIS NOT TYPECHECK? - let doc = (PP.text "pattern") <+> (PP.hsep (List.map Util.pretty (x:xs))) <+> PP.equals <+> Util.pretty p - echo $ PP.render $ doc --} - echo $ "pattern " ++ Util.showList " " show (x:xs) ++ " = " ++ show p - v <- whnf' $ foldr (Lam defaultDec) (patternToExpr p) xs - addSig x (PatSig xs p v) - return [d] - -typeCheckDeclaration (MutualFunDecl False co funs) = - -- traceCheck ("type checking a function block") $ - do - funse <- typeCheckFuns co funs - return $ [MutualFunDecl False co funse] - -typeCheckDeclaration (MutualFunDecl True co funs) = - -- traceCheck ("type checking a block of measured function") $ - do - funse <- typeCheckMeasuredFuns co funs - return $ [MutualFunDecl False co funse] - -typeCheckDeclaration (MutualDecl measured ds) = do - -- first check type signatures - -- we add the typings into the context, not the signature - ktss <- typeCheckMutualSigs ds - -- register the mutually defined names - let ns = for ktss $ \ (Kinded _ (TypeSig n _)) -> n - addMutualNames = local $ \ e -> e { mutualNames = ns ++ mutualNames e } - -- then check bodies - -- we need to construct a positivity graph - edss <- addKindedTypeSigs ktss $ addMutualNames $ - zipWithM (typeCheckMutualBody measured) (map (predKind . kindOf) ktss) ds - -- check and reset positivity graph - checkPositivityGraph - return $ concat edss - - --- check signatures of a flattened mutual block -typeCheckMutualSigs :: [Declaration] -> TypeCheck [Kinded (TySig TVal)] -typeCheckMutualSigs [] = return [] -typeCheckMutualSigs (d:ds) = do - kts@(Kinded ki (TypeSig n tv)) <- typeCheckMutualSig d - new' n (Domain tv ki defaultDec) $ do - ktss <- typeCheckMutualSigs ds - return $ kts : ktss - -typeCheckSignature :: TySig Type -> TypeCheck (Kinded (TySig TVal)) -typeCheckSignature (TypeSig n t) = do - echoTySig n t - Kinded ki te <- checkType t - tv <- whnf' te - return $ Kinded (predKind ki) $ TypeSig n tv - -typeCheckMutualSig :: Declaration -> TypeCheck (Kinded (TySig TVal)) -typeCheckMutualSig (LetDecl ev n tel (Just t) e) = - typeCheckSignature $ TypeSig n $ teleToType tel t -typeCheckMutualSig (DataDecl n sz co pos tel t cs fields) = do - Kinded ki ts <- typeCheckSignature (TypeSig n (teleToType tel t)) - return $ Kinded ki ts -typeCheckMutualSig (FunDecl co (Fun ts n' ar cls)) = - typeCheckSignature ts -typeCheckMutualSig (OverrideDecl TrustMe [d]) = - newAssertionHandling Warning $ typeCheckMutualSig d -typeCheckMutualSig (OverrideDecl Impredicative [d]) = - goImpredicative $ typeCheckMutualSig d -typeCheckMutualSig d = throwErrorMsg $ "typeCheckMutualSig: panic: unexpected declaration " ++ show d - --- typeCheckMutualBody measured kindCandidate -typeCheckMutualBody :: Bool -> Kind -> Declaration -> TypeCheck [EDeclaration] -typeCheckMutualBody measured _ (DataDecl n sz co pos tel t cs fields) = do - -- set name of mutual thing whose body we are checking - checkingMutual (Just $ DefId DatK $ QName n) $ - -- - typeCheckDataDecl n sz co pos tel t cs fields -typeCheckMutualBody measured@False ki (FunDecl co fun@(Fun ts@(TypeSig n t) n' ar cls)) = do - checkingMutual (Just $ DefId FunK $ QName n) $ do - fun' <- typeCheckFunBody co ki fun - return $ [FunDecl co fun'] - -typeCheckDataDecl :: Name -> Sized -> Co -> [Pol] -> Telescope -> Type -> [Constructor] -> [Name] -> TypeCheck [EDeclaration] -typeCheckDataDecl n sz co pos0 tel0 t0 cs0 fields = enter (show n) $ - (do -- sig <- gets signature - let params = size tel0 - -- in case we are dealing with a sized type, check that - -- the polarity annotation (if present) at the size arg. is correct. - (p', pos, t) <- do - case sz of - Sized -> do - let polsz = if co==Ind then Pos else Neg - t <- case t0 of - Quant Pi (TBind x (Domain domt ki dec)) b | isSize domt -> - case (polarity dec) of - -- insert correct polarity annotation if none was there - pol | pol `elem` [Param,Rec] -> return $ Quant Pi (TBind x $ Domain tSize kSize $ setPol polsz dec) b - pol | pol == polsz -> return t0 - pol -> throwErrorMsg $ "sized type " ++ show n ++ " has wrong polarity annotation " ++ show pol ++ " at Size argument, it should be " ++ show polsz - t0 -> return t0 - return (params + 1, pos0 ++ [polsz], t) - NotSized -> return (params, pos0, t0) - -- compute full type signature (including parameter telescope) - let dt = (teleToType tel0 t) - echoTySig n dt - {- mmh, this does not work, e.g. data Id (A : Set)(a : A) : A -> Set - then A -> Set is not distinguishable from Set -> Set (GADT) - unclear what to do... - dte <- checkTele tel $ \ tele -> do - te <- checkSmallType t - return (teleToType tele te) - -} - -- get the target sort ds of the datatype - Kinded ki0 (ds, dte) <- checkDataType p' dt -- TODO?: use above code? - let ki = dataKind ki0 - echoKindedTySig ki n dte --- echoTySigE n dte - v <- whnf emptyEnv dte - Just fkind <- extractKind v - -- get the updated telescope which contains the kinds - let (tel, dtcore) = typeToTele' params dte - -- compute the constructor telescopes - cs0 <- mapM (insertConstructorTele tel dtcore) cs0 - let cis = analyzeConstructors co n tel cs0 - let cs = map reassembleConstructor cis - addSig n (DataSig { numPars = params - , positivity = pos - , isSized = sz - , isCo = co - , symbTyp = v - , symbolKind = ki - , constructors = cis - , etaExpand = False - , isTuple = False --- if cs==[] then Just [] else Nothing -{- OLD CODE - , constructors = map namePart cs - -- at first, do not add destructors, get them out later - , destructors = Nothing - , isFamily = t /= Set -- currently UNUSED - -} - , extrTyp = fkind - }) - when (sz == Sized) $ - szType co params v - - (isRecList, kcse) <- liftM unzip $ - mapM (typeCheckConstructor n dte sz co pos tel) cs - - -- compute the kind of the data type from the kinds of the - -- constructor arguments (mmh, DOES NOT WORK FOR MUTUAL DATA!) - let newki = case (foldl unionKind NoKind (map kindOf kcse)) of - NoKind -> kType -- no non-rec constructor arguments - AnyKind -> AnyKind - Kind s s' -> Kind (Set Zero) s' -- a data type is always also a type - -- echoKindedTySig newki n dte -- 2012-01-26 disabled (repetitive) - - -- solve for size variables - sol <- solveConstraints - -- TODO: substitute - resetConstraints - - -- add destructors only for the constructors that are non-overlapping - let decls = concat $ map mkDestrs cis - -- cEtaExp = True means that all field names are present - -- and constructor is not overlapping with others - mkDestrs ci | cEtaExp ci = concat $ map mkDestr (cFields ci) - | otherwise = [] - mkDestr fi = - case (fClass fi) of - Field (Just (ty, arity, cl)) | not (erased $ fDec fi) && not (emptyName $ fName fi) -> - let n' = fName fi - n = internal n' - in - [MutualFunDecl False Ind [Fun (TypeSig n ty) n' arity [cl]]] - _ -> [] - - when (not (null decls)) $ - traceCheckM $ "generated destructors: " ++ show decls - declse <- mapM (\ d@(MutualFunDecl False co [Fun (TypeSig n t) n' ar cls]) -> do - -- echo $ "G> " ++ showFun co ++ " " ++ show n ++ " : " ++ show t - -- echo $ "G> " ++ PP.render (prettyFun n cls) - checkingMutual Nothing $ typeCheckDeclaration d) - decls - - -- decide whether to eta-expand at this type - -- all patterns need to be proper and non-overlapping - -- at least one constructor needs to be eta-expandable - let isPatIndFam = all (\ ci -> fst (cPatFam ci) /= NotPatterns && cEtaExp ci) cis --- && not (or overlapList) - -- do not eta-expand recursive constructors (might not terminate) - let disableRec ci {-ov-} rec' = ci - { cRec = rec' - , cEtaExp = cEtaExp ci -- all destructors present - && fst (cPatFam ci) /= NotPatterns -- proper pattern to compute indices --- && not ov -- non-overlapping - && not (co==Ind && rec') } -- non-recursive - let cis' = zipWith disableRec cis {-overlapList-} isRecList - let typeEtaExpandable = isPatIndFam && (null cis || any cEtaExp cis') - traceEtaM $ "data " ++ show n ++ " eta-expandable " ++ show typeEtaExpandable ++ " constructors " ++ show cis' - modifySig n (\ dataSig -> - dataSig { symbolKind = newki - , etaExpand = typeEtaExpandable - , constructors = cis' - , isTuple = length cis' >= 1 && isPatIndFam - }) - -- compute extracted data decl - let (tele, te) = typeToTele' (size tel) dte - return $ (DataDecl n sz co pos tele te (map valueOf kcse) fields) : concat declse - - ) -- `throwTrace` n -- in case of an error, add name n to the trace - - -insertConstructorTele :: Telescope -> Type -> Constructor -> TypeCheck Constructor -insertConstructorTele dtel dt c@(Constructor n Nothing t) = return c -insertConstructorTele dtel dt c@(Constructor n Just{} t) = do - res <- computeConstructorTele dtel dt t - return $ Constructor n (Just res) t - --- | @computeConstructorTele dtel t = return ctel@ --- Computes the constructor telescope from the target. -computeConstructorTele :: Telescope -> Type -> Type -> TypeCheck (Telescope, [Pattern]) -computeConstructorTele dtel dt t = do - -- target is data name applied to parameters and indices - let (_, target) = typeToTele t - (_, es) = spineView target - pars = take (size dtel) es - (cxt, ps) <- checkConstructorParams pars =<< whnf' (teleToType dtel dt) - (,ps) . setDec (Dec Param) <$> do local (const cxt) $ contextToTele cxt - --- | @checkConstructorParams pars tv = return cxt@ --- Checks that parameters @pars@ are patterns elimating the datatype @tv@. --- Returns a context @cxt@ that binds the pattern variables in --- left-to-right order. -checkConstructorParams :: [Expr] -> TVal -> TypeCheck (TCContext, [Pattern]) -checkConstructorParams es tv = do - -- for now, we only allow patterns in parameters - -- could be extended to unifyable expressions in general - ps <- mapM (\ e -> maybe (errorParamNotPattern e) return $ exprToPattern e) es - -- no goals from dot patterns, no absurd pattern - ([],_,cxt,_,_,_,False) <- checkPatterns defaultDec [] emptySub tv ps - return (cxt, ps) - - where - errorParamNotPattern e = throwErrorMsg $ - "expected parameter to be a pattern, but I found " ++ show es - --- | --- Precondition: @ce@ is included in the current context. -contextToTele :: TCContext -> TypeCheck Telescope -contextToTele ce = do - let n :: Int - n = len (context ce) -- context length - delta :: Map Int (OneOrTwo Domain) - delta = cxt (context ce) -- types for dB levels - names :: Map Int Name - names = naming ce -- names for dB levels - -- traverse the context from left to right - Telescope <$> do - forM [0..n-1] $ \ k -> do - x <- lookupM k names - One dom <- lookupM k delta - TBind x <$> Traversable.traverse toExpr dom - --- | @typeCheckConstructor d dt sz co pols tel (TypeSig c t)@ --- --- returns True if constructor has recursive argument -typeCheckConstructor :: Name -> Type -> Sized -> Co -> [Pol] -> Telescope -> Constructor -> TypeCheck (Bool, Kinded EConstructor) -typeCheckConstructor d dt sz co pos dtel (Constructor n mctel t) = enter ("constructor " ++ show n) $ do - let tel = maybe dtel fst mctel -{- - tel <- case cpars of - -- old style data parameters - Nothing -> return dtel - -- new style pattern parameters - Just{} -> computeConstructorTele dtel dt t --} - sig <- gets signature - let telE = setDec irrelevantDec tel -- need kinded tel!! - -- parameters are erased in types of constructors - let tt = teleToType telE t - echoTySig n tt - let params = size tel - -- when checking constructor types, do NOT resurrect telescope - -- data T [A : Set] : Set { inn : A -> T A } - -- should be rejected, since A ~= T A, and T A = T B means A ~=B for arb. A, B! - -- add data name as spos var, to check positivity - -- and as NoKind, to compute the true kind from the constructors - let telWithD = Telescope $ (TBind d $ Domain dt NoKind $ Dec SPos) : telescope tel - Kinded ki te <- addBinds telWithD $ - checkConType sz t -- do NOT resurrect telescope!! - - -- Check target of constructor. - dv <- whnf' dt - let (Telescope argts,target) = typeToTele te - whenNothing mctel $ -- only for old-style parameters - addBinds telWithD $ addBinds (Telescope argts) $ checkTarget d dv tel target - - -- Make type of a constructor a singleton type. - let mkName i n | emptyName n = fresh $ "y" ++ show i - | otherwise = n - fields = map boundName argts - argns = zipWith mkName [0..] $ fields - argtbs = zipWith (\ n tb -> tb { boundName = n }) argns argts --- core = (foldl App (con (coToConK co) n) $ map Var argns) - core = Record (NamedRec (coToConK co) n False notDotted) $ zip fields $ map Var argns - tsing = teleToType (Telescope argtbs) $ Sing core target - - let tte = teleToType telE tsing -- te -- DO resurrect here! - vt <- whnf' tte - - -- Now, compute the remaining information concerning the constructor. - - {- old code was more accurate, since it evaluated before checking - for recursive occurrence. - recOccs <- sposConstructor d 0 pos vt -- get recursive occurrences - -} - mutualNames <- asks mutualNames - let mutOcc tb = not $ null $ List.intersect (d:mutualNames) $ usedDefs $ boundType tb - recOccs = map mutOcc argts - isRec = or recOccs - -- fType <- extractType vt -- moved to Extract - let fType = undefinedFType n - isSz <- if sz /= Sized then return Nothing else do - szConstructor d co params vt -- check correct use of sizes - if co == CoInd then return $ Just $ error "impossible lhs type of coconstructor" else do - let (x, lte) = mapSnd (teleToType telE) $ mkConLType params te - echoKindedTySig kTerm n lte - ltv <- whnf' lte - return $ Just (x, ltv) - - -- Add the type constructor to the signature. - let cpars = fmap (mapFst (map boundName . telescope)) mctel -- deletes types, keeps names - addSigQ n (ConSig cpars isSz recOccs vt d (size dtel) fType) --- let (tele, te) = typeToTele (length tel) tte -- NOT NECESSARY - echoKindedTySig kTerm n tte - -- traceM ("kind of " ++ n ++ "'s args: " ++ show ki) --- echoTySigE n tte - return (isRec, Kinded ki $ Constructor n (fmap (mapFst (const telE)) mctel) te) - -typeCheckMeasuredFuns :: Co -> [Fun] -> TypeCheck [EFun] -typeCheckMeasuredFuns co funs0 = do - -- echo $ show funs - kfse <- mapM typeCheckFunSig funs0 -- NO LONGER erases measure - -- use erased type signatures with retaines measure - let funs = zipWith (\ (Kinded ki ts) f -> f { funTypeSig = ts }) kfse funs0 - - -- type check and solve size constraints - -- return clauses with meta vars resolved - kcle <- installFuns co (zipWith Kinded (map kindOf kfse) funs) $ - mapM typeCheckFunClauses funs - let kis = map kindOf kcle - let clse = map valueOf kcle -{- - -- replace old clauses by new ones in funs - let funs' = zipWith (\(tysig,(ar,cls)) cls' -> (tysig,(ar,cls'))) funs clss --} - -- get the list of mutually defined function names - let funse = List.zipWith4 Fun - (map (fmap eraseMeasure . valueOf) kfse) - (map funExtName funs) - (map funArity funs) - clse - -- print reconstructed clauses - mapM_ (\ (Fun (TypeSig n t) n' ar cls) -> do - -- echoR $ n ++ " : " ++ show t - echoR $ (PP.render $ prettyFun n cls)) - funse - -- replace in signature by erased clauses - zipWithM (enableSig co) (zipWith intersectKind kis $ map kindOf kfse) funse - return $ funse - - where - enableSig :: Co -> Kind -> Fun -> TypeCheck () - enableSig co ki (Fun (TypeSig n t) n' ar' cl') = do - vt <- whnf' t - addSig n (FunSig co vt ki ar' cl' True $ undefinedFType $ QName n) - -- add a let binding for external use - v <- up False (vFun n) vt - addSig n' (LetSig vt ki v $ undefinedFType $ QName n') - - - --- type check the body of one function in a mutual block --- type signature is already checked and added to local context -typeCheckFunBody :: Co -> Kind -> Fun -> TypeCheck EFun -typeCheckFunBody co ki0 fun@(Fun ts@(TypeSig n t) n' ar cls0) = do - -- echo $ show fun - addFunSig co $ Kinded ki0 fun - -- type check and solve size constraints - -- return clauses with meta vars resolved - Kinded ki clse <- setCo co $ typeCheckFunClauses fun - - -- check new clauses for admissibility, inserting "unusuable" flags in the patterns where necessary - -- TODO: proper cleanup, proper removal of admissibility check! - -- clse <- admCheckFunSig co names ts clse - - -- print reconstructed clauses - -- echoR $ n ++ " : " ++ show t - echoR $ (PP.render $ prettyFun n clse) - -- replace in signature by erased clauses - let fune = Fun ts n' ar clse - enableSig ki fune - return fune - - -typeCheckFuns :: Co -> [Fun] -> TypeCheck [EFun] -typeCheckFuns co funs0 = do - -- echo $ show funs - kfse <- mapM typeCheckFunSig funs0 - let kfuns = zipWith (\ (Kinded ki ts) (Fun ts0 n' ar cls) -> Kinded ki (Fun ts n' ar cls)) kfse funs0 - -- zipWithM (addFunSig co) (map kindOf kfse) funs - mapM (addFunSig co) kfuns - let funs = map valueOf kfuns - -- type check and solve size constraints - -- return clauses with meta vars resolved - kce <- setCo co $ mapM typeCheckFunClauses funs - let kis = map kindOf kce - let clse = map valueOf kce - -- get the list of mutually defined function names - let names = map (\ (Fun (TypeSig n t) n' ar cls) -> n) funs - -- check new clauses for admissibility, inserting "unusuable" flags in the patterns where necessary - -- TODO: proper cleanup, proper removal of admissibility check! - clse <- zipWithM (\ (Fun tysig _ _ _) cls' -> admCheckFunSig co names tysig cls') funs clse - -- replace old clauses by new ones in funs - let funse = List.zipWith4 Fun - (map valueOf kfse) - (map funExtName funs) - (map funArity funs) - clse --- let funse = zipWith (\(tysig,(ar,cls)) cls' -> (tysig,(ar,cls'))) funs clse - -- print reconstructed clauses - mapM_ (\ (Fun (TypeSig n t) n' ar cls) -> do - -- echoR $ n ++ " : " ++ show t - echoR $ (PP.render $ prettyFun n cls)) - funse - terminationCheck funse - -- replace in signature by erased clauses - zipWithM enableSig kis funse - return $ funse - -addFunSig :: Co -> Kinded Fun -> TypeCheck () -addFunSig co (Kinded ki (Fun (TypeSig n t) n' ar cl)) = do - sig <- gets signature - vt <- whnf' t -- TODO: PROBLEM for internal extraction (would need te here) - addSig n (FunSig co vt ki ar cl False $ undefinedFType $ QName n) --not yet type checked / termination checked - --- ADMCHECK FOR COFUN is not taking place in checking the lhs --- TODO: proper analysis for size patterns! --- admCheckFunSig mutualNames (TypeSig thisName thisType, clauses) -admCheckFunSig :: Co -> [Name] -> TypeSig -> [Clause] -> TypeCheck [Clause] -admCheckFunSig CoInd mutualNames (TypeSig n t) cls = return cls -admCheckFunSig co@Ind mutualNames (TypeSig n t) cls = traceAdm ("admCheckFunSig: checking admissibility of " ++ show n ++ " : " ++ show t) $ - ( - do -- a function is not recursive if did does not mention any of the - -- mutually defined function names - let usedNames = rhsDefs cls - let notRecursive = all (\ n -> not (n `elem` usedNames)) mutualNames - -- for non-recursive functions, we can skip the admissibility check - if notRecursive then - -- trace ("function " ++ n ++ " is not recursive") $ - return cls - else -- trace ("function " ++ n ++ " is recursive ") $ - do vt <- whnf' t - admFunDef co cls vt - ) `throwTrace` ("checking type of " ++ show n ++ " for admissibility") - - -enableSig :: Kind -> Fun -> TypeCheck () -enableSig ki (Fun (TypeSig n _) n' ar' cl') = do - (FunSig co vt ki0 ar cl _ ftyp) <- lookupSymb n - addSig n (FunSig co vt (intersectKind ki ki0) ar cl' True ftyp) - -- add a let binding for external use - v <- up False (vFun n) vt - addSig n' (LetSig vt ki v ftyp) - - --- typeCheckFunSig (TypeSig thisName thisType, clauses) -typeCheckFunSig :: Fun -> TypeCheck (Kinded ETypeSig) -typeCheckFunSig (Fun (TypeSig n t) n' ar cls) = enter ("type of " ++ show n) $ do - echoTySig n t - Kinded ki0 te <- checkType t - -- let te = eraseMeasure te0 - let ki = predKind ki0 - echoKindedTySig ki n (eraseMeasure te) --- echoTySigE n te - return $ Kinded ki $ TypeSig n te - -typeCheckFunClauses :: Fun -> TypeCheck (Kinded [EClause]) -typeCheckFunClauses (Fun (TypeSig n t) n' ar cl) = enter (show n) $ - do result@(Kinded _ cle) <- checkFun t cl - -- traceCheck (show (TypeSig n t)) $ - -- traceCheck (show cl') $ - -- echo $ PP.render $ prettyFun n cle - return result - --- checkConType sz t = Kinded ki te --- the returned kind is the kind of the constructor arguments --- check that result is a universe --- ( params were already checked by checkDataType and are not included in t ) --- called initially in the context consisting of the parameter telescope -checkConType :: Sized -> Expr -> TypeCheck (Kinded Extr) -checkConType NotSized t = checkConType' t -checkConType Sized t = - case t of - Quant Pi tb@(TBind _ (Domain t1 _ _)) t2 | isSize t1 -> do - addBind (mapDec (const paramDec) tb) $ do -- size is parametric in constructor type - Kinded ki t2e <- checkConType' t2 - return $ Kinded ki $ Quant Pi (mapDec (const irrelevantDec) tb) t2e -- size is irrelevant in constructor - _ -> throwErrorMsg $ "checkConType: expecting size quantification, found " ++ show t - -checkConType' :: Expr -> TypeCheck (Kinded Extr) -checkConType' t = do - (s, kte) <- checkingCon True $ inferType t - case s of - Set{} -> return kte - CoSet{} -> return kte - _ -> throwErrorMsg $ "checkConType: type " ++ show t ++ " of constructor not a universe" - --- check that the data type and the parameter arguments (written down like declared in telescope) --- precondition: target tg type checks in current context -checkTarget :: Name -> TVal -> Telescope -> Type -> TypeCheck () -checkTarget d dv tel tg = do - tv <- whnf' tg - case tv of - VApp (VDef (DefId DatK (QName n))) vs | n == d -> do - telvs <- mapM (\ tb -> whnf' (Var (boundName tb))) $ telescope tel - enter ("checking datatype parameters in constructor target") $ - leqVals' N mixed (One dv) (take (size tel) vs) telvs - return () - _ -> throwErrorMsg $ "constructor should produce something in data type " ++ show d - -{- RETIRED (syntactic check) -checkTarget :: Name -> Telescope -> Type -> TypeCheck () -checkTarget d tel tg = - case spineView tg of - (Def (DefId Dat n), args) | n == d -> checkParams tel (take (length tel) args) - _ -> throwErrorMsg $ "target mismatch" ++ show tg - - where checkParams :: Telescope -> [Expr] -> TypeCheck () - checkParams [] [] = return () - checkParams (tb : tl) ((Var n') : el) | boundName tb == n' - = checkParams tl el - checkParams tl al = throwErrorMsg $ "target param mismatch " ++ - d ++ " " ++ show tel ++ " != " ++ show tg ++ "\ncheckParams " ++ show tl ++ " " ++ show al ++ " failed" --} - --- check that params are types --- check that arguments are stypes --- check that target is set -checkDataType :: Int -> Expr -> TypeCheck (Kinded (Sort Expr, Extr)) -checkDataType p e = do - traceCheckM ("checkDataType " ++ show e ++ " p=" ++ show p) - case e of - Quant Pi tb@(TBind x (Domain t1 _ dec)) t2 -> do - k <- getLen - traceCheckM ("length of context = " ++ show k) - -- t1e <- checkingDom $ if k <= p then checkType t1 else checkSmallType t1 - (s1, Kinded ki0 t1e) <- checkingDom $ inferType t1 - let ki1 = predKind ki0 - addBind (TBind x (Domain t1 ki1 defaultDec)) $ do - Kinded ki2 (s, t2e) <- checkDataType p t2 - -- when k <= p $ ltSort s1 s -- check size of indices (disabled) - return $ Kinded ki2 (s, Quant Pi (TBind x (Domain t1e ki1 dec)) t2e) - Sort s@(Set e1) -> do - (_, e1e) <- checkLevel e1 - return $ Kinded (kUniv e1e) (s, Sort $ Set e1e) - Sort s@(CoSet e1) -> do - e1e <- checkSize e1 - return $ Kinded (kUniv Zero) (s, Sort $ CoSet e1e) - _ -> throwErrorMsg "doesn't target Set or CoSet" - -{- -checkSize :: Expr -> TypeCheck Extr -checkSize Infty = return Infty -checkSize e = valueOf <$> checkExpr e vSize --} - -checkSize :: Expr -> TypeCheck Extr -checkSize e = - case e of - Meta i -> do - ren <- asks renaming - addMeta ren i - return e - e -> inferSize e - -inferSize :: Expr -> TypeCheck Extr -inferSize e = - case e of - Zero -> return e - Infty -> return e - Succ e -> Succ <$> checkSize e - Plus es -> Plus <$> mapM checkSize es - Max es -> maxE <$> mapM checkSize es - e -> do - (v, Kinded ki e) <- inferExpr e - subtype v vSize - return e - -checkBelow :: Expr -> LtLe -> Val -> TypeCheck Extr -checkBelow e Le VInfty = checkSize e -checkBelow e ltle v = do - e' <- checkSize e - v' <- whnf' e - leSize ltle Pos v' v - return e' - - --- checkLevel e = (value of e, ee) --- if e : Size and value of e != Infty -checkLevel :: Expr -> TypeCheck (Val, Extr) -checkLevel e = do - Kinded _ ee <- checkExpr e vSize - v <- whnf' e - when (v == VInfty) $ recoverFail $ "# is not a valid universe level" - return (v, ee) - -{- Kind inference - - i : Size : Type - t : Nat : Set : Set1 : ... : Type = Set\omega - p : P : Prop : Set : ... - -Functional, cumulative PTS (s,s',s') written (s,s') - - (Size,s) s != Size size-dependency - (s,Prop) impredicative Prop - (Set_i,Set_j) i <= j predicativity - -Kind can be used to construct Kinds -term t terms, types, universes, proofs, propositions -type T types, universes, propositions -size i types, universes, propositions -prf p proofs -pred P types, universes, propositions - -We like to infer kinds of expressions - - Tm < Set < Set1 < Set2 < ... - -For t : A if kind(A) = Tm then t is a term, - = Set then t is a type, - = Set1 then t is a type1 (e.g, a universe) ... - -Then, if t : (x : A) -> B - and kind(A) `irrelevantFor` kind(B) [ with irrelevantFor := > ] - -we can change the type signature to - - t : [x : A] -> B - -This is because you cannot eliminate a type to produce a term. - - kind(Set) = Set - kind(Size) = Size -- this means that we treat sizes as types, they cannot - kind(s) = s -- if s is a sort - kind((x : A) -> B) = kind(B) - kind(A : Set0) = Tm - kind(A : Prop) = Prf - kind(A : Size) = <> - kind(A : Setk) = k-1 - -irrFor Tm _ = False -irrFor Ty Tm = True -irrFor Ty Prf = True -irrFor Ty _ = False -irrFor Size Tm = True -irrFor Size Prf = True - -One problem is that we cannot infer exact kinds, e.g. - - fun T : Bool -> Set 1 -- T is a type - { T true = Bool -- T true is a type - ; T false = Set 0 -- T false is a universe - } - -T is either a type or a universe. So we can only assign intervals. -This is like in Augustsson's Cayenne [not in his paper, though]. - -A datatype is always a type. A size is a type. -A constructor is always a term. - --} - - --- type checking - --- checkExpr e tv = (e', ki) --- e' is the version of e with erasure marker at irrelevant positions --- ki is the kind of e (Tm, Ty, Set ...) --- ki is at most the predecessor of the sort of tv --- --- this is *internal* extraction in the style of Barras and Bernardo --- e.g., does not prune t : Id A a b --- thus, we can use the pruned version for evaluation! -checkExpr :: Expr -> TVal -> TypeCheck (Kinded Extr) -checkExpr e v = do - l <- getLen - enterDoc (text ("checkExpr " ++ show l ++ " |-") <+> prettyTCM e <+> colon <+> prettyTCM v) $ do - - ce <- ask - traceCheck ("checkExpr: " ++ show (renaming ce) ++ ";" ++ show (context ce) ++ " |- " ++ show e ++ " : " ++ show v ++ " in env" ++ show (environ ce)) $ do - - (case (e, v) of - -{- In the presence of full bracket types, - we could implement the following "resurrecting version of let" - - Gamma |- s : [A] - Gamma, x:A |- t : C Gamma, x:A, y:A |- t = t[y/x] : C - ------------------------------------------------------- - Gamma |- let x:[A] = s in t : C - - -} - - (App (Lam dec x f) e, v) | inferable e -> checkLet dec x emptyTel Nothing e f v - -{- - (LLet (TBind x (Domain Nothing _ dec)) e1 e2, v) -> checkUntypedLet x dec e1 e2 v - (LLet (TBind x (Domain (Just t1) _ dec)) e1 e2, v) -> checkTypedLet x t1 dec e1 e2 v --} - (LLet (TBind x (Domain mt _ dec)) tel e1 e2, v) -> checkLet dec x tel mt e1 e2 v - - (Case (Var x) Nothing [Clause _ [SuccP (VarP y)] (Just rhs)], v) -> do - (tv, _) <- resurrect $ inferExpr (Var x) - subtype tv vSize - vx@(VGen i) <- whnf' (Var x) - endsInSizedCo i v - let dom = Domain vSize kSize defaultDec - newWithGen y dom $ \ j vy -> do - let vp = VSucc vy - addSizeRel j 1 i $ - addRewrite (Rewrite vx vp) [v] $ \ [v'] -> do - Kinded ki2 rhse <- checkRHS emptySub rhs v' - return $ Kinded ki2 $ Case (Var x) (Just tSize) [Clause [TBind y dom] [SuccP (VarP y)] (Just rhse)] - - - (Case e mt cs, v) -> do - (tv, t, Kinded ki1 ee) <- checkOrInfer neutralDec e mt - ve <- whnf' ee - -- tv' <- sing' ee tv -- DOES NOT WORK - Kinded ki2 cle <- checkCases ve (arrow tv v) cs - return $ Kinded ki2 $ Case ee (Just t) cle -{- - (Case e Nothing cs, _) -> do - (tv, Kinded ki1 ee) <- inferExpr e - ve <- whnf' ee - -- tv' <- sing' ee tv -- DOES NOT WORK - Kinded ki2 cle <- checkCases ve (arrow tv v) cs - t <- toExpr tv - return $ Kinded ki2 $ Case ee (Just t) cle --} - (_, VGuard beta bv) -> - addBoundHyp beta $ checkExpr e bv - - (e,v) | inferable e -> do - (v2, Kinded ki1 ee) <- inferExpr e - checkSubtype ee v2 v - return $ Kinded ki1 ee - - _ -> checkForced e v - - ) -- >> (trace ("checkExpr successful: " ++ show e ++ ":" ++ show v) $ return ()) - --- | checkLet @let .x tel : t = e1 in e2@ -checkLet :: Dec -> Name -> Telescope -> Maybe Type -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr) -checkLet dec x tel mt1 e1 e2 v = do - (v_t1, t1e, Kinded ki1 e1e) <- checkLetDef dec tel mt1 e1 --- (v_t1, t1e, Kinded ki1 e1e) <- checkOrInfer dec e1 mt1 - checkLetBody x t1e v_t1 ki1 dec e1e e2 v - --- | checkLetDef @.x tel : t = e@ becomes @.x : tel -> t = \ tel -> e@ -checkLetDef :: Dec -> Telescope -> Maybe Type -> Expr -> TypeCheck (TVal, EType, Kinded Extr) -checkLetDef dec tel mt e = local (\ cxt -> cxt {consistencyCheck = True}) $ do - -- 2013-04-01 - -- since a let telescope is treated like a lambda abstraction - -- and the let-defined symbol reduces by itself, we need to - -- do the context consistency check at each introduction. - (tel, (vt, te, Kinded ki ee)) <- checkTele tel $ checkOrInfer dec e mt - te <- return $ teleToType tel te - ee <- return $ teleLam tel ee - vt <- whnf' te - return (vt, te, Kinded ki ee) - -{- -checkTypedLet :: Name -> Type -> Dec -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr) -checkTypedLet x t1 dec e1 e2 v = do - Kinded kit t1e <- checkType t1 - v_t1 <- whnf' t1 - Kinded ki0 e1e <- applyDec dec $ checkExpr e1 v_t1 - let ki1 = intersectKind ki0 (predKind kit) - checkLetBody x t1e v_t1 ki1 dec e1e e2 v -{- - v_e1 <- whnf' e1 - new x (Domain v_t1 ki1 dec) $ \ vx -> do - addRewrite (Rewrite vx v_e1) [v] $ \ [v'] -> do - Kinded ki2 e2e <- checkExpr e2 v' - return $ Kinded ki2 $ LLet (TBind x (Domain t1e ki1 dec)) e1e e2e -- if e2e==Irr then Irr else LLet n t1e e1e e2e --} - -checkUntypedLet :: Name -> Dec -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr) -checkUntypedLet x dec e1 e2 v = do - (v_t1, Kinded ki1 e1e) <- applyDec dec $ inferExpr e1 - v_e1 <- whnf' e1 - t1e <- toExpr v_t1 - checkLetBody x t1e v_t1 ki1 dec e1e e2 v --} - -checkLetBody :: Name -> EType -> TVal -> Kind -> Dec -> Extr -> Expr -> TVal -> TypeCheck (Kinded Extr) -checkLetBody x t1e v_t1 ki1 dec e1e e2 v = do - v_e1 <- whnf' e1e - new x (Domain v_t1 ki1 dec) $ \ vx -> do - addRewrite (Rewrite vx v_e1) [v] $ \ [v'] -> do - Kinded ki2 e2e <- checkExpr e2 v' - return $ Kinded ki2 $ LLet (TBind x (Domain (Just t1e) ki1 dec)) emptyTel e1e e2e -{- --- Dependent let: not checkable in rho;Delta style --- v_e1 <- whnf rho e1 --- checkExpr (update rho n v_e1) (v_t1 : delta) e2 v --} - --- | @checkPair e1 e2 y dom env b@ checks @Pair e1 e2@ against --- @VQuant Sigma y dom env b@. -checkPair :: Expr -> Expr -> Name -> Domain -> FVal -> TypeCheck (Kinded Expr) -checkPair e1 e2 y dom@(Domain av ki dec) fv = do - case av of - VBelow Lt VInfty -> do - lowerSemi <- underAbs y dom fv $ \ i _ bv -> lowerSemiCont i bv - continue $ if lowerSemi then VBelow Le VInfty else av - _ -> continue av - where - continue av = do - Kinded k1 e1 <- applyDec dec $ checkExpr e1 av - v1 <- whnf' e1 - bv <- app fv v1 - Kinded k2 e2 <- checkExpr e2 bv - return $ Kinded (unionKind k1 k2) $ Pair (maybeErase dec e1) e2 - --- check expression after forcing the type -checkForced :: Expr -> TVal -> TypeCheck (Kinded Expr) -checkForced e v = do - ren <- asks renaming - v <- force v --- enter ("checkForced " ++ show ren ++ " |- " ++ show e ++ " : " ++ show v) $ do - enterDoc (text ("checkForced " ++ show ren ++ " |-") <+> prettyTCM e <+> colon <+> prettyTCM v) $ do - case (e,v) of -{- - (_, VGuard (Bound (Measure [VGen i]) (Measure [VGen j])) bv) -> - addSizeRel i j $ checkForced e bv --} - (_, VGuard beta bv) -> - addBoundHyp beta $ checkForced e bv - - (Pair e1 e2, VQuant Sigma y dom@(Domain av ki dec) fv) -> - checkPair e1 e2 y dom fv - - (Record ri rs, t@(VApp (VDef (DefId DatK d)) vl)) -> do - let fail1 = failDoc (text "expected" <+> prettyTCM t <+> text "to be a record type") --- DataSig { numPars, isTuple } <- lookupSymb d --- unless isTuple $ fail1 - mfs <- getFieldsAtType d vl - case mfs of - Nothing -> fail1 - Just ptv -> do - let checkField :: (Name, Expr) -> TypeCheck (Kinded [(Name,Expr)]) -> TypeCheck (Kinded [(Name,Expr)]) - checkField (p,e) cont = - case lookup p ptv of - Nothing -> failDoc (prettyTCM p <+> text "is not a field of record" <+> prettyTCM t) - Just tv -> do - tv <- piApp tv VIrr -- remove record argument (cannot be dependent!) - Kinded k e <- checkExpr e tv - Kinded k' es <- cont - return $ Kinded (unionKind k k') ((p,e) : es) - Kinded k rs <- foldr checkField (return $ Kinded NoKind []) rs - return $ Kinded k $ Record ri rs - - -{- OLD: -Following Awodey/Bauer 2001, the following rule is valid - - Gamma, x:A |- t : B Gamma, x:A, y:A |- t = t[y/x] : B - -------------------------------------------------------- - Gamma |- \xt : Pi x:[A]. B - - (Lam _ y e1, VPi dec x va env t1) -> do - rho <- getEnv -- get the environment corresponding to Gamma - new y (Domain va (resurrectDec dec)) $ \ vy -> do - v_t1 <- whnf (update env x vy) t1 - -- traceCheckM $ "checking " ++ show e1 ++ " : " ++ show v_t1 - e1e <- checkExpr e1 v_t1 - when (erased dec) $ do -- now check invariance of the e1 - new y (Domain va (resurrectDec dec)) $ \ vy' -> do - ve <- whnf (update rho y vy) e1e - ve' <- whnf (update rho y vy') e1e - eqVal v_t1 ve ve' -- BUT: ve' does not have type v_t1 !? - -- prune the lambda if body has been pruned - return $ if e1e==Irr then Irr else Lam y e1e - -} - --- NOW just my rule (LICS 2010 draft) a la Barras/Bernardo - - (Lam _ y e1, VQuant Pi x dom fv) -> do - -- rho <- getEnv -- get the environment corresponding to Gamma - underAbs y dom fv $ \ _ vy bv -> do - -- traceCheckM $ "checking " ++ show e1 ++ " : " ++ show v_t1 - Kinded ki1 e1e <- checkExpr e1 bv - -- the kind of a lambda is the kind of its body - return $ Kinded ki1 $ Lam (decor dom) y e1e - - -- lone projection: eta-expand! - (Proj Pre p, VQuant Pi x dom fv) -> do - let y = nonEmptyName x "y" - checkForced (Lam (decor dom) y $ App e (Var y)) v -{- - -- should be subsumed by checkBelow: - (e, v) | isVSize v -> Kinded kSize <$> checkSize e --} -{- MOVED to checkSize - - -- metavariables must have type size - (Meta i, _) | isVSize v -> do - addMeta ren i - return $ Kinded kSize $ Meta i - - (Infty, v) | isVSize v -> return $ Kinded kSize $ Infty - (Zero, v) | isVSize v -> return $ Kinded kSize $ Zero - - (Plus es, v) | isVSize v -> do - ese <- mapM checkSize es - return $ Kinded kSize $ Plus ese - - (Max es, v) | isVSize v -> do - ese <- mapM checkSize es - return $ Kinded kSize $ Max ese - - (Succ e2, v) | isVSize v -> do - e2e <- checkSize e2 - return $ Kinded kSize $ Succ e2e --} - - (e, VBelow ltle v) -> Kinded kSize <$> checkBelow e ltle v -{- - -- prune sizes - return $ if e2e==Irr then Irr else Succ e2e --} - (e,v) -> do - case spineView e of - - -- unfold defined patterns - (h@(Def (DefId (ConK DefPat) c)), es) -> do - PatSig xs pat _ <- lookupSymbQ c - let (xs1, xs2) = splitAt (length es) xs - phi x = maybe (Var x) id $ lookup x (zip xs1 es) - body = parSubst phi (patternToExpr pat) - e = foldr (Lam defaultDec) body xs2 - checkForced e v - - -- check constructor term - (h@(Def (DefId (ConK co) c)), es) -> checkConTerm co c es v -{- - (h@(Def (DefId (ConK co) c)), es) -> do - tv <- conType c v - (knes, dv) <- checkSpine es tv - let e = foldl App h $ map (snd . valueOf) knes - checkSubtype e dv v - e <- etaExpandPis e dv -- a bit similiar to checkSubtype, which computes a singleton - return $ Kinded kTerm $ e --} - -- else infer - _ -> do - (v2,kee) <- inferExpr e - checkSubtype (valueOf kee) v2 v - return kee - --- | Check (partially applied) constructor term, eta-expand it and turn it --- into a named record. -checkConTerm :: ConK -> QName -> [Expr] -> TVal -> TypeCheck (Kinded Extr) -checkConTerm co c es v = do - case v of - VQuant Pi x dom fv -> do - let y = freshen $ nonEmptyName x "y" - underAbs y dom fv $ \ _ _ bv -> do - Kinded ki ee <- checkConTerm co c (es ++ [Var y]) bv - return $ Kinded ki $ Lam (decor dom) y ee - _ -> do - c <- disambigCon c v - tv <- conType c v - (knes, dv) <- checkSpine es tv - let ee = Record (NamedRec co c False notDotted) $ map valueOf knes - checkSubtype ee dv v - return $ Kinded kTerm ee - -{- --- | Check (partially applied) constructor term, eta-expand it and turn it --- into a named record. -checkConTerm :: ConK -> Name -> [Expr] -> TVal -> TypeCheck (Kinded Extr) -checkConTerm co c es v = do - tv <- conType c v - (knes, dv) <- checkSpine es tv - let e0 = foldl App (Def (DefId (ConK co) c)) $ map (snd . valueOf) knes - checkSubtype e0 dv v - (vTel, _) <- telView dv - let xs = map (boundName . snd) vTel - decs = map (decor . boundDom . snd) vTel - ys = map freshen xs - rs = map valueOf knes ++ (zip xs $ map Var ys) - e1 = Record (NamedRec co c False) rs - e = foldr (uncurry Lam) e1 (zip decs ys) - return $ Kinded kTerm e --} - -{- --- | Only eta-expand at function types, do not force. -etaExpandPis :: Expr -> TVal -> TypeCheck Expr -etaExpandPis e tv = do - case tv of - VQuant Pi x dom env b -> new x dom $ \ xv -> do - let y = freshen x - Lam (decor dom) y <$> do - etaExpandPis (App e (Var y)) =<< whnf (update env x xv) b - _ -> return e --} - -checkSpine :: [Expr] -> TVal -> TypeCheck ([Kinded (Name, Extr)], TVal) -checkSpine [] tv = return ([], tv) -checkSpine (e : es) tv = do - (kne, tv) <- checkApp e tv - (knes, tv) <- checkSpine es tv - return (kne : knes, tv) - -maybeErase dec = if erased dec then erasedExpr else id - --- | checking e against (x : A) -> B returns (x,e) and B[e/x] -checkApp :: Expr -> TVal -> TypeCheck (Kinded (Name, Extr), TVal) -checkApp e2 v = do - v <- force v -- if v is a corecursively defined type in Set, unfold! - enter ("checkApp " ++ show v ++ " eliminated by " ++ show e2) $ do - case v of - VQuant Pi x dom@(Domain av@(VBelow Lt VInfty) _ dec) fv -> do - upperSemi <- underAbs x dom fv $ \ i _ bv -> upperSemiCont i bv - continue $ if upperSemi then VQuant Pi x dom{ typ = VBelow Le VInfty} fv - else v - _ -> continue v - where - continue v = case v of - VQuant Pi x (Domain av _ dec) fv -> do - (ki, v2, e2e) <- do - if inferable e2 then do - -- if e2 has a singleton type, we should not take v2 = whnf e2 - -- but use the single value of e2 - -- this is against the spirit of bidir. checking - -- if checking a type we need to resurrect - (av', Kinded ki e2e) <- applyDec dec $ inferExpr e2 - case av' of - VSing v2 av'' -> do subtype av' av - return (ki, v2, e2e) - _ -> do checkSubtype e2e av' av - v2 <- whnf' e2e - return (ki, v2, e2e) - else do - Kinded ki e2e <- applyDec dec $ checkExpr e2 av - v2 <- whnf' e2e - return (ki, v2, e2e) - bv <- app fv v2 - -- the kind of the application is the kind of its head - return (Kinded ki $ (x,) $ maybeErase dec e2e, bv) - -- if e1e==Irr then Irr else if e2e==Irr then e1e else App e1e [e2e]) - _ -> throwErrorMsg $ "checking application to " ++ show e2 ++ ": expected function type, found " ++ show v - - --- checkSubtype expr : infered_type <= ascribed_type -checkSubtype :: Expr -> TVal -> TVal -> TypeCheck () -checkSubtype e v2 v = do - rho <- getEnv - traceSingM $ "computing singleton <" ++ show e ++ " : " ++ show v2 ++ ">" -- ++ " in environment " ++ show rho - v2principal <- sing rho e v2 - traceSingM $ "subtype checking " ++ show v2principal ++ " ?<= " ++ show v ++ " in environment " ++ show rho - subtype v2principal v - - --- ptsRule s1 s2 = s if (s1,s2,s) is a valid rule --- precondition: s1,s2 are proper sorts, i.e., not Size or Tm -ptsRule :: Bool -> Sort Val -> Sort Val -> TypeCheck (Sort Val) -ptsRule er s1 s2 = do - cxt <- ask - let parametric = checkingConType cxt -- are we dealing with a parametric pi? - let err = "ptsRule " ++ show (s1,s2) ++ " " ++ (if parametric then "(in type of constructor)" else "") ++ ": " - case (s1,s2) of - (Set VInfty,_) -> throwErrorMsg $ err ++ "domain too big" - (Set v1, Set v2) -> - if parametric then do - unless er $ leqSize Pos v1 v2 -- when we are checking a constructor, to reject - {- data Bad : Set { bad : Set -> Bad } -} - return s2 - else return $ Set $ maxSize [v1,v2] - (CoSet v1, Set VZero) - | parametric -> return $ CoSet v1 - | v1 == VInfty -> return $ Set VZero - | otherwise -> throwErrorMsg $ err ++ "domain cannot be sized" - (CoSet v1, CoSet v2) - | parametric -> do - let v2' = maybe v2 id $ predSize v2 - case minSize v1 v2 of - Just v -> return $ CoSet v - Nothing -> throwErrorMsg $ err ++ "min" ++ show (v1,v2) ++ " does not exist" - | v1 == VInfty -> return $ CoSet $ succSize v2 - | otherwise -> throwErrorMsg $ err ++ "domain cannot be sized" - _ -> return s2 - -checkOrInfer :: Dec -> Expr -> Maybe Type -> TypeCheck (TVal, EType, Kinded Extr) -checkOrInfer dec e Nothing = do - (tv, ke) <- applyDec dec $ inferExpr e - te <- toExpr tv - return (tv, te, ke) -checkOrInfer dec e (Just t) = do - Kinded kt te <- checkType t - tv <- whnf' te - Kinded ke ee <- applyDec dec $ checkExpr e tv - let ki = intersectKind ke $ predKind kt - return $ (tv, te, Kinded ki ee) - --- inferType t = (s, te) -inferType :: Expr -> TypeCheck (Sort Val, Kinded Extr) -inferType t = do - (sv, te) <- inferExpr t - case sv of - VSort s | not (s `elem` map SortC [Tm,Size]) -> return (s,te) - _ -> throwErrorMsg $ "inferExpr: expected " ++ show t ++ " to be a type!" - --- inferExpr e = (tv, s, ee) --- input : expr e | inferable e --- output: type tv, kind s, and erased form ee of e --- the kind tells whether e is a term, a size, a set, ... -inferExpr :: Expr -> TypeCheck (TVal, Kinded Extr) -inferExpr e = do - (tv, ee) <- inferExpr' e - case tv of - VGuard beta vb -> do - checkGuard beta - return (vb, ee) - _ -> return (tv, ee) - -inferProj :: Expr -> PrePost -> Name -> TypeCheck (TVal, Kinded Extr) -inferProj e1 fx p = checkingCon False $ do - (v, Kinded ki1 e1e) <- inferExpr e1 -{- - let fail1 = failDoc (text "expected" <+> prettyTCM e1 <+> text "to be of record type when taking the projection" <+> text p <> comma <+> text "but found type" <+> prettyTCM v) - let fail2 = failDoc (text "record" <+> prettyTCM e1 <+> text "of type" <+> prettyTCM v <+> text "does not have field" <+> text p) --} - v <- force v -- if v is a corecursively defined type in Set, unfold! - tv <- projectType v p =<< whnf' e1e - return (tv, Kinded ki1 (proj e1e fx p)) -{- - case v of - VApp (VDef (DefId Dat d)) vl -> do - mfs <- getFieldsAtType d vl - case mfs of - Nothing -> fail1 - Just ptvs -> - case lookup p ptvs of - Nothing -> fail2 - Just tv -> do - tv <- piApp tv VIrr -- cut of record arg - return (tv, Kinded ki1 (App e1e (Proj p))) - _ -> fail1 --} - - --- inferExpr' might return a VGuard, this is removed in inferExpr --- the returned kind for constructor type is computed as the union --- of the kinds of the non-erased arguments --- otherwise it is the kind of the target -inferExpr' :: Expr -> TypeCheck (TVal, Kinded Extr) -inferExpr' e = enter ("inferExpr' " ++ show e) $ - let returnSing (Kinded ki ee) tv = do - tv' <- sing' ee tv - return (tv', Kinded ki ee) - in - (case e of - - Var x -> do - traceCheckM ("infer variable " ++ show x) - item <- lookupName1 x - traceCheckM ("infer variable: retrieved item ") - let dom = domain item - av = typ dom - traceCheckM ("infer variable: " ++ show av) - enterDoc (text "inferExpr: variable" <+> prettyTCM x <+> colon <+> prettyTCM av <+> text "may not occur") $ do - let dec = decor dom - udec = upperDec item - pol = polarity dec - upol = polarity udec - when (erased dec && not (erased udec)) $ - recoverFail ", because it is marked as erased" - enter ", because of polarity" $ - leqPolM pol upol - traceCheckM ("infer variable returns") - traceCheckM ("infer variable " ++ show x ++ " : " ++ show av) - return $ (av, Kinded (kind dom) $ Var x) -{- - let err = "inferExpr: variable " ++ x ++ " : " ++ show (typ item) ++ - " may not occur" - let dec = decor item - let pol = polarity dec - if erased dec then - throwErrorMsg $ err ++ ", because it is marked as erased" - else if not (leqPol pol SPos) then - throwErrorMsg $ err ++ ", because it has polarity " ++ show pol - else do - -- traceCheckM ("infer variable " ++ x ++ " : " ++ show (typ item)) - return $ (typ item, Var x) -- TODO: (typ item, kind item, Var x) --} - - -- for constants, the kind coincides with the type! - Sort (CoSet e) -> do - ee <- checkSize e - return (VSort (Set (VSucc VZero)), Kinded (kUniv Zero) $ Sort $ CoSet ee) - Sort (Set e) -> do - (v, ee) <- checkLevel e - return (VSort (Set (succSize v)), Kinded (kUniv ee) $ Sort $ Set ee) - Sort (SortC Size) -> return (vTSize, Kinded kTSize $ e) - Zero -> return (vSize, Kinded kSize Zero) - Infty -> return (vSize, Kinded kSize Infty) - Below ltle e -> do - ee <- checkSize e - return (vTSize, Kinded kTSize $ Below ltle ee) - - Quant pisig (TBind n (Domain t1 _ dec)) t2 -> do - -- make sure that in a constructor declaration the constructor args are - -- mixed-variant (there is no subtyping between constrs anyway) - checkCon <- asks checkingConType -{- TODO - when (checkCon && polarity dec /= Mixed) $ - throwErrorMsg $ "constructor arguments must be declared mixed-variant" --} - (s1, Kinded ki0 t1e) <- (if pisig==Pi then checkingDom else id) $ - checkingCon False $ inferType t1 -- switch off parametric Pi - -- the kind of the bound variable is the precedessor of the kind of its type - let ki1 = predKind ki0 - addBind (TBind n (Domain t1e ki1 $ defaultDec)) $ do -- ignore erasure flag AND polarity in Pi! (except for irrelevant, only becomes parametric) - -- TODO: - -- addBind (TBind n (Domain t1e ki1 $ coDomainDec dec)) $ do -- ignore erasure flag AND polarity in Pi! (except for irrelevant, only becomes parametric) - (s2, Kinded ki2 t2e) <- inferType t2 - ce <- ask - let er = erased dec - s <- if impredicative ce && er && s2 == Set VZero then return s2 else ptsRule er s1 s2 -- Impredicativity! - -- improve erasure annotation: irrelevant arguments can be erased! - let (ki',dec') = if checkCon then - -- in case of constructor types the kind is the union - -- of the kinds of the constructor arguments - if ki0 == kTSize then (ki2, irrelevantDec) - else if erased dec then (ki2, dec) -- do not count erased args in - else (unionKind ki0 ki2, dec) - else (ki2, if argKind ki0 `irrelevantFor` (predKind ki2) - then irrelevantDec - else dec) - -- the kind of the Pi-type is the kind of its target (codomain) - return (VSort s, Kinded ki' $ Quant pisig (TBind n (Domain t1e ki1 dec')) t2e) - - Quant Pi (TMeasure (Measure mu)) t2 -> do - mue <- mapM checkSize mu - (s, Kinded ki2 t2e) <- inferType t2 - return (VSort s, Kinded ki2 $ Quant Pi (TMeasure (Measure mue)) t2e) - - Quant Pi (TBound (Bound ltle (Measure mu) (Measure mu'))) t2 -> do - (mue,mue') <- checkingDom $ do - mue <- checkingDom $ mapM checkSize mu - mue' <- mapM checkSize mu' - return (mue,mue') - (s, Kinded ki2 t2e) <- inferType t2 - return (VSort s, Kinded ki2 $ Quant Pi (TBound (Bound ltle (Measure mue) (Measure mue'))) t2e) - - Sing e1 t -> do - (s, Kinded ki te) <- inferType t - tv <- whnf' te - Kinded ki1 e1e <- checkExpr e1 tv - return (VSort $ s, Kinded (intersectKind ki $ succKind ki1) -- not sure how useful the intersection is, maybe just ki is good enough - $ Sing e1e te) - -{- Not safe to infer pairs because of irrelevance! - Pair e1 e2 -> do - (tv1, Kinded k1 e1) <- inferExpr e1 - (tv2, Kinded k2 e2) <- inferExpr e2 - let ki = unionKind k1 k2 - tv = prod tv1 tv2 - return (tv, Kinded ki $ Pair e1 e2) --} - - App (Proj Pre p) e -> inferProj e Pre p - App e (Proj Post p) -> inferProj e Post p - - App e1 e2 -> checkingCon False $ do - (v, Kinded ki1 e1e) <- inferExpr e1 - (Kinded ki2 (_, e2e), bv) <- checkApp e2 v - -- the kind of the application is the kind of its head - return (bv, Kinded ki1 $ App e1e e2e) -{- - v <- force v -- if v is a corecursively defined type in Set, unfold! - case v of - VQuant Pi x (Domain av _ dec) env b -> do - (v2,e2e) <- - if inferable e2 then do - -- if e2 has a singleton type, we should not take v2 = whnf e2 - -- but use the single value of e2 - -- this is against the spirit of bidir. checking - -- if checking a type we need to resurrect - (av', Kinded _ e2e) <- applyDec dec $ inferExpr e2 - case av' of - VSing v2 av'' -> do subtype av' av - return (v2,e2e) - _ -> do checkSubtype e2e av' av - v2 <- whnf' e2e - return (v2, e2e) - else do - Kinded _ e2e <- applyDec dec $ checkExpr e2 av - v2 <- whnf' e2 - return (v2, e2e) - bv <- whnf (update env x v2) b - -- the kind of the application is the kind of its head - return (bv, Kinded ki1 $ App e1e (if erased dec then erasedExpr e2e else e2e)) --- if e1e==Irr then Irr else if e2e==Irr then e1e else App e1e [e2e]) - _ -> throwErrorMsg $ "inferExpr : expected Pi with expression : " ++ show e1 ++ "," ++ show v --} - --- App e1 (e2:el) -> inferExpr $ (e1 `App` [e2]) `App` el - -- 2012-01-22 no longer infer constructors - (Def id@(DefId {idKind, idName = name})) | not (conKind idKind) -> do -- traceCheckM ("infer defined head " ++ show n) - mitem <- errorToMaybe $ lookupName1 $ unqual name - case mitem of -- first check if it is also a var name - Just item -> do -- we are inside a mutual declaration (not erased!) - let pol = (polarity $ decor $ domain item) - let upol = (polarity $ upperDec item) - mId <- asks checkingMutualName - case mId of - Just srcId -> - -- we are checking constructors or function bodies - addPosEdge srcId id upol - Nothing -> - -- we are checking signatures - enter ("recursive occurrence of " ++ show name ++ " not strictly positive") $ - leqPolM pol upol - return (typ $ domain item, Kinded (kind $ domain item) $ e) - Nothing -> -- otherwise, it is not the data type name just being defined - do sige <- lookupSymbQ name - case sige of - -- data types have always kind Set 0! - (DataSig { symbTyp = tv }) -> return (tv, Kinded (symbolKind sige) e) - (FunSig { symbTyp = tv }) -> return (tv, Kinded (symbolKind sige) e) - -- constructors are always terms - (ConSig { symbTyp = tv }) -> returnSing (Kinded kTerm e) tv -- constructors have sing.type! - (LetSig { symbTyp = tv }) -> return (tv, Kinded (symbolKind sige) e) -- return $ vSing v tv -{- - (Con _ n) -> do sig <- gets signature - case (lookupSig n sig) of - (Let n) -> do sig <- gets signature - case (lookupSig n sig) of --} - _ -> throwErrorMsg $ "cannot infer type of " ++ show e - ) >>= \ tv -> ask >>= \ ce -> - traceCheck ("inferExpr: " ++ show (renaming ce) ++ ";" ++ show (context ce) ++ " |- " ++ show e ++ " :=> " ++ show tv ++ " in env" ++ show (environ ce)) $ --- traceCheck ("inferExpr: " ++ show e ++ " :=> " ++ show tv) $ - return tv - - -{- BAD IDEA! -improveDec :: Dec -> TVal -> Dec -improveDec dec v = if v == VSet || v == VSize then erased else dec --} - -{- --- entry point 3: resurrects -checkType :: Expr -> TypeCheck Extr -checkType e = (resurrect $ checkType' e) `throwTrace` ("not a type: " ++ show e ) - -checkType' :: Expr -> TypeCheck Extr -checkType' e = case e of - Sort s -> return e - Pi dec x t1 t2 -> do - t1e <- checkType' t1 - -- ignore erasure flag in types! --- t1v <- whnf' t1e --- new' x (Domain (Dec False) t1v) $ do - addBind x (Dec False) t1e $ do - t2e <- checkType' t2 - return $ Pi dec x t1e t2e -- Pi (improveDec dec t1v) x t1e t2e - _ -> checkExpr' e $ VSort Set --} - -checkType :: Expr -> TypeCheck (Kinded Extr) -checkType t = - enter ("not a type: " ++ show t) $ - resurrect $ do - (s, te) <- inferType t - leqSort Pos s (Set VInfty) - return te - -checkSmallType :: Expr -> TypeCheck (Kinded Extr) -checkSmallType t = - enter ("not a set: " ++ show t) $ - resurrect $ do - (s, te) <- inferType t - case s of - Set VZero -> return te - CoSet{} -> return te - _ -> throwErrorMsg $ "expected " ++ show s ++ " to be Set or CoSet _" - -{- --- small type -checkSmallType :: Expr -> TypeCheck Extr -checkSmallType e = (resurrect $ checkExpr' e $ VSort Set) `throwTrace` ("not a set: " ++ show e ) --} - --- check telescope and add bindings to contexts -checkTele :: Telescope -> TypeCheck a -> TypeCheck (ETelescope, a) -checkTele (Telescope tel) k = loop tel where - loop tel = case tel of - [] -> (emptyTel,) <$> k - tb@(TBind x (Domain t _ dec)) : tel -> do - Kinded ki te <- checkType t - let tb = TBind x (Domain te (predKind ki) dec) - (tel, a) <- addBind tb $ loop tel - return (Telescope $ tb : telescope tel, a) - --- the integer argument is the number of the clause, used just for user feedback -checkCases :: Val -> TVal -> [Clause] -> TypeCheck (Kinded [EClause]) -checkCases = checkCases' 1 - -checkCases' :: Int -> Val -> TVal -> [Clause] -> TypeCheck (Kinded [EClause]) -checkCases' i v tv [] = return $ Kinded NoKind [] -checkCases' i v tv (c : cl) = do - Kinded k1 ce <- checkCase i v tv c - Kinded k2 cle <- checkCases' (i + 1) v tv cl - return $ Kinded (unionKind k1 k2) $ ce : cle - -checkCase :: Int -> Val -> TVal -> Clause -> TypeCheck (Kinded EClause) -checkCase i v tv cl@(Clause _ [p] mrhs) = enter ("case " ++ show i) $ - -- traceCheck ("checking case " ++ show i) $ - do - -- clearDots -- NOT NEEDED - (flex,ins,cxt,vt,pe,pv,absp) <- checkPattern neutral [] emptySub tv p - local (\ _ -> cxt) $ do - mapM (checkGoal ins) flex - tel <- getContextTele -- TODO! - case (absp,mrhs) of - (True,Nothing) -> return $ Kinded NoKind (Clause tel [pe] Nothing) - (False,Nothing) -> throwErrorMsg ("missing right hand side in case " ++ showCase cl) - (True,Just rhs) -> throwErrorMsg ("absurd pattern requires no right hand side in case " ++ showCase cl) - (False,Just rhs) -> do - -- pv <- whnf' (patternToExpr p) -- DIFFICULT FOR DOT PATTERNS! - -- vp <- patternToVal p -- BUG: INTRODUCES FRESH GENS, BUT THEY HAVE ALREADY BEEN INTRODUCED IN checkPattern - addRewrite (Rewrite v pv) [vt] $ \ [vt'] -> do - Kinded ki rhse <- checkRHS ins rhs vt' - return $ Kinded ki (Clause tel [pe] (Just rhse)) - -- [rhs'] <- solveAndModify [rhs] (environ cxt) - -- return (Clause [p] rhs') - --- type check a function - -checkFun :: Type -> [Clause] -> TypeCheck (Kinded [EClause]) -checkFun t cl = do - tv <- whnf' t - checkClauses tv cl - --- the integer argument is the number of the clause, used just for user feedback -checkClauses :: TVal -> [Clause] -> TypeCheck (Kinded [EClause]) -checkClauses = checkClauses' 1 - -checkClauses' :: Int -> TVal -> [Clause] -> TypeCheck (Kinded [EClause]) -checkClauses' i tv [] = return $ Kinded NoKind ([]) -checkClauses' i tv (c:cl) = do - Kinded ki1 ce <- checkClause i tv c - Kinded ki2 cle <- checkClauses' (i + 1) tv cl - return $ Kinded (unionKind ki1 ki2) $ (ce : cle) - --- checkClause i tv cl = (cl', cle) --- checking one equation cl of a function at type tv --- solve size constraints --- substitute solution into clause, resulting in cl' --- return also extracted clause cle -checkClause :: Int -> TVal -> Clause -> TypeCheck (Kinded EClause) -checkClause i tv cl@(Clause _ pl mrhs) = enter ("clause " ++ show i) $ do - -- traceCheck ("checking function clause " ++ show i) $ - -- clearDots -- NOT NEEDED - (flex,ins,cxt,tv0,ple,plv,absp) <- checkPatterns neutral [] emptySub tv pl - -- 2013-03-30 When checking the rhs, we only allow new size hypotheses - -- if they do not break any valuation of the existing hypotheses. - -- See ICFP 2013 paper. - -- We exclude cofuns here, for experimentation. - -- Note that cofuns need not be SN, so the strict consistency may be - -- not necessary. - local (\ _ -> cxt { consistencyCheck = (mutualCo cxt == Ind) }) $ do - mapM (checkGoal ins) flex -{- - dots <- openDots - unless (null dots) $ - recoverFailDoc $ text "the following dotted constructors could not be confirmed: " <+> prettyTCM dots --} - -- TODO: insert meta var solution in dot patterns - tel <- getContextTele -- WRONG TELE, has VGens for DotPs - case (absp,mrhs) of - (True,Nothing) -> return $ Kinded NoKind (Clause tel ple Nothing) - (False,Nothing) -> throwErrorMsg ("missing right hand side in clause " ++ show cl) - (True,Just rhs) -> throwErrorMsg ("absurd pattern requires no right hand side in clause " ++ show cl) - (False,Just rhs) -> do - Kinded ki rhse <- checkRHS ins rhs tv0 - env <- getEnv - [rhse] <- solveAndModify [rhse] env - return $ Kinded ki (Clause tel ple (Just rhse)) - - --- * Pattern checking ------------------------------------------------ - -type Substitution = Valuation -- [(Int,Val)] - -emptySub = emptyVal -sgSub = sgVal -lookupSub i = lookup i . valuation - -type DotFlex = (Int,(Expr,Domain)) - --- left over goals -data Goal - = DotFlex Int (Maybe Expr) Domain - -- ^ @Just@ : Flexible variable from inaccessible pattern. - -- ^ @Nothing@ : Flexible variable from hidden function type. - | MaxMatches Int TVal - | DottedCons Dotted Pattern TVal - deriving Show - --- checkPatterns is initially called with an empty local context --- in the type checking monad -checkPatterns :: Dec -> [Goal] -> Substitution -> TVal -> [Pattern] -> TypeCheck ([Goal],Substitution,TCContext,TVal,[EPattern],[Val],Bool) -checkPatterns dec0 flex ins v pl = - case v of - VMeasured mu vb -> setMeasure mu $ checkPatterns dec0 flex ins vb pl - VGuard beta vb -> addBoundHyp beta $ checkPatterns dec0 flex ins vb pl -{- - VGuard beta vb -> throwErrorMsg $ "checkPattern at type " ++ show v ++ " --- introduction of constraints not supported" --} - _ -> case pl of - [] -> do cxt <- ask - return (flex,ins,cxt,v,[],[],False) - (p:pl') -> do (flex',ins',cxt',v',pe,pv,absp) <- checkPattern dec0 flex ins v p - local (\ _ -> cxt') $ do - (flex'',ins'',cxt'',v'',ple,plv,absps) <- checkPatterns dec0 flex' ins' v' pl' - return (flex'',ins'',cxt'',v'', pe:ple, pv:plv, absp || absps) -- if pe==IrrP then ple else pe:ple) - -{- -checkPattern dec0 flex subst tv p = (flex', subst', cxt', tv', pe, pv, absp) - -Input : - dec0 : context in which pattern occurs (irrelevant, parametric, recursive) - are we checking an erased argument? (constr. pat. needs to be forced!) - flex : list of pairs (flexible variable, its dot pattern + supposed type) - subst : list of pairs (flexible variable, its valuation) - cxt : in monad, containing - rho : binding of variables to values - delta : binding of generic values to their types - tv : type of the expression \ p -> t - p : the pattern to check - -Output - tv' : type of t - pe : erased pattern - pv : value of pattern (this is in essence whnf' pe, - but we cannot evaluate because of dot patterns) - absp : did we encounter an absurd pattern --} - -checkPattern :: Dec -> [Goal] -> Substitution -> TVal -> Pattern -> TypeCheck ([Goal],Substitution,TCContext,TVal,EPattern,Val,Bool) -checkPattern dec0 flex ins tv p = -- ask >>= \ TCContext { context = delta, environ = rho } -> trace ("checkPattern" ++ ("\n dot pats: " +?+ show flex) ++ ("\n substion: " +?+ show ins) ++ ("\n environ : " +?+ show rho) ++ ("\n context : " +?+ show delta) ++ "\n pattern : " ++ show p ++ "\n at type : " ++ show tv ++ "\t<>") $ - enter ("pattern " ++ show p) $ do - tv <- force tv - case tv of - -- record type can be eliminated - VApp (VDef (DefId DatK d)) vl -> - case p of - ProjP proj -> do - tv <- projectType tv proj VIrr -- do not have record value here - cxt <- ask - return (flex, ins, cxt, tv, p, VProj Post proj, False) -{- - mfs <- getFieldsAtType d vl - case mfs of - Nothing -> failDoc (text "cannot eliminate type" <+> prettyTCM tv <+> text "with projection pattern" <+> prettyTCM p) - Just ptvs -> - case lookup proj ptvs of - Nothing -> failDoc (text "record type" <+> prettyTCM tv <+> text "does not know projection" <+> text proj) - Just tv -> do - tv <- piApp tv VIrr -- cut of record arg - cxt <- ask - return (flex, ins, cxt, tv, p, VProj proj, False) --} - _ -> failDoc (text "cannot eliminate type" <+> prettyTCM tv <+> text "with a non-projection pattern") - - -- intersection type - VQuant Pi x dom@(Domain av ki Hidden) fv -> do - -- introduce new flexible variable - newWithGen x dom $ \ i xv -> do - tv <- fv `app` xv - checkPattern dec0 (DotFlex i Nothing dom : flex) ins tv p - - -- function type can be eliminated - VQuant Pi x (Domain av ki dec) fv -> do -{- - let erased' = er || erased dec - let decEr = if erased' then irrelevantDec else dec -- dec {erased = erased'} --} - let decEr = dec `compose` dec0 - let domEr = (Domain av ki decEr) - case p of - - -- treat successor pattern here, because of admissibility check - SuccP p2 -> do - when (av /= vSize) $ throwErrorMsg "checkPattern: expected type Size" - when (isSuccessorPattern p2) $ cannotMatchDeep p tv - - co <- asks mutualCo - when (co /= CoInd) $ - throwErrorMsg ("successor pattern only allowed in cofun") - - enterDoc (text ("checkPattern " ++ show p ++" : matching on size, checking that target") <+> prettyTCM tv <+> text "ends in correct coinductive sized type") $ - underAbs x domEr fv $ \ i _ bv -> endsInSizedCo i bv - - cxt <- ask - -- 2012-02-05 assume size variable in SuccP to be < # - let sucTy = (vFinSize `arrow` vFinSize) - (flex',ins',cxt',tv',p2e,p2v,absp) <- checkPattern decEr flex ins sucTy p2 - -- leqVal Mixed delta' VSet VSize av -- av = VSize - let pe = SuccP p2e - let pv = VSucc p2v --- pv0 <- local (\ _ -> cxt') $ whnf' $ patternToExpr pe - -- pv0 <- patternToVal p -- RETIRE patternToVal - -- pv <- up False pv0 av -- STUPID what can be eta-exanded at type Size?? - vb <- app fv pv -{- - endsInCoind <- endsInSizedCo pv vb - when (not endsInCoind) $ throwErrorMsg $ "checkPattern " ++ show p ++" : cannot match on size since target " ++ show tv ++ " does not end in correct coinductive sized type" --} - return (flex',ins',cxt',vb,pe,pv,absp) - - -- other patterns: no need to know about result type - _ -> do - (flex',ins',cxt',pe,pv,absp) <- checkPattern' flex ins domEr p - -- traceM ("checkPattern' returns " ++ show (flex',ins',cxt',pe,pv,absp)) - vb <- app fv pv - vb <- substitute ins' vb -- from ConP case -- ?? why not first subst and then whnf? - -- traceCheckM ("Returning type " ++ show vb) - return (flex',ins',cxt',vb,pe,pv,absp) - - _ -> throwErrorMsg $ "checkPattern: expected function type, found " ++ show tv - --- TODO: refactor with monad transformers --- put absp into writer monad - -turnIntoVarPatAtUnitType :: TVal -> Pattern -> TypeCheck Pattern -turnIntoVarPatAtUnitType (VApp (VDef (DefId DatK n)) _) p@(ConP pi c []) = - flip (ifM $ isUnitData n) (return p) $ do - let x = fresh "un!t" - return $ VarP x -turnIntoVarPatAtUnitType _ p = return p - -checkPattern' :: [Goal] -> Substitution -> Domain -> Pattern -> TypeCheck ([Goal],Substitution,TCContext,EPattern,Val,Bool) -checkPattern' flex ins domEr@(Domain av ki decEr) p = do - p <- turnIntoVarPatAtUnitType av p - case p of - SuccP{} -> failDoc (text "successor pattern" <+> prettyTCM p <+> text "not allowed here") - - PairP p1 p2 -> do - av <- force av - case av of - VQuant Sigma y dom1@(Domain av1 ki1 dec1) fv -> do - (flex, ins, cxt, pe1, pv1, absp1) <- - checkPattern' flex ins (Domain av1 ki1 $ dec1 `compose` decEr) p1 - av2 <- app fv pv1 - (flex, ins, cxt, pe2, pv2, absp2) <- - local (const cxt) $ - checkPattern' flex ins (Domain av2 ki decEr) p2 - return (flex, ins, cxt, PairP pe1 pe2, VPair pv1 pv2, absp1 || absp2) - _ -> failDoc (text "pair pattern" <+> prettyTCM p <+> text "could not be checked against type" <+> prettyTCM av) -{- - (x : Sigma y:A. B) -> C - =iso= (y : A) -> (x' : B) -> C[(y,x')/x] - - (x : Sigma y:V. ) -> - =iso= (y : V) -> <(x': B) -> C; ?? x=(y,x')> - -} -{- - case av of - VQuant Sigma y dom1@(Domain av1 ki1 dec1) env1 a2 -> do - let x' = x ++ "#2" - ep = Pair (Var y) (Var x') - tv = VQuant Pi y dom1 env1 $ - Quant x' (Domain a2 --} - - ProjP proj -> failDoc (text "cannot eliminate type" <+> prettyTCM av <+> text "with projection pattern" <+> prettyTCM p) - - VarP y -> do - new y domEr $ \ xv -> do - cxt' <- ask - p' <- case av of - VBelow Lt v -> flip SizeP y <$> toExpr v - _ -> return p - return (flex, ins, cxt', maybeErase $ p', xv, False) - -{- checking bounded size patterns - - ex : [i : Size] -> [j : Below< i] -> ... - ex i (j < i) = ... - - type of pattern : Below< i needs to cover type of parameter Below< i - - zero : [j : Size] -> Nat $j -- need to hold a "sized con type" - zero : [j < i] -> Nat i - - ex : [i : Size] -> (n : Nat i) -> ... - ex i (zero (j < i) = ... - - type of size-pat : Below< i - --} - SizeP e y -> do -- pattern (z > y), y is the bound variable, z the bound of z - e <- resurrect $ checkSize e -- (Var z) - newWithGen y domEr $ \ j xv -> do -{- - VGen k <- whnf' (Var z) - addSizeRel j 1 k $ do -- j < k --} - ve <- whnf' e - addBoundHyp (Bound Lt (Measure [xv]) (Measure [ve])) $ do - subtype av (VBelow Lt ve) - cxt' <- ask - return (flex, ins, cxt', maybeErase $ SizeP e y, xv, False) - - AbsurdP -> do - when (isFunType av) $ throwErrorMsg ("absurd pattern " ++ show p ++ " does not match function types, like " ++ show av) - cxt' <- ask - return (MaxMatches 0 av : flex, ins, cxt', maybeErase $ AbsurdP, VIrr, True) -{- - cenvs <- matchingConstructors av -- TODO: av might be MVar - -- need to be postponed - case cenvs of - [] -> do bv <- whnf (update env x VIrr) b - cxt' <- ask - return (flex, ins, cxt', bv, maybeErase $ AbsurdP, True) - _ -> throwErrorMsg $ "type " ++ show av ++ " of absurd pattern not empty" --} - - -- always expand defined patterns! - p@(ConP pi n ps) | coPat pi == DefPat -> do - checkPattern' flex ins domEr =<< expandDefPat p - --- ConP pi n pl | not $ dottedPat pi -> do - ConP pi n pl -> do - - -- disambiguate constructor first - n <- disambigCon n av - - let co = coPat pi - dotted = dottedPat pi - - -- First check that we do not match against an irrelevant argument. - unless dotted $ nonDottedConstructorChecks n co pl -{- TODO - enter ("can only match non parametric arguments") $ - leqPolM (polarity dec) (pprod defaultPol) --} - (vc,(flex',ins',cxt',vc',ple,pvs,absp)) <- checkConstructorPattern co n pl - - when (isFunType vc') $ throwErrorMsg ("higher-order matching of pattern " ++ show p ++ " of type " ++ show vc' ++ " not allowed") - let flexgen = concat $ map (\ g -> case g of - DotFlex i _ _ -> [i] - _ -> []) flex' - -- fst $ unzip flex' --- av1 <- sing (environ cxt') (patternToExpr p) vc' --- av2 <- sing (environ cxt') (patternToExpr p) av --- subst <- local (\ _ -> cxt') $ inst flexgen VSet av1 av2 - - - -- need to evaluate the erased pattern! - let pe = ConP pi n ple -- erased pattern - -- dot <- if dottedPat pi then newDotted p else return notDotted - dot <- if dottedPat pi then mkDotted True else return notDotted - pv0 <- mkConVal dot co n pvs vc - -- OLD: let pv0 = VDef (DefId (ConK co) n) `VApp` pvs -{- - let epe = patternToExpr pe - pv0 <- local (\ _ -> cxt') $ whnf' epe --- pv0 <- patternToVal p -- THIS USE should be ok, since the new GENs are not in the global context yet, only in cxt' -- NO LONGER ok with erasure! - -- traceM $ "sucessfully computed value " ++ show pv0 ++ " of pattern " ++ show epe --} - - subst <- local (\ _ -> cxt') $ do - case av of -- TODO: need subtyping-unify instead of unify?? - VSing vav av0 -> do - vav <- whnfClos vav - inst Pos flexgen av0 pv0 vav - _ -> unifyIndices flexgen vc' av -- vc' <= av ?! - -- THIS IMPLEMENTATION RELIES HEAVILY ON INJECTIVITY OF DATAS - -{- moved to checkRHS - -- apply substitution to measures in environment - let mmu = (envBound . environ) cxt' - mmu' <- Traversable.mapM (substitute subst) mmu --} -{- - ins'' <- compSubst ins' subst - vb <- substitute ins'' vb - delta' <- substitute ins'' delta' --} - ins'' <- compSubst ins' subst -- 2010-07-27 not ok to switch! - delta'' <- substitute ins'' (context cxt') - traceCheckM $ "delta'' = " ++ show delta'' - av <- substitute ins'' av -- 2010-09-22: update av - pv <- up False pv0 av - - -- if the constructor was dotted, make sure it is the only match - let flex'' = fwhen dotted (DottedCons dot p av :) flex' - return (flex'', ins'', cxt' { context = delta'' }, - maybeErase pe, pv, absp) -{- DO NOT UPDATE measure here, its done in checkRHS - return (flex', ins'', cxt' { context = delta'', environ = (environ cxt') { envBound = mmu' } }, vb', - maybeErase pe, absp) --} - - -{- UNUSED - -- If we encounter a dotted constructor, we simply - -- compute the pattern variable context - -- and then treat the pattern as dot pattern. - p@(ConP pi n ps) | dottedPat pi -> do - (vc,(flex',ins',cxt',vc',ple,pvs,absp)) <- - checkConstructorPattern (coPat pi) n ps - local (const cxt') $ - checkPattern' flex ins domEr $ DotP $ patternToExpr p --} - - DotP e -> do - -- create an informative, but irrelevant identifier for dot pattern - let xp = fresh $ "." ++ case e of Var z -> suggestion z; _ -> Util.parens $ show e - newWithGen xp domEr $ \ k xv -> do - cxt' <- ask - -- traceCheck ("Returning type " ++ show vb) $ - return (DotFlex k (Just e) domEr : flex - ,ins - ,cxt' - ,maybeErase $ DotP e -- $ Var xp -- DotP $ Meta k -- e -- Meta k - -- ,maybeErase $ -- AbsurdP -- VarP $ show e - ,xv - ,False) -- TODO: Erase in e/ Meta subst! -{- original code - do let (k, delta') = cxtPush dec av delta - vb <- whnf (update env x (VGen k)) b - return ((k,(e,Domain av dec)):flex - ,ins - ,rho - ,delta' - ,vb) --} - - where - maybeErase p = if erased decEr then ErasedP p else p - - checkConstructorPattern co n pl = do - when (isFunType av) $ throwErrorMsg ("higher-order matching of pattern " ++ show p ++ " at type " ++ show av ++ " not allowed") --- TODO: ensure that matchings against erased arguments are forced --- when (erased dec) $ throwErrorMsg $ "checkPattern: cannot match on erased argument " ++ show p ++ " : " ++ show av - - ConSig {conPars, lhsTyp = sz, recOccs, symbTyp = vc, dataName, dataPars} <- lookupSymbQ n - - -- the following is a hack to still support old-style - -- add .($ i) (zero i) ... - -- fun defs: if (zero i) is matched against (Nat flexvar$i) - -- we use the old constructor type [i : Size] -> Nat $i - -- else, the new one [j < i] -> Nat i - let flexK k (DotFlex k' _ _) = k == k' - flexK k _ = False - -- use lhs con type only if sizeindex is not a rigid var - isFlex (VGen k) = List.any (flexK k) flex - isFlex _ = True - isSz = if co == Cons then sz else Nothing - vc <- instConLType n conPars vc isSz isFlex dataPars =<< force av -{- - vc <- case sz of - Nothing -> instConType n nPars vc =<< force av - Just vc -> instConType n (nPars+1) vc =<< force av --} - - -- (flex',ins',cxt',vc',ple,pvs,absp) <- - (vc,) <$> checkPatterns decEr flex ins vc pl - - - -- These checks are only relevant if a constructor is an actual match. - nonDottedConstructorChecks n co pl = do - ConSig {conPars, lhsTyp = sz, recOccs, symbTyp = vc, dataName, dataPars} <- lookupSymbQ n - - -- check that size argument of coconstr is dotted - when (co == CoCons && isJust sz) $ do - let sizep = head pl -- 2012-01-22: WAS (pl !! nPars) - unless (isDotPattern sizep) $ - throwErrorMsg $ "in pattern " ++ show p ++ ", coinductive size sub pattern " ++ show sizep ++ " must be dotted" - - when (not $ decEr `elem` map Dec [Const,Rec]) $ - recoverFail $ "cannot match pattern " ++ show p ++ " against non-computational argument" - -- check not to match non-trivially against erased stuff - when (decEr == Dec Const) $ do - let failNotForced = recoverFail $ "checkPattern: constructor " ++ show n ++ " of non-computational argument " ++ show p ++ " : " ++ show av ++ " not forced" - mcenvs <- matchingConstructors av - case mcenvs of - Nothing -> do -- now check whether dataName is a record type - DataSig { constructors } <- lookupSymb dataName - unless (length constructors == 1) $ failNotForced - return () - Just [] -> recoverFail $ "checkPattern: no constructor matches type " ++ show av - Just [(ci, _)] | cName ci == n -> return () - _ -> failNotForced - - - - -{- New treatment of size matching (see examples/Sized/Cody.ma) - -sized data O : Size -> Set -{ Z : [i : Size] -> O ($ i) -; S : [i : Size] -> O i -> O ($ i) -; L : [i : Size] -> (Nat -> O i) -> O ($ i) -; M : [i : Size] -> O i -> O i -> O ($ i) -} - -fun deep : [i : Size] -> O i -> Nat -> Nat -{ deep i4 (M i3 (L j2 f) (S i2 (S i1 (S i x)))) n - = deep _ (M _ (L _ (pre _ f)) (S _ (f n))) (succ (succ (succ n))) -; deep i x n = n -} - -Explicit form: Size variables and their constraints are noted explicitely, -to be able to do untyped call extraction in the termination module. - - deep i4 - (M (i4 > i3) - (L (i3 > j2) f) - (S (i3 > i2) - (S (i2 > i1) - (S (i1 > i) x)))) n - = deep _ (M _ (L _ (pre _ f)) (S _ (f n))) (succ (succ (succ n))) - -i4, i3, ... are all rigid variables with constraints between them. -There is a tree hierarchy, but I do not know whether I can exploit -this. - - i4 > i3 > i2 > i1 > i - > j3 - -This could be stored in a union-find-like data structure, or just in -the constraint matrix. - -How to pattern match? - - id : [i : Size] -> List i -> List i - id i (cons (i > j) x xs) = cons j x (id j xs) - -Only a size variable matches a size arguments - - match (cons (i > j) x xs) against List i - get cons : [j : Size] -> Nat -> List j -> List ($ j) - yield x : Nat, xs : List j, cons j x xs : List ($ j) - check List ($ j) <= List i - -} - -{- RETIRED --- checkDot does not need to extract -checkDot :: Substitution -> DotFlex -> TypeCheck () -checkDot subst (i,(e,it)) = enter ("dot pattern " ++ show e) $ - case (lookup i subst) of - Nothing -> throwErrorMsg $ "not instantiated" - Just v -> do - tv <- substitute subst (typ it) - ask >>= \ ce -> traceCheckM ("checking dot pattern " ++ show ce ++ " |- " ++ show e ++ " : " ++ show (decor it) ++ " " ++ show tv) - applyDec (decor it) $ do - checkExpr e tv - v' <- whnf' e -- TODO: has subst erased terms? - enter ("inferred value " ++ show v ++ " does not match given dot pattern value " ++ show v') $ - eqVal Pos tv v v' --} - --- checkDot does not need to extract --- 2012-01-25 now we do since "extraction" turns also con.terms into records -checkGoal :: Substitution -> Goal -> TypeCheck () -checkGoal subst (DotFlex i me it) = enter ("dot pattern " ++ show me) $ - case lookupSub i subst of - Nothing -> recoverFail $ "not instantiated" - Just v -> whenJust me $ \ e -> do - tv <- substitute subst (typ it) - ask >>= \ ce -> traceCheckM ("checking dot pattern " ++ show ce ++ " |- " ++ show e ++ " : " ++ show (decor it) ++ " " ++ show tv) --- applyDec (decor it) $ do - resurrect $ do -- consider a DotP e always as irrelevant! - e <- valueOf <$> checkExpr e tv - v' <- whnf' e -- TODO: has subst erased terms? - enterDoc (text "inferred value" <+> prettyTCM v <+> text "does not match given dot pattern value" <+> prettyTCM v') $ - leqVal Pos tv v v' -- WAS: eqVal -checkGoal subst (MaxMatches n av) = do - traceCheckM ("checkGoal _ $ MaxMatches " ++ show n ++ " $ " ++ show av) - av' <- substitute subst av - traceCheckM ("checkGoal _ $ MaxMatches " ++ show n ++ " $ " ++ show av') - -- av' <- reval av' - -- traceCheckM ("checkGoal: reevalutated " ++ show av') - mcenvs <- matchingConstructors av' - traceCheckM ("checkGoal matching constructors = " ++ show mcenvs) - maybe (recoverFail $ "not a data type: " ++ show av') - (\ cenvs -> - if length cenvs > n then recoverFail $ - if n==0 then "absurd pattern does not match since type " ++ show av' ++ " is not empty" - else - "more than one constructor matches type " ++ show av' - else return ()) - mcenvs -checkGoal subst (DottedCons dot p av) - | isDotted dot = - enterDoc (text "confirming dotted constructor" <+> prettyTCM p) $ do - checkGoal subst (MaxMatches 1 av) - | otherwise = return () - -checkRHS :: Substitution -> Expr -> TVal -> TypeCheck (Kinded Extr) -checkRHS ins rhs v = do - traceCheckM ("checking rhs " ++ show rhs ++ " : " ++ show v) - enter "right hand side" $ do - -- first update measure according to substitution for dot variables - cxt <- ask - let rho = environ cxt - mmu' <- Traversable.mapM (substitute ins) (envBound rho) - local (\ _ -> cxt { environ = rho { envBound = mmu' }}) $ - activateFuns $ - checkExpr rhs v - - - --- TODO type directed unification - --- unifyIndices flex tv1 tv2 --- tv1 = D pars inds is the type of the pattern --- tv2 = D pars' inds' is the type matched against --- Note that in this case we can unify without using the principle of --- injective data type constructors, --- we are only calling unifyIndices from the constructor pattern case --- in Checkpattern -unifyIndices :: [Int] -> Val -> Val -> TypeCheck Substitution -unifyIndices flex v1 v2 = ask >>= \ cxt -> enterDoc (text ("unifyIndices " ++ show (context cxt) ++ " |-") <+> prettyTCM v1 <+> text ("?<=" ++ show Pos) <+> prettyTCM v2) $ do --- {- - case (v1,v2) of - (VSing _ v1, VApp (VDef (DefId DatK d2)) vl2) -> - flip (unifyIndices flex) v2 =<< whnfClos v1 - (VApp (VDef (DefId DatK d1)) vl1, VApp (VDef (DefId DatK d2)) vl2) | d1 == d2 -> do - (DataSig { numPars = np, symbTyp = tv, positivity = posl}) <- lookupSymbQ d1 - instList posl flex tv vl1 vl2 -- unify also parameters to solve dot patterns - _ -> --- -} - inst Pos flex vTopSort v1 v2 --- throwErrorMsg ("unifyIndices " ++ show v1 ++ " =?= " ++ show v2 ++ " failed, not applied to data types") - --- unify, but first produce whnf -instWh :: Pol -> [Int] -> TVal -> Val -> Val -> TypeCheck Substitution -instWh pos flex tv w1 w2 = do - v1 <- whnfClos w1 - v2 <- whnfClos w2 - inst pos flex tv v1 v2 - --- | Check occurrence and return singleton substitution. -assignFlex :: Int -> Val -> TypeCheck Substitution -assignFlex k v = do - unlessM (nocc [k] v) $ - failDoc $ - text "variable " <+> prettyTCM (VGen k) <+> - text " may not occur in " <+> prettyTCM v - return $ sgSub k v - --- match v1 against v2 by unification , yielding a substition -inst :: Pol -> [Int] -> TVal -> Val -> Val -> TypeCheck Substitution -inst pos flex tv v1 v2 = ask >>= \ cxt -> enterDoc (text ("inst " ++ show (context cxt) ++ " |-") <+> prettyTCM v1 <+> text ("?<=" ++ show pos) <+> prettyTCM v2 <+> colon <+> prettyTCM tv) $ do --- case tv of --- (VPi dec x av env b) -> - case (v1,v2) of - (VGen k, VGen j) | k == j -> return emptySub - (VGen k, _) | elem k flex -> assignFlex k v2 - (_, VGen k) | elem k flex -> assignFlex k v1 - - -- injectivity of data type constructors is unsound in general - (VApp (VDef (DefId DatK d1)) vl1, - VApp (VDef (DefId DatK d2)) vl2) | d1 == d2 -> do - (DataSig { numPars, symbTyp = tv, positivity = posl }) <- lookupSymbQ d1 - instList' numPars posl flex tv vl1 vl2 - -- ignore parameters (first numPars args) - -- this is sound because we have irrelevance for parameters - -- we assume injectivity for indices - - -- Constructor applications are represented as VRecord - (VRecord (NamedRec _ c1 _ dot1) rs1, - VRecord (NamedRec _ c2 _ dot2) rs2) | c1 == c2 -> do - alignDotted dot1 dot2 - sige <- lookupSymbQ c1 - instList [] flex (symbTyp sige) (map snd rs1) (map snd rs2) - - (VSucc v1', VSucc v2') -> instWh pos flex tv v1' v2' - (VSucc v, VInfty) -> instWh pos flex tv v VInfty - (VSing v1' tv1, VSing v2' tv2) -> do - subst <- inst pos flex tv tv1 tv2 - u1 <- substitute subst v1' - u2 <- substitute subst v2' - tv1' <- substitute subst tv1 - inst pos flex tv1' u1 u2 >>= compSubst subst - --- HACK AHEAD - (VUp v1 _, _) -> inst pos flex tv v1 v2 - (_, VUp v2 _) -> inst pos flex tv v1 v2 --- (VUp v1' a1, VUp v2' a2) -> instList flex [a1,v1'] [a2,v2'] --- (VPi dec x1 av1 env1 b1, VPi dec x2 av2 env2 b2) -> - -{- TODO: REPAIR THIS - _ -> traceCheck ("inst: WARNING! assuming " ++ show (context cxt) ++ " |- " ++ show v1 ++ " == " ++ show v2) $ - return [] -- throwErrorMsg $ "inst: NYI" - -} - _ -> do leqVal pos tv v1 v2 `throwTrace` ("inst: leqVal " ++ show v1 ++ " ?<=" ++ show pos ++ " " ++ show v2 ++ " : " ++ show tv ++ " failed") - return emptySub - -instList :: [Pol] -> [Int] -> TVal -> [Val] -> [Val] -> TypeCheck Substitution -instList = instList' 0 - --- unify lists, ignoring the first np items -instList' :: Int -> [Pol] -> [Int] -> TVal -> [Val] -> [Val] -> TypeCheck Substitution -instList' np posl flex tv [] [] = return emptySub -instList' np posl flex tv (v1:vl1) (v2:vl2) = do - v1 <- whnfClos v1 - v2 <- whnfClos v2 - if (np <= 0 || isMeta flex v1 || isMeta flex v2) then - case tv of - (VQuant Pi x dom fv) -> do - let pol = getPol dom -- WAS: (headPosl posl) - subst <- inst pol flex (typ dom) v1 v2 - vl1' <- mapM (substitute subst) vl1 - vl2' <- mapM (substitute subst) vl2 - v <- substitute subst v1 - fv <- substitute subst fv - vb <- app fv v - subst' <- instList' (np - 1) (tailPosl posl) flex vb vl1' vl2' - compSubst subst subst' - else - case tv of - (VQuant Pi x dom fv) -> do - vb <- app fv v2 - instList' (np - 1) (tailPosl posl) flex vb vl1 vl2 -instList' np pos flex tv vl1 vl2 = throwErrorMsg $ "internal error: instList' " ++ show (np,pos,flex,tv,vl1,vl2) ++ " not handled" - -headPosl :: [Pol] -> Pol -headPosl [] = mixed -headPosl (pos:_) = pos - -tailPosl :: [Pol] -> [Pol] -tailPosl [] = [] -tailPosl (_:posl) = posl - - -isMeta :: [Int] -> Val -> Bool -isMeta flex (VGen k) = k `elem` flex -isMeta _ _ = False - ----------------------------------------------------------------------- --- * Substitution into values ----------------------------------------------------------------------- - --- | Overloaded substitution of values for generic values (free variables). -class Substitute a where - substitute :: Substitution -> a -> TypeCheck a - -instance Substitute v => Substitute (x,v) where - substitute subst (x,v) = (x,) <$> substitute subst v - -instance Substitute v => Substitute [v] where - substitute = mapM . substitute - -instance Substitute v => Substitute (Maybe v) where - substitute = Traversable.mapM . substitute - -instance Substitute v => Substitute (Map k v) where - substitute = Traversable.mapM . substitute - -instance Substitute v => Substitute (OneOrTwo v) where - substitute = Traversable.mapM . substitute - -instance Substitute v => Substitute (Dom v) where - substitute = Traversable.mapM . substitute - -instance Substitute v => Substitute (Measure v) where - substitute = Traversable.mapM . substitute - -instance Substitute v => Substitute (Bound v) where - substitute = Traversable.mapM . substitute - -instance Substitute v => Substitute (Sort v) where - substitute = Traversable.mapM . substitute - --- substitute generic variable in value -instance Substitute Val where - substitute subst v = do -- enterDoc (text "substitute" <$> prettyTCM v) $ do - let sub v = substitute subst v - case v of - VGen k -> return $ valuateGen k subst - VApp v1 vl -> foldM app ==<< (sub v1, sub vl) - VSing v1 vt -> vSing ==<< (sub v1, sub vt) -- TODO: Check reevaluation necessary? - - VSucc v1 -> succSize <$> substitute subst v1 - VMax vs -> maxSize <$> mapM (substitute subst) vs - VPlus vs -> plusSizes <$> mapM (substitute subst) vs - - VCase v1 tv1 env cl -> VCase <$> sub v1 <*> sub tv1 <*> sub env <*> return cl - VMeasured mu bv -> VMeasured <$> sub mu <*> sub bv - VGuard beta bv -> VGuard <$> sub beta <*> sub bv - - VBelow ltle v -> VBelow ltle <$> substitute subst v - - VQuant pisig x dom fv -> VQuant pisig x <$> sub dom <*> sub fv - VRecord ri rs -> VRecord ri <$> sub rs - VPair v1 v2 -> VPair <$> sub v1 <*> sub v2 - VProj{} -> return v - - VLam x env b -> flip (VLam x) b <$> sub env - VConst v -> VConst <$> sub v - VAbs x i v valu -> VAbs x i v <$> sub valu - VClos env e -> flip VClos e <$> sub env - VUp v1 vt -> up False ==<< (sub v1, sub vt) - VSort s -> VSort <$> sub s - VZero -> return $ v - VInfty -> return $ v - VIrr -> return $ v - VDef id -> return $ vDef id -- because empty list of apps will be rem. - VMeta x env n -> flip (VMeta x) n <$> sub env -{- REDUNDANT - _ -> error $ "substitute: internal error: not defined for " ++ show v --} - -instance Substitute SemCxt where - substitute subst delta = do - cxt' <- substitute subst (cxt delta) - return $ delta { cxt = cxt' } - --- | Substitute in environment. -instance Substitute Env where - substitute subst (Environ rho mmeas) = - Environ <$> substitute subst rho <*> substitute subst mmeas - -instance Substitute Substitution where - substitute subst2 subst1 = compSubst subst1 subst2 - --- | "merge" substitutions by first applying the second to the first, then --- appending them @t[sigma][tau] = t[sigma . tau]@ -compSubst :: Substitution -> Substitution -> TypeCheck Substitution -compSubst (Valuation subst1) subst2@(Valuation subst2') = - Valuation . (++ subst2') <$> substitute subst2 subst1 - ----------------------------------------------------------------------- --- * Size checking ----------------------------------------------------------------------- - -{- TODO: From a sized data declaration - - sized data D pars : Size -> t - { c : [j : Size] -> args -> D pars $j ts - } - - with constructor type - - c : .pars -> [j : Size] -> args -> D pars $j ts - - extract new-style constructor type - - c : .pars -> [i : Size] -> [j < i : Size] -> args -> D pars i ts - - Then replace in ConSig filed isSized :: Sized by :: Maybe Expr - which stores the new-style constructor type - --} - -mkConLType :: Int -> Expr -> (Name, Expr) -mkConLType npars t = - let (Telescope (sizetb : tel), t0) = typeToTele t - in case spineView t0 of - (d@(Def (DefId DatK _)), args) -> - let (pars, sizeindex : inds) = splitAt npars args - i = fresh "s!ze" - args' = pars ++ Var i : inds - core = foldl App d args' - tbi = TBind i $ sizeDomain irrelevantDec - tbj = sizetb { boundDom = belowDomain irrelevantDec Lt (Var i) } - tel' = Telescope $ tbi : tbj : tel - in (i, teleToType tel' core) - _ -> error $ "conLType " ++ show npars ++ " (" ++ show t ++ "): illformed constructor type" - - - --- * check wether the data type is sized type - - --- check data declaration type --- called from typeCheckDeclaration (DataDecl{}) --- parameters : number of params, type -szType :: Co -> Int -> TVal -> TypeCheck () -szType co p tv = doVParams p tv $ \ tv' -> do - let polsz = if co==Ind then Pos else Neg - case tv' of - VQuant Pi x (Domain av ki dec) fv | isVSize av && not (erased dec) && polarity dec == polsz -> return () - _ -> throwErrorMsg $ "not a sized type, target " ++ show tv' ++ " must have non-erased domain " ++ show Size ++ " with polarity " ++ show polsz - --- * constructors of sized type - --- check data constructors --- called from typeCheckConstructor -szConstructor :: Name -> Co -> Int -> TVal -> TypeCheck () -szConstructor n co p tv = enterDoc (text ("szConstructor " ++ show n ++ " :") <+> prettyTCM tv) $ do - doVParams p tv $ \ tv' -> - case tv' of - VQuant Pi x dom fv | isVSize (typ dom) -> - underAbs x dom fv $ \ k xv bv -> do - szSizeVarUsage n co p k bv - _ -> throwErrorMsg $ "not a valid sized constructor: expected size quantification" - -szSizeVarUsage :: Name -> Co -> Int -> Int -> TVal -> TypeCheck () -szSizeVarUsage n co p i tv = enterDoc (text "szSizeVarUsage of" <+> prettyTCM (VGen i) <+> text "in" <+> prettyTCM tv) $ - case tv of - VQuant Pi x dom fv -> do - let av = typ dom - szSizeVarDataArgs n p i av -- recursive calls of for D..i.. - enterDoc (text "checking" <+> prettyTCM av <+> text (" to be " ++ - (if co == CoInd then "antitone" else "isotone") ++ " in variable") - <+> prettyTCM (VGen i)) $ - szMono co i av -- monotone in i - underAbs x dom fv $ \ _ xv bv -> do - szSizeVarUsage n co p i bv - - _ -> szSizeVarTarget p i tv - --- check that Target is of form D ... (Succ i) ... -szSizeVarTarget :: Int -> Int -> TVal -> TypeCheck () -szSizeVarTarget p i tv = enterDoc (text "szSizeVarTarget, variable" <+> prettyTCM (VGen i) <+> text ("argument no. " ++ show p ++ " in") <+> prettyTCM tv) $ do - let err = text "expected target" <+> prettyTCM tv <+> text "of size" <+> prettyTCM (VSucc (VGen i)) - case tv of - VSing _ tv -> szSizeVarTarget p i =<< whnfClos tv - VApp d vl -> do - v0 <- whnfClos (vl !! p) - case v0 of - (VSucc (VGen i')) | i == i' -> return () - _ -> failDoc err - _ -> failDoc err - - --- check that rec. arguments are of form D ... i .... --- and size used nowhere else ?? -- Andreas, 2009-11-27 TOO STRICT! -{- accepts, for instance - - Nat -> Ord i as argument of a constructor of Ord ($ i) - List (Rose A i) as argument of a constructor of Rose A ($i) - -} -szSizeVarDataArgs :: Name -> Int -> Int -> TVal -> TypeCheck () -szSizeVarDataArgs n p i tv = enterDoc (text "sizeVarDataArgs" <+> prettyTCM (VGen i) <+> text "in" <+> prettyTCM tv) $ do - case tv of - - {- case D pars sizeArg args -} - VApp (VDef (DefId DatK (QName m))) vl | n == m -> do - let (pars, v0 : idxs) = splitAt p vl - v0 <- whnfClos v0 - case v0 of - VGen i' | i' == i -> do - forM_ (pars ++ idxs) $ \ v -> nocc [i] v >>= do - boolToErrorDoc $ - text "variable" <+> prettyTCM (VGen i) <+> - text "may not occur in" <+> prettyTCM v - _ -> failDoc $ - text "wrong size index" <+> prettyTCM v0 <+> - text "at recursive occurrence" <+> prettyTCM tv - --- not necessary: check for monotonicity above --- {- case D' pars sizeArg args -} --- VApp (VDef m) vl | n /= m -> do - - VApp v1 vl -> mapM_ (\ v -> whnfClos v >>= szSizeVarDataArgs n p i) (v1:vl) - - VQuant Pi x dom fv -> do - szSizeVarDataArgs n p i (typ dom) - underAbs x dom fv $ \ _ xv bv -> do - szSizeVarDataArgs n p i bv - - fv | isFun fv -> - addName (absName fv) $ \ xv -> szSizeVarDataArgs n p i =<< app fv xv -{- - VLam x env b -> - addName x $ \ xv -> do - bv <- whnf (update env x xv) b - szSizeVarDataArgs n p i bv --} - _ -> return () - -{- REMOVED, 2009-11-28, replaced by monotonicity check - VGen i' -> return $ i' /= i - VSucc tv' -> szSizeVarDataArgs n p i tv' - -} - --- doVParams number_of_params constructor_or_datatype_signature --- skip over parameters of type signature of a constructor/data type -doVParams :: Int -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a -doVParams 0 tv k = k tv -doVParams p (VQuant Pi x dom fv) k = - underAbs x dom fv $ \ _ xv bv -> do - doVParams (p - 1) bv k - --------------------------------------- --- check for admissible type - -{- - - - admissibility needs to be check clausewise, because of Karl's example - - fun nonAdmissibleType : Unit -> Set - - fun diverge : (u : Unit) -> nonAdmissibleType u - { - diverge unit patterns = badRhs - } - - - the type must be admissible in the current position - only if the size pattern is a successor. - If the pattern is a variable, then there is no induction on that size - argument, so no limit case, so no upper semi-continuity necessary - for the type. - - - when checking - - ... (s i) ps admissible (j : Size) -> A - - we will check - - A admissible in j - - and continue with - - ... ps admissible A[s i / j] - - just to maintain type wellformedness. The (s i) in A does not - really matter, since there is no case distinction on ordinals. - - - a size pattern which is not inductive (meaning there is an - inductive type indexed by that size) nor coinductive (meaning that - the result type is coinductive and is indexed by that size) must - be flagged unusable for termination checking. - - - the fun/cofun distinction could be inferred by the termination checker - or be clausewise as in Agda 2 - --} - - -admFunDef :: Co -> [Clause] -> TVal -> TypeCheck [Clause] -admFunDef co cls tv = do - (cls, inco) <- admClauses cls tv - when (co==CoInd && not (co `elem` inco)) $ - throwErrorMsg $ show tv ++ " is not a type of a cofun" -- ++ if co==Ind then "fun" else "cofun" - return cls - -admClauses :: [Clause] -> TVal -> TypeCheck ([Clause], [Co]) -admClauses [] tv = return ([], []) -admClauses (cl:cls) tv = do - (cl',inco) <- admClause cl tv - (cls',inco') <- admClauses cls tv - return (cl' : cls', inco ++ inco') - -admClause :: Clause -> TVal -> TypeCheck (Clause, [Co]) -admClause (Clause tel ps e) tv = traceAdm ("admClause: admissibility of patterns " ++ show ps) $ - introPatterns ps tv $ \ pvs _ -> do - (ps', inco) <- admPatterns pvs tv - return (Clause tel ps' e, inco) - -admPatterns :: [(Pattern,Val)] -> TVal -> TypeCheck ([Pattern], [Co]) -admPatterns [] tv = do - isCo <- endsInCo tv - return ([], if isCo then [CoInd] else []) -admPatterns ((p,v):pvs) tv = do - (p, inco1) <- admPattern p tv - bv <- piApp tv v - (ps, inco2) <- admPatterns pvs bv - return (p:ps, inco1 ++ inco2) - -{- --- turn a pattern into a value --- extend delta by generic values but do not introduce their types -evalPat :: Pattern -> (Val -> TypeCheck a) -> TypeCheck a -evalPat p f = - case p of - VarP n -> addName n f - ConP co n [] -> f (VCon co n) - ConP co n pl -> evalPats pl $ \ vl -> f (VApp (VCon co n) vl) - SuccP p -> evalPat p $ \ v -> f (VSucc v) --- DOES NOT WORK SINCE e has unbound variables - DotP e -> do - v <- whnf' e - f v - -evalPats :: [Pattern] -> ([Val] -> TypeCheck a) -> TypeCheck a -evalPats [] f = f [] -evalPats (p:ps) f = evalPat p $ \ v -> evalPats ps $ \ vs -> f (v:vs) --} - -{- -evalPat :: Pattern -> TypeCheck (State TCContext Val) -evalPat p = - case p of - VarP n -> return $ State $ \ ce -> - let (k, delta) = cxtPushGen (context ce) - rho = update n (VGen k) (environ ce) - in (VGen k, TCContext { context = delta, environ = rho }) - ConP co n [] -> return (VCon co n) - ConP co n pl -> do - vl <- mapM evalPat pl - return (VApp (VCon co n) vl) - SuccP p -> do - v <- evalPat p - return (VSucc v) --- TODO: does not work! --- DotP e -> return $ State $ \ ce -> --} - - - - -{- 2013-03-31 On instantiation of quantifiers [i < #] - F i - -If F is upper semi-continuous then - - [i < #] -> F i is a sub"set" of F # - -so we can instantiate i to #. (Hughes et al., POPL 96; Abel, LMCS 08) - -1) Consider the special case - - F i = [j < i] -> G i - -Because # is a limit, thus, j < i < # iff j < #, we reason: - - F # = [j < #] -> G j - - [i < #] -> F i - = [i < #] -> [j < i] -> G j (since # is a limit) - = [j < #] -> G j - -2) Consider the special case - - F i = [j <= i] -> G j - -We have - - F # = [j <= #] -> G j - = G # /\ ([j < #] -> G j) - - [i < #] -> F i - = [i < #] -> [j <= i] -> G j - = [j < #] -> G j - -So if G is upper semi-continuous, so is F. - --} - - --- | Check whether a type is upper semi-continuous. -lowerSemiCont :: Int -> TVal -> TypeCheck Bool -lowerSemiCont i tv = errorToBool $ lowerSemiContinuous i tv - -docNotLowerSemi i av = text "type " <+> prettyTCM av <+> - text " not lower semi continuous in " <+> prettyTCM (VGen i) - -lowerSemiContinuous :: Int -> TVal -> TypeCheck () -lowerSemiContinuous i av = do - av <- force av - let fallback = szAntitone i av `newErrorDoc` docNotLowerSemi i av - - case av of - - -- [j < i] & F j is lower semi-cont in i - -- because [i < #] & [j < i] & F j is the same as [j < #] & F j - -- [but what if i in FV(F j)? should not matter!] 2013-04-01 - VQuant Sigma x dom@Domain{ typ = VBelow Lt (VGen i') } fv | i == i' -> return () - - -- [j <= i] & F j is lower semi-cont in i if F is - VQuant Sigma x dom@Domain{ typ = VBelow Le (VGen i') } fv | i == i' -> do - underAbs x dom fv $ \ j xv bv -> lowerSemiContinuous j bv - - -- Sigma-type general case - VQuant Sigma x dom@Domain{ typ = av } fv -> do - lowerSemiContinuous i av - underAbs x dom fv $ \ _ xv bv -> lowerSemiContinuous i bv - - VApp (VDef (DefId DatK n)) vl -> do - sige <- lookupSymbQ n - case sige of - - -- finite tuple type - DataSig { symbTyp = dv, constructors = cis, isTuple = True } -> do - -- match target of constructor against tv to instantiate - -- c : ... -> D ps -- ps = snd (cPatFam ci) - mrhoci <- Util.firstJustM $ map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis - case mrhoci of - Nothing -> fallback - Just (rho,ci) -> if (cRec ci) then fallback else do - -- infinite tuples (recursive constructor) are not lower semi cont - enter ("lowerSemiContinuous: detected tuple type, checking components") $ - allComponentTypes (cFields ci) rho (lowerSemiContinuous i) - - -- i-sized inductive types are lower semi-cont in i - DataSig { numPars, isSized = Sized, isCo = Ind } | length vl > numPars -> do - s <- whnfClos $ vl !! numPars -- the size argument is the first fgter the parameters - case s of - VGen i' | i == i' -> return () - _ -> fallback - - -- finite inductive type - DataSig { symbTyp = dv, constructors = cis, isCo = Ind } -> - -- if any cRec cis then fallback else do -- we loop on recursive data, so exclude - -- check that we do not loop on the same data names... - ifM ((n `elem`) <$> asks callStack) fallback $ do - local (\ ce -> ce { callStack = n : callStack ce }) $ do - -- match target of constructor against tv to instantiate - -- c : ... -> D ps -- ps = snd (cPatFam ci) - forM_ cis $ \ ci -> do - match <- nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv - Foldable.forM_ match $ \ rho -> do - enter ("lowerSemiContinuous: detected tuple type, checking components") $ - allComponentTypes (cFields ci) rho (lowerSemiContinuous i) - - _ -> fallback - _ -> fallback - --- | Check whether a type is upper semi-continuous. -upperSemiCont :: Int -> TVal -> TypeCheck Bool -upperSemiCont i tv = errorToBool $ endsInSizedCo' False i tv - -- 2013-03-30 - -- endsInSizedCo needs tv[0/i] = Top - -- upperSemiCont does not need this, the target can also be constant in i - --- | @endsInSizedCo i tv@ checks that @tv@ is lower semi-continuous in @i@ --- and that @tv[0/i] = Top@. -endsInSizedCo :: Int -> TVal -> TypeCheck () -endsInSizedCo = endsInSizedCo' True - --- | @endsInSizedCo' False i tv@ checks that @tv@ is lower semi-continuous in @i@. --- @endsInSizedCo' True i tv@ additionally checks that @tv[0/i] = Top@. -endsInSizedCo' :: Bool -> Int -> TVal -> TypeCheck () -endsInSizedCo' endInCo i tv = enterDoc (text "endsInSizedCo:" <+> prettyTCM tv) $ do - tv <- force tv - let fallback - | endInCo = failDoc $ text "endsInSizedCo: target" <+> prettyTCM tv <+> text "of corecursive function is neither a CoSet or codata of size" <+> prettyTCM (VGen i) <+> text "nor a tuple type" - | otherwise = szMonotone i tv - case tv of - VSort (CoSet (VGen i)) -> return () - VMeasured mu bv -> endsInSizedCo' endInCo i bv - - -- case forall j <= i. C j coinductive in i - VQuant Pi x dom@Domain{ typ = VBelow Le (VGen i') } fv | i == i' -> - underAbs x dom fv $ \ j xv bv -> - endsInSizedCo' endInCo j bv - VGuard (Bound Le (Measure [VGen j]) (Measure [VGen i'])) bv | i == i' -> - endsInSizedCo' endInCo j bv - - -- same case again, written as j < i+1. C j - VQuant Pi x dom@Domain{ typ = VBelow Lt (VSucc (VGen i')) } fv | i == i' -> - underAbs x dom fv $ \ j xv bv -> - endsInSizedCo' endInCo j bv - VGuard (Bound Lt (Measure [VGen j]) (Measure [VSucc (VGen i')])) bv | i == i' -> - endsInSizedCo' endInCo j bv - - -- case forall j < i. C j: already coinductive in i !! - -- Trivially, forall j < 0. C j is the top type. - -- And, forall i < # forall j < i is equivalent to forall j < # - -- so we can instantiate i to #. - VGuard (Bound Lt (Measure [VGen j]) (Measure [VGen i'])) bv | i == i' -> - return () - VQuant Pi x dom@Domain{ typ = VBelow Lt (VGen i') } fv | i == i' -> return () - - VQuant Pi x dom fv -> do - lowerSemiContinuous i $ typ dom - underAbs x dom fv $ \ _ xv bv -> endsInSizedCo' endInCo i bv - - VSing _ tv -> endsInSizedCo' endInCo i =<< whnfClos tv - VApp (VDef (DefId DatK n)) vl -> do - sige <- lookupSymbQ n - case sige of - DataSig { numPars = np, isSized = Sized, isCo = CoInd } - | length vl > np -> do - v <- whnfClos $ vl !! np - if isVGeni v then return () else fallback - where isVGeni (VGen i) = True - isVGeni (VPlus vs) = and $ map isVGeni vs - isVGeni (VMax vs) = and $ map isVGeni vs - isVGeni VZero = True - isVGeni _ = False -{- WE DO NOT HAVE SUBST ON VALUES! - case vl !! np of - VGen j -> if i == j then return () else fail1 - VZero -> return () - VClos rho e -> do - v <- whnf (update rho i VZero) e -- BUGGER - if v == VZero then return () else fail1 --} --- we also allow the target to be a tuple if all of its components --- fulfill "endsInSizedCo" - DataSig { symbTyp = dv, constructors = cis, isTuple = True } -> do - allTypesOfTuple tv vl dv cis (endsInSizedCo' endInCo i) -{- - -- match target of constructor against tv to instantiate - -- c : ... -> D ps -- ps = snd (cPatFam ci) - mrhoci <- Util.firstJustM $ map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis - case mrhoci of - Nothing -> failDoc $ text "endsInSizedCo: panic: target type" <+> prettyTCM tv <+> text "is not an instance of any constructor" - Just (rho,ci) -> enter ("endsInSizedCo: detected tuple target, checking components") $ - fieldsEndInSizedCo endInCo i (cFields ci) rho --} - _ -> fallback - _ -> fallback -{- failDoc $ text "endsInSizedCo: target" <+> prettyTCM tv <+> text "of corecursive function is neither a function type nor a codata nor a tuple type" --} - --- | @allTypesOfTyples args dv cis check@ performs @check@ on all component --- types of tuple type @tv = d args@ where @dv@ is the type of @d@. -allTypesOfTuple :: TVal -> [Val] -> TVal -> [ConstructorInfo] -> (TVal -> TypeCheck ()) -> TypeCheck () -allTypesOfTuple tv vl dv cis check = do - -- match target of constructor against tv to instantiate - -- c : ... -> D ps -- ps = snd (cPatFam ci) - mrhoci <- Util.firstJustM $ - map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis - -- we know that only one constructor can match, otherwise it would not be a tuple type - case mrhoci of - Nothing -> failDoc $ text "allTypesOfTuple: panic: target type" <+> prettyTCM tv <+> text "is not an instance of any constructor" - Just (rho,ci) -> enter ("allTypesOfTuple: detected tuple target, checking components") $ - allComponentTypes (cFields ci) rho check - -{- -fieldsEndInSizedCo :: Bool -> Int -> [FieldInfo] -> Env -> TypeCheck () -fieldsEndInSizedCo endInCo i fis rho0 = allComponentTypes fis rho0 (endsInSizedCo' endInCo i) -fieldsEndInSizedCo endInCo i fis rho0 = enter ("fieldsEndInSizedCo: checking fields of tuple type " ++ show fis ++ " in environment " ++ show rho0) $ - loop fis rho0 where - loop [] rho = return () - -- nothing to check for erased index fields - loop (f : fs) rho | fClass f == Index && erased (fDec f) = - loop fs rho - loop (f : fs) rho | fClass f == Index = do - tv <- whnf rho (fType f) - endsInSizedCo' endInCo i tv - loop fs rho - loop (f : fs) rho = do - tv <- whnf rho (fType f) - when (not $ erased (fDec f)) $ endsInSizedCo' endInCo i tv - -- for non-index fields, value is not given by matching, so introduce - -- generic value - new (fName f) (Domain tv defaultKind (fDec f)) $ \ xv -> do - let rho' = update rho (fName f) xv - -- do not need to check erased fields? - loop fs rho' --} - --- | @allComponentTypes fis env check@ applies @check@ to all field types --- in @fis@ (evaluated wrt to environment @env@). --- Erased fields are skipped. (Is this correct?) -allComponentTypes :: [FieldInfo] -> Env -> (TVal -> TypeCheck ()) -> TypeCheck () -allComponentTypes fis rho0 check = enter ("allComponentTypes: checking fields of tuple type " ++ show fis ++ " in environment " ++ show rho0) $ - loop fis rho0 where - loop [] rho = return () - - -- nothing to check for erased index fields - loop (f : fs) rho | fClass f == Index && erased (fDec f) = - loop fs rho - - -- ordinary index field types are checked - loop (f : fs) rho | fClass f == Index = do - check =<< whnf rho (fType f) - loop fs rho - - -- proper fields - loop (f : fs) rho = do - tv <- whnf rho (fType f) - -- do not need to check erased fields? - when (not $ erased (fDec f)) $ check tv - -- for non-index fields, value is not given by matching, so introduce - -- generic value - new (fName f) (Domain tv defaultKind (fDec f)) $ \ xv -> do - loop fs $ update rho (fName f) xv - - - -endsInCo :: TVal -> TypeCheck Bool -endsInCo tv = -- traceCheck ("endsInCo: " ++ show tv) $ - case tv of - VQuant Pi x dom fv -> underAbs x dom fv $ \ _ _ bv -> endsInCo bv - - VApp (VDef (DefId DatK n)) vl -> do - sige <- lookupSymbQ n - case sige of - DataSig { isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $ - return True - _ -> return False - _ -> return False - --- precondition: Pattern does not contain "Unusable" -admPattern :: Pattern -> TVal -> TypeCheck (Pattern, [Co]) -admPattern p tv = traceAdm ("admPattern " ++ show p ++ " type: " ++ show tv) $ - case tv of - VGuard beta bv -> addBoundHyp beta $ admPattern p bv - VApp (VDef (DefId DatK d)) vl -> do - case p of - ProjP n -> return (p, []) - _ -> throwErrorMsg "admPattern: IMPOSSIBLE: non-projection pattern for record type" - VQuant Pi x dom fv -> underAbs x dom fv $ \ k xv bv -> do - {- - if p is successor pattern - check that bv is admissible in k, returning subset of [Ind, CoInd] - p is usable if either CoInd or it is a var or dot pattern and Ind --} - if isSuccessorPattern p then do - inco <- admType k bv - when (CoInd `elem` inco && not (shallowSuccP p)) $ cannotMatchDeep p tv - if (CoInd `elem` inco) - || (inco /= [] && completeP p) - then return (p, inco) - else return (UnusableP p, inco) - else return (p, []) - - _ -> throwErrorMsg "admPattern: IMPOSSIBLE: pattern for a non-function type" - -cannotMatchDeep p tv = recoverFailDoc $ - text "cannot match against deep successor pattern" - <+> text (show p) <+> text "at type" <+> prettyTCM tv - -admType :: Int -> TVal -> TypeCheck [Co] -admType i tv = enter ("admType: checking " ++ show tv ++ " admissible in v" ++ show i) $ - case tv of - VQuant Pi x dom@(Domain av _ _) fv -> do - isInd <- szUsed Ind i av - when (not isInd) $ - szAntitone i av `newErrorDoc` docNotLowerSemi i av - underAbs x dom fv $ \ gen _ bv -> do - inco <- admType i bv - if isInd then return (Ind : inco) else return inco - _ -> do - isCoind <- szUsed CoInd i tv - if isCoind then return [CoInd] - else do - szMonotone i tv - return [] - -szUsed :: Co -> Int -> TVal -> TypeCheck Bool -szUsed co i tv = traceAdm ("szUsed: " ++ show tv ++ " " ++ show co ++ " in v" ++ show i) $ - case tv of - (VApp (VDef (DefId DatK n)) vl) -> - do sige <- lookupSymbQ n - case sige of - DataSig { numPars = p - , isSized = Sized - , isCo = co' } | co == co' && length vl > p -> - -- p is the number of parameters - -- it is also the index of the size argument - do s <- whnfClos $ vl !! p - case s of - VGen i' | i == i' -> return True - _ -> return False - _ -> return False - _ -> return False - - - --- for inductive fun, and for every size argument i --- - every argument needs to be either inductive or antitone in i --- - the result needs to be monotone in i - -{- szCheckIndFun admpos delta tv - - entry point for admissibility check for recursive functions - - scans for the first size quantification - - passes on to szCheckIndFunSize - - currently: also continues to look for the next size quantification... - -} - -szCheckIndFun :: [Int] -> TVal -> TypeCheck () -szCheckIndFun admpos tv = -- traceCheck ("szCheckIndFun: " ++ show delta ++ " |- " ++ show tv ++ " adm?") $ - case tv of - VQuant Pi x dom fv -> underAbs x dom fv $ \ k _ bv -> do - -- bv <- whnf' b - if isVSize (typ dom) then do - when (k `elem` admpos) $ - szCheckIndFunSize k bv - szCheckIndFun admpos bv -- this is for lexicographic induction on sizes, I suppose? Probably should me more fine grained! Andreas, 2008-12-01 - else szCheckIndFun admpos bv - _ -> return () - - -{- szCheckIndFunSize delta i tv - - checks whether type tv is admissible for recursion in index i - - every argument needs to be either inductive or antitone in i - - the result needs to be monotone in i - -} - -szCheckIndFunSize :: Int -> TVal -> TypeCheck () -szCheckIndFunSize i tv = -- traceCheck ("szCheckIndFunSize: " ++ show delta ++ " |- " ++ show tv ++ " adm(v" ++ show i ++ ")?") $ - case tv of - VQuant Pi x dom fv -> do - szLowerSemiCont i (typ dom) --- new x dom $ \ k _ -> szCheckIndFunSize i =<< app fv (VGen k) - underAbs x dom fv $ \ _ _ bv -> szCheckIndFunSize i bv -{- - new' x dom $ do - bv <- whnf' b - szCheckIndFunSize i bv --} - _ -> szMonotone i tv - -{- szLowerSemiCont - - - check for lower semi-continuity [Abel, CSL 2006] - - current approximation: inductive type or antitone - -} -szLowerSemiCont :: Int -> TVal -> TypeCheck () -szLowerSemiCont i av = -- traceCheck ("szlowerSemiCont: checking " ++ show av ++ " lower semi continuous in v" ++ show i) $ - (szAntitone i av `catchError` - (\ msg -> -- traceCheck (show msg) $ - szInductive i av)) - `newErrorDoc` docNotLowerSemi i av - - -{- checking cofun-types for admissibility - -conditions: - -1. type must end in coinductive type or in sized coinductive type - indexed by just a variable i which has been quantified in the type - -2. in the second case, each argument must be inductive or antitone in i - optimization: - arguments types before the quantification over i can be ignored --} - -data CoFunType - = CoFun -- yes, but not sized cotermination - | SizedCoFun Int -- yes an admissible sized type (the Int specifies the number of the recursive size argument) - -{- -design: - -admCoFun delta tv : IsCoFunType - - endsInCo delta tv (len delta) id - -admEndsInCo delta tv firstVar jobs : IsCoFunType - - traverse tv, gather continutations in jobs, check for CoInd in the end - - if tv = (x:A) -> B - push A on delta - add the following task to jobs: - check A for lower semicontinuity in delta - continue on B - - if tv = Codata^i - run (jobs i) - if they return (), return YesSized Int, otherwise No - - if tv = Codata - return Yes - - otherwise - return No - -} - --- {- TODO: FINISH THIS!! - -admCoFun :: TVal -> TypeCheck CoFunType -admCoFun tv = do - l <- getLen - admEndsInCo tv l (\ i -> return ()) - -admEndsInCo :: TVal -> Int -> (Int -> TypeCheck ()) -> TypeCheck CoFunType -admEndsInCo tv firstVar jobs = -- traceCheck ("admEndsInCo: " ++ show tv) $ - case tv of - VQuant Pi x dom fv -> do - l <- getLen - let jobs' = (addJob l (typ dom) jobs) - underAbs x dom fv $ \ _ _ bv -> admEndsInCo bv firstVar jobs' -{- - new' x dom $ do - bv <- whnf' b - admEndsInCo bv firstVar jobs' --} - -{- - -- if not applied, it cannot be a sized type - VDef n -> do - sig <- gets signature - case (lookupSig n sig) of - DataSig { isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $ - return CoFun - _ -> throwErrorMsg $ "type of cofun does not end in coinductive type" --} - - VApp (VDef (DefId DatK n)) vl -> do - sige <- lookupSymbQ n - case sige of - DataSig { isSized = NotSized, isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $ - return CoFun - DataSig { numPars = p, isSized = Sized, isCo = CoInd } | length vl > p -> -- traceCheck ("found sized coinductive target") $ - do - -- p is the number of parameters - -- it is also the index of the size argument - s <- whnfClos $ vl !! p - case s of - VGen i -> do - jobs i - return $ SizedCoFun $ i - firstVar - _ -> throwErrorMsg $ "size argument in result type must be a variable" - _ -> throwErrorMsg $ "type of cofun does not end in coinductive type" - -addJob :: Int -> TVal -> (Int -> TypeCheck ()) - -> (Int -> TypeCheck ()) -addJob l tv jobs recVar = do - -- is the "recursive" size variable actually in scope? - jobs recVar - when (recVar < l) $ szLowerSemiCont recVar tv - --- -} - - -{- szCheckCoFun OBSOLETE!! - - entry point for admissibility check for corecursive functions - - scans for the first size quantification - - passes on to szCheckIndFunSize - - currently: also continues to look for the next size quantification - - and checks in the end whether the target is a coinductive type - - --- STALE COMMENT: for a cofun : arguments nocc i and result coinductive in i -szCheckCoFun :: SemCxt -> TVal -> TypeCheck () -szCheckCoFun delta tv = - case tv of - VPi dec x av env b -> do - let (k, delta') = cxtPush dec av delta - bv <- whnf (update env x (VGen k)) b - case av of - VSize -> do szCheckCoFunSize delta' k bv - szCheckCoFun delta' bv - _ -> szCheckCoFun delta' bv - -- result - (VApp (VDef n) vl) -> - do sig <- gets signature - case (lookupSig n sig) of - (DataSig _ _ _ CoInd _) -> - return () - _ -> throwErrorMsg $ "cofun doesn't target coinductive type" - (VDef n) -> - do sig <- gets signature - case (lookupSig n sig) of - (DataSig _ _ _ CoInd _) -> - return () - _ -> throwErrorMsg $ "cofun doesn't target coinductive type" - _ -> throwErrorMsg $ "cofun doesn't target coinductive type" - -szCheckCoFunSize :: SemCxt -> Int -> TVal -> TypeCheck () -szCheckCoFunSize delta i tv = -- traceCheck ("szco " ++ show tv) $ - case tv of - VPi dec x av env b -> do - let (k, delta') = cxtPush dec av delta - bv <- whnf (update env x (VGen k)) b - szLowerSemiCont delta i av - szCheckCoFunSize delta' i bv - -- result must be coinductive - _ -> szCoInductive delta i tv - --} - -szMono :: Co -> Int -> TVal -> TypeCheck () -szMono co i tv = - case co of - Ind -> szMonotone i tv - CoInd -> szAntitone i tv - -szMonotone :: Int -> TVal -> TypeCheck () -szMonotone i tv = traceCheck ("szMonotone: " -- ++ show delta ++ " |- " - ++ show tv ++ " mon(v" ++ show i ++ ")?") $ - do - let si = VSucc (VGen i) - tv' <- substitute (sgSub i si) tv - leqVal Pos vTopSort tv tv' - -szAntitone :: Int -> TVal -> TypeCheck () -szAntitone i tv = traceCheck ("szAntitone: " -- ++ show delta ++ " |- " - ++ show tv ++ " anti(v" ++ show i ++ ")?") $ - do - let si = VSucc (VGen i) - tv' <- substitute (sgSub i si) tv - leqVal Neg vTopSort tv tv' - --- checks if tv is a sized inductive type of size i -szInductive :: Int -> TVal -> TypeCheck () -szInductive i tv = szUsed' Ind i tv - --- checks if tv is a sized coinductive type of size i -szCoInductive :: Int -> TVal -> TypeCheck () -szCoInductive i tv = szUsed' CoInd i tv - -szUsed' :: Co -> Int -> TVal -> TypeCheck () -szUsed' co i tv = - case tv of - (VApp (VDef (DefId DatK n)) vl) -> - do sige <- lookupSymbQ n - case sige of - DataSig { numPars = p, isSized = Sized, isCo = co' } | co == co' && length vl > p -> - -- p is the number of parameters - -- it is also the index of the size argument - do s <- whnfClos $ vl !! p - case s of - VGen i' | i == i' -> return () - _ -> throwErrorMsg $ "expected size variable" - _ -> throwErrorMsg $ "expected (co)inductive sized type" - _ -> throwErrorMsg $ "expected (co)inductive sized type" diff --git a/Util.hs b/Util.hs deleted file mode 100644 --- a/Util.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TupleSections, NoMonomorphismRestriction, - FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-} - -module Util where - -import Prelude hiding (showList, null) - -import Control.Applicative hiding (empty) -import Control.Monad -import Control.Monad.Writer (Writer, runWriter, All, getAll) - -import qualified Data.List as List -import Data.Map (Map) -import qualified Data.Map as Map -import Debug.Trace - -import Text.PrettyPrint as PP - -(+?+) :: String -> String -> String -(+?+) xs "[]" = [] -(+?+) xs ys = xs ++ ys - -implies :: Bool -> Bool -> Bool -implies a b = if a then b else True - -class Pretty a where - pretty :: a -> Doc - prettyPrec :: Int -> a -> Doc - - pretty = prettyPrec 0 - prettyPrec = const pretty - -instance Pretty Doc where - pretty = id - -angleBrackets :: Doc -> Doc -angleBrackets d = text "<" <+> d <+> text ">" - --- | Apply when condition is @True@. -fwhen :: Bool -> (a -> a) -> a -> a -fwhen True f a = f a -fwhen False f a = a - -parensIf :: Bool -> Doc -> Doc -parensIf b = fwhen b PP.parens - -hsepBy :: Doc -> [Doc] -> Doc -hsepBy sep [] = empty -hsepBy sep [d] = d -hsepBy sep (d:ds) = d <> sep <> hsepBy sep ds - -pwords :: String -> [Doc] -pwords = map text . words - -fwords :: String -> Doc -fwords = fsep . pwords - -fromAllWriter :: Writer All a -> (Bool, a) -fromAllWriter m = let (a, w) = runWriter m - in (getAll w, a) - -traceM :: (Monad m) => String -> m () -traceM msg = trace msg $ return () - -infixr 9 <.> - --- | Composition: pure function after monadic function. -(<.>) :: Functor m => (b -> c) -> (a -> m b) -> a -> m c -(f <.> g) a = f <$> g a - -whenM :: Monad m => m Bool -> m () -> m () -whenM mb k = mb >>= (`when` k) - -unlessM :: Monad m => m Bool -> m () -> m () -unlessM mb k = mb >>= (`unless` k) - -whenJustM :: (Monad m) => m (Maybe a) -> (a -> m ()) -> m () -whenJustM mm k = mm >>= (`whenJust` k) - -whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m () -whenJust (Just a) k = k a -whenJust Nothing k = return () - -whenNothing :: (Monad m) => Maybe a -> m () -> m () -whenNothing Nothing m = m -whenNothing Just{} m = return () - -ifNothingM :: (Monad m) => m (Maybe a) -> m b -> (a -> m b) -> m b -ifNothingM mma mb f = maybe mb f =<< mma - -ifJustM :: (Monad m) => m (Maybe a) -> (a -> m b) -> m b -> m b -ifJustM mma f mb = maybe mb f =<< mma - -mapMapM :: (Monad m, Ord k) => (a -> m b) -> Map k a -> m (Map k b) -mapMapM f = Map.foldrWithKey step (return $ Map.empty) - where step k a m = do a' <- f a - m' <- m - return $ Map.insert k a' m' - -ifM :: Monad m => m Bool -> m a -> m a -> m a -ifM c d e = do { b <- c ; if b then d else e } - -{- Control.Monad.IfElse -whenM :: Monad m => m Bool -> m () -> m () -whenM c d = do { b <- c; if b then d else return () } - -unlessM :: Monad m => m Bool -> m () -> m () -unlessM c e = do { b <- c; if b then return () else e } --} - -andLazy :: Monad m => m Bool -> m Bool -> m Bool -andLazy ma mb = ifM ma mb $ return False - -andM :: Monad m => [m Bool] -> m Bool -andM [] = return True -andM (m:ms) = m `andLazy` andM ms - -findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) -findM p [] = return Nothing -findM p (x : xs) = do b <- p x - if b then return (Just x) else findM p xs - --- | Binary version of @=<<@. -(==<<) :: Monad m => (a -> b -> m c) -> (m a, m b) -> m c -f ==<< (ma, mb) = do { a <- ma; f a =<< mb } - -parens :: String -> String -parens s = "(" ++ s ++ ")" - -brackets :: String -> String -brackets s = "[" ++ s ++ "]" - -bracketsIf :: Bool -> String -> String -bracketsIf False s = s -bracketsIf True s = "[" ++ s ++ "]" - -separate :: String -> String -> String -> String -separate sep "" y = y -separate sep x "" = x -separate sep x y = x ++ sep ++ y - -showList :: String -> (a -> String) -> [a] -> String -showList sep f [] = "" -showList sep f [e] = f e -showList sep f (e:es) = f e ++ sep ++ showList sep f es --- OR: showList sep f es = foldl separate "" $ map f es - -hasDuplicate :: (Eq a) => [a] -> Bool -hasDuplicate [] = False -hasDuplicate (x : xs) = x `elem` xs || hasDuplicate xs - -compressMaybes :: [Maybe a] -> [a] -compressMaybes = concat . map (maybe [] (\ a -> [a])) - -mapFst :: (a -> c) -> (a,d) -> (c,d) -mapFst f (a,b) = (f a, b) - -mapSnd :: (b -> d) -> (a,b) -> (a,d) -mapSnd f (a,b) = (a, f b) - -mapPair :: (a -> c) -> (b -> d) -> (a,b) -> (c,d) -mapPair f g (a,b) = (f a, g b) - -zipPair :: (a -> b -> c) -> (d -> e -> f) -> (a,d) -> (b,e) -> (c,f) -zipPair f g (a,d) (b,e) = (f a b, g d e) - -headMaybe :: [a] -> Maybe a -headMaybe [] = Nothing -headMaybe (a:as) = Just a - -firstJust :: [Maybe a] -> Maybe a -firstJust = headMaybe . compressMaybes - -firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a) -firstJustM [] = return Nothing -firstJustM (mm : mms) = do - m <- mm - case m of - Nothing -> firstJustM mms - Just{} -> return m - -mapOver :: (Functor f) => f a -> (a -> b) -> f b -mapOver = flip fmap - -for = mapOver - -mapAssoc :: (a -> b) -> [(n,a)] -> [(n,b)] -mapAssoc f = map (\ (n, a) -> (n, f a)) - -mapAssocM :: (Applicative m, Monad m) => (a -> m b) -> [(n,a)] -> m [(n,b)] -mapAssocM f = mapM (\ (n, a) -> (n,) <$> f a) - -compAssoc :: Eq b => [(a,b)] -> [(b,c)] -> [(a,c)] -compAssoc xs ys = [ (a,c) | (a,b) <- xs, (b',c) <- ys, b == b' ] - --- * Lists and stacks of lists - -class Push a b where - push :: a -> b -> b - -instance Push a [a] where - push = (:) - -instance Push a [[a]] where - push a (b:bs) = (a : b) : bs - --- TOO HARD for ghc: --- instance Push a b => Push a [b] where --- push a (b:bs) = push a b : bs - -class Retrieve a b c | b -> c where - retrieve :: Eq a => a -> b -> Maybe c - -instance Retrieve a [(a,b)] b where - retrieve = lookup - -instance Retrieve a [[(a,b)]] b where - retrieve a = retrieve a . concat - --- instance Retrieve a b c => Retrieve a [b] c where --- retrieve a = firstJust . map (retrieve a) - -{- -class ListLike a where - length :: a -> Int - null :: a -> Bool - nil :: a --} - -class Size a where - size :: a -> Int - -instance Size [a] where - size = length - -class Null a where - null :: a -> Bool - -instance Null [a] where - null = List.null diff --git a/Value.hs b/Value.hs deleted file mode 100644 --- a/Value.hs +++ /dev/null @@ -1,407 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} - -module Value where - -import Prelude hiding (null) - -import Control.Applicative - -import qualified Data.List as List -import Data.Set (Set) -import qualified Data.Set as Set -import Debug.Trace - -import Abstract -import Polarity -import Util -import TraceError -- orM - --- call-by-value --- cofuns are not forced - -data Val - -- sizes - = VInfty - | VZero - | VSucc Val - | VMax [Val] - | VPlus [Val] - | VMeta MVar Env Int -- X rho + n (n-fold successor of X rho) - -- types - | VSort (Sort Val) - | VMeasured (Measure Val) Val -- mu -> A (only in checkPattern) - | VGuard (Bound Val) Val -- mu A - | VBelow LtLe Val -- domain in bounded size quant. - | VQuant - { vqPiSig :: PiSigma - , vqName :: Name - , vqDom :: Domain - , vqFun :: FVal - } - | VSing Val TVal -- Singleton type (TVal not Pi) - -- functions - | VLam Name Env Expr - | VAbs Name Int Val Valuation -- abstract free variable - | VConst Val -- constant function - | VUp Val TVal -- delayed eta expansion; TVal is a Pi - -- values - | VRecord RecInfo EnvMap -- a record value / fully applied constructor - | VPair Val Val -- eager pair - -- neutrals - | VGen Int -- free variable (de Bruijn level) - | VDef DefId -- co(data/constructor/fun) - -- VDef occurs only inside a VApp! - | VCase Val TVal Env [Clause] - | VApp Val [Clos] - -- closures - | VProj PrePost Name -- a projection as an argument to a neutral - | VClos Env Expr -- closure for cbn evaluation - -- don't care - | VIrr -- erased hypothetical inhabitant of empty type - deriving (Eq,Ord) - --- | Makes constant function if name is empty. -vLam :: Name -> Env -> Expr -> FVal -vLam x env e - | emptyName x = VConst $ VClos env e - | otherwise = VLam x env e - --- | Is a value a function? May become more @True@ after forcing the @VUp@. -isFun :: Val -> Bool -isFun VLam{} = True -isFun VAbs{} = True -isFun VConst{} = True -isFun (VUp _ VQuant{ vqPiSig = Pi }) = True -isFun v = False - -absName :: FVal -> Name -absName fv = - case fv of - VLam x _ _ -> x - VAbs x _ _ _ -> x - VUp _ (VQuant Pi x _ _) -> x - _ -> noName - -type FVal = Val -type TVal = Val -- type value -type Clos = Val -type Domain = Dom TVal - --- | Valuation of free variables. -newtype Valuation = Valuation { valuation :: [(Int,Val)] } - deriving (Eq,Ord) - -emptyVal = Valuation [] -sgVal i v = Valuation [(i,v)] - -valuateGen :: Int -> Valuation -> Val -valuateGen i valu = maybe (VGen i) id $ lookup i $ valuation valu - -type TeleVal = [TBinding Val] - -data Environ a = Environ - { envMap :: [(Name,a)] -- the actual map from names to values - , envBound :: Maybe (Measure Val) -- optionally the current termination measure - } - deriving (Eq,Ord,Show) - -type EnvMap = [(Name,Val)] -type Env = Environ Val - -{- -data MeasVal = MeasVal [Val] -- lexicographic termination measure - deriving (Eq,Ord,Show) --} - --- smart constructors ------------------------------------------------ - --- | The value representing type Size. -vSize :: Val -vSize = VBelow Le VInfty -- 2012-01-28 non-termination bug I have not found --- vSize = VSort $ SortC Size - -vFinSize = VBelow Lt VInfty - --- | Ensure we construct the correct value representing Size. -vSort :: Sort Val -> Val -vSort (SortC Size) = vSize -vSort s = VSort s - -isVSize :: Val -> Bool -isVSize (VSort (SortC Size)) = True -isVSize (VBelow Le VInfty) = True -isVSize _ = False - -vTSize = VSort $ SortC TSize - -vTopSort :: Val -vTopSort = VSort $ Set VInfty - -mkClos :: Env -> Expr -> Val -mkClos rho Infty = VInfty -mkClos rho Zero = VZero --- mkClos rho (Succ e) = VSucc (mkClos rho e) -- violates an invariant!! succeed/crazys -mkClos rho (Below ltle e) = VBelow ltle (mkClos rho e) -mkClos rho (Proj fx n) = VProj fx n -mkClos rho (Var x) = lookupPure rho x -mkClos rho (Ann e) = mkClos rho $ unTag e -mkClos rho e = VClos rho e - -- Problem with MetaVars: freeVars of a meta var is unknown in this repr.! - -- VClos (rho { envMap = filterEnv (freeVars e) (envMap rho)}) e - -filterEnv :: Set Name -> EnvMap -> EnvMap -filterEnv ns [] = [] -filterEnv ns ((x,v) : rho) = - if Set.member x ns then (x,v) : filterEnv (Set.delete x ns) rho - else filterEnv ns rho - -vDef id = VDef id `VApp` [] -vCon co n = vDef $ DefId (ConK co) n --- vCon co n = vDef $ DefId (ConK (coToConK co)) n -vFun n = vDef $ DefId FunK $ QName n -vDat n = vDef $ DefId DatK n - -{- POSSIBLY BREAKS INVARIANT! -vApp :: Val -> [Val] -> Val -vApp f [] = f -vApp f vs = VApp f vs --} - -vAbs :: Name -> Int -> Val -> FVal -vAbs x i v = VAbs x i v emptyVal - -arrow , prod :: TVal -> TVal -> TVal -arrow = quant Pi -prod = quant Sigma - -quant piSig a b = VQuant piSig x (defaultDomain a) (VConst b) - where x = fresh "" --- quant piSig a b = VQuant piSig x (defaultDomain a) (Environ [(bla,b)] Nothing) (Var bla) --- where x = fresh "" --- bla = fresh "#codom" - - --- * Sizes ------------------------------------------------------------ - --- Sizes form a commutative semiring with multiplication (Plus) and --- idempotent addition (Max) --- --- Wellformed size values are polynomials, i.e., sums (Max) of products (Plus). --- A monomial m takes one of the forms (k stands for a variable: VGen or VMeta) --- 0. VSucc^* VZero --- 1. VSucc^* k --- 2. VSucc^* (VPlus [k1,...,kn]) where n>=2 --- A polynomial takes one of the forms --- 0. VInfty --- 1. m --- 2. VMax ms where length ms >= 2 and each mi different -{- OLD --- * VSucc^* VGen --- * VMax vs where each v_i = VSucc^* (VGen k_i) and all k_i different --- and vs has length >= 2 --} --- --- the smart constructors construct wellformed size values using the laws --- $ # = # Infty --- max # k = # --- $ (max i j) = max ($ i) ($ j) $ distributes over max --- max (max i j) k = max i j k Assoc-Commut of max --- max i i = i Idempotency of max -succSize :: Val -> Val -succSize v = case v of - VInfty -> VInfty - VMax vs -> maxSize $ map succSize vs - VMeta i rho n -> VMeta i rho (n + 1) -- TODO: integrate + and mvar - _ -> VSucc v -vSucc = succSize - --- "multiplication" of sizes -plusSize :: Val -> Val -> Val -plusSize VZero v = v -plusSize v VZero = v -plusSize VInfty v = VInfty -plusSize v VInfty = VInfty -plusSize (VMax vs) v = maxSize $ map (plusSize v) vs -plusSize v (VMax vs) = maxSize $ map (plusSize v) vs -plusSize (VSucc v) v' = succSize $ plusSize v v' -plusSize v' (VSucc v) = succSize $ plusSize v v' -plusSize (VPlus vs) (VPlus vs') = VPlus $ List.sort (vs ++ vs') -- every summand is a var! -- TODO: more efficient sorting! -plusSize (VPlus vs) v = VPlus $ List.insert v vs -plusSize v (VPlus vs) = VPlus $ List.insert v vs -plusSize v v' = VPlus $ List.sort [v,v'] - -plusSizes :: [Val] -> Val -plusSizes [] = VZero -plusSizes [v] = v -plusSizes (v:vs) = v `plusSize` (plusSizes vs) - --- maxSize vs = VInfty if any v_i=Infty --- = VMax (sort (nub (flatten vs)) else --- precondition vs - -maxSize :: [Val] -> Val -maxSize vs = case Set.toList . Set.fromList <$> flatten vs of - Nothing -> VInfty - Just [] -> VZero - Just [v] -> v - Just vs' -> VMax vs' - where flatten (VZero:vs) = flatten vs - flatten (VInfty:_) = Nothing - flatten (VMax vs:vs') = flatten vs' >>= return . (vs++) - flatten (v:vs) = flatten vs >>= return . (v:) - flatten [] = return [] - -{- -maxSize :: [Val] -> Val -maxSize vs = case flatten [] vs of - [] -> VInfty - [v] -> v - vs' -> VMax vs' - where flatten acc (VInfty:_) = [] - flatten acc (VMax vs:vs') = flatten (vs ++ acc) vs' - flatten acc (v:vs) = flatten (v:acc) vs - flatten acc [] = Set.toList $ Set.fromList acc -- sort, nub --} - --- * destructors ------------------------------------------------------- - -vSortToSort :: Sort Val -> Sort Expr -vSortToSort (SortC c) = SortC c -vSortToSort (Set VInfty) = Set Infty - -predSize :: Val -> Maybe Val -predSize VInfty = Just VInfty -predSize (VSucc v) = Just v -predSize (VMax vs) = do vs' <- mapM predSize vs - return $ maxSize vs' -predSize (VMeta v rho n) | n > 0 = return $ VMeta v rho (n-1) -predSize _ = Nothing -- variable or zero or sum - -instance HasPred Val where - predecessor VInfty = Nothing -- for printing bounds - predecessor v = predSize v - -isFunType :: TVal -> Bool -isFunType VQuant{ vqPiSig = Pi } = True -isFunType _ = False - -isDataType :: TVal -> Bool -isDataType (VApp (VDef (DefId DatK _)) _) = True -isDataType (VSing v tv) = isDataType tv -isDataType _ = False - --- * ugly printing ----------------------------------------------------- - -instance Show (Sort Val) where - show (SortC c) = show c - show (Set VZero) = "Set" - show (CoSet VInfty) = "Set" - show (Set v) = parens $ ("Set " ++ show v) - show (CoSet v) = parens $ ("CoSet " ++ show v) - -instance Show Val where - show v | isVSize v = "Size" - show (VSort s) = show s - show VInfty = "#" - show VZero = "0" - show (VSucc v) = "($ " ++ show v ++ ")" - show (VMax vl) = "(max " ++ showVals vl ++ ")" - show (VPlus (v:vl)) = parens $ foldr (\ v s -> show v ++ " + " ++ s) (show v) vl - show (VApp v []) = show v - show (VApp v vl) = "(" ++ show v ++ " " ++ showVals vl ++ ")" - show (VDef id) = show id - show (VProj Pre id) = show id - show (VProj Post id) = "." ++ show id - show (VPair v1 v2) = "(" ++ show v1 ++ ", " ++ show v2 ++ ")" - show (VGen k) = "v" ++ show k - show (VMeta k rho 0) = "?" ++ show k ++ showEnv rho - show (VMeta k rho 1) = "$?" ++ show k ++ showEnv rho - show (VMeta k rho n) = "(?" ++ show k ++ showEnv rho ++ " + " ++ show n ++")" - show (VRecord ri env) = show ri ++ "{" ++ Util.showList "; " (\ (n, v) -> show n ++ " = " ++ show v) env ++ "}" - show (VCase v vt env cs) = "case " ++ show v ++ " : " ++ show vt ++ " { " ++ showCases cs ++ " } " ++ showEnv env - show (VClos (Environ [] Nothing) e) = showsPrec precAppR e "" - show (VClos env e) = "{" ++ show e ++ " " ++ showEnv env ++ "}" - show (VSing v vt) = "<" ++ show v ++ " : " ++ show vt ++ ">" - show VIrr = "." - show (VMeasured mu tv) = parens $ show mu ++ " -> " ++ show tv - show (VGuard beta tv) = parens $ show beta ++ " -> " ++ show tv - show (VBelow ltle v) = show ltle ++ " " ++ show v - - show (VQuant pisig x (Domain (VBelow ltle v) ki dec) bv) - | (ltle,v) /= (Le,VInfty) = - parens $ (\ p -> if p==defaultPol then "" else show p) (polarity dec) ++ - (if erased dec then brackets binding else parens binding) - ++ " " ++ show pisig ++ " " ++ showSkipLambda bv - where binding = show x ++ " " ++ show ltle ++ " " ++ show v - - show (VQuant pisig x (Domain av ki dec) bv) = - parens $ (\ p -> if p==defaultPol then "" else show p) (polarity dec) ++ - (if erased dec then brackets binding - else if emptyName x then s1 else parens binding) - ++ " " ++ show pisig ++ " " ++ showSkipLambda bv - where s1 = s2 ++ s0 - s2 = show av - s3 = show ki - s0 = if ki == defaultKind || s2 == s3 then "" else "::" ++ s3 - binding = if emptyName x then s1 else show x ++ " : " ++ s1 - - show (VLam x env e) = "(\\" ++ show x ++ " -> " ++ show e ++ showEnv env ++ ")" - show (VConst v) = "(\\ _ -> " ++ show v ++ ")" - show (VAbs x i v valu) = "(\\" ++ show x ++ "@" ++ show i ++ show v ++ showValuation valu ++ ")" - show (VUp v vt) = "(" ++ show v ++ " Up " ++ show vt ++ ")" - -showSkipLambda v = - case v of - (VLam x env e) -> show e ++ showEnv env - (VConst v) -> show v - (VAbs x i v valu) -> show v ++ showValuation valu - v -> show v - -showVals :: [Val] -> String -showVals [] = "" -showVals (v:vl) = show v ++ (if null vl then "" else " " ++ showVals vl) - --- environment --------------------------------------------------- - -emptyEnv :: Environ a -emptyEnv = Environ [] Nothing - -appendEnv :: Environ a -> Environ a -> Environ a -appendEnv (Environ rho mmeas) (Environ rho' mmeas') = - Environ (rho ++ rho') (orM mmeas mmeas') - --- | enviroment extension / update -update :: Environ a -> Name -> a -> Environ a -update env n v | emptyName n = env - | otherwise = env { envMap = (n,v) : envMap env } - -lookupPure :: Show a => Environ a -> Name -> a -lookupPure rho x = - case lookup x (envMap rho) of - Just v -> v - Nothing -> error $ "lookupPure: unbound identifier " ++ show x ++ " in environment " ++ show rho - -lookupEnv :: Monad m => Environ a -> Name -> m a -lookupEnv rho x = - case lookup x (envMap rho) of - Just v -> return $ v - Nothing -> fail $ "lookupEnv: unbound identifier " ++ show x -- ++ " in environment " ++ show rho -{- -lookupEnv :: Monad m => Environ a -> Name -> m a -lookupEnv [] n = fail $ "lookupEnv: identifier " ++ show n ++ " not bound" -lookupEnv ((x,v):xs) n = if x == n then return v - else lookupEnv xs n --} - -showValuation :: Valuation -> String -showValuation (Valuation []) = "" -showValuation (Valuation tau) = "{" ++ Util.showList ", " (\(i,v) -> show i ++ " = " ++ show v) tau ++ "}" - -showEnv :: Environ Val -> String -showEnv (Environ [] Nothing) = "" -showEnv (Environ rho Nothing) = "{" ++ showEnv' rho ++ "}" -showEnv (Environ [] (Just mu)) = "{ measure=" ++ show mu ++ " }" -showEnv (Environ rho (Just mu)) = "{" ++ showEnv' rho ++ " | measure=" ++ show mu ++ " }" - -showEnv' :: EnvMap -> String -showEnv' = Util.showList ", " (\ (n,v) -> show n ++ " = " ++ show v) diff --git a/Value.hs-boot b/Value.hs-boot deleted file mode 100644 --- a/Value.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module Value where - -import {-# SOURCE #-} Abstract - -data Val -instance Eq Val -instance Ord Val -instance Show Val - -type TeleVal = [TBinding Val] diff --git a/Warshall.hs b/Warshall.hs deleted file mode 100644 --- a/Warshall.hs +++ /dev/null @@ -1,433 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} - -module Warshall where - -{- construct a graph from constraints - - x + n <= y becomes x ---(-n)---> y - x <= n + y becomes x ---(+n)---> y - -the default edge (= no edge is) labelled with infinity - -building the graph involves keeping track of the node names. -We do this in a finite map, assigning consecutive numbers to nodes. --} - - -import Control.Monad.State -import Data.Maybe -- fromJust -import Data.Array -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.List as List - -import Debug.Trace -import Util - - -traceSolve msg a = a -- trace msg a -traceSolveM msg = return () -- traceM msg -{- -traceSolve msg a = trace msg a -traceSolveM msg = traceM msg --} - - --- semi rings ---------------------------------------------------- - -class SemiRing a where - oplus :: a -> a -> a - otimes :: a -> a -> a - ozero :: a -- neutral for oplus, dominant for otimes - oone :: a -- neutral for otimes - -type Matrix a = Array (Int,Int) a - --- assuming a square matrix -warshall :: SemiRing a => Matrix a -> Matrix a -warshall a0 = loop r a0 where - b@((r,c),(r',c')) = bounds a0 -- assuming r == c and r' == c' - loop k a | k <= r' = - loop (k+1) (array b [ ((i,j), - (a!(i,j)) `oplus` ((a!(i,k)) `otimes` (a!(k,j)))) - | i <- [r..r'], j <- [c..c'] ]) - | otherwise = a - --- edge weight in the graph, forming a semi ring - -data Weight = Finite Int | Infinite - deriving (Eq) - -inc :: Weight -> Int -> Weight -inc Infinite n = Infinite -inc (Finite k) n = Finite (k + n) - -instance Show Weight where - show (Finite i) = show i - show Infinite = "." - -instance Ord Weight where - a <= Infinite = True - Infinite <= b = False - Finite a <= Finite b = a <= b - -instance SemiRing Weight where - oplus = min - - otimes Infinite _ = Infinite - otimes _ Infinite = Infinite - otimes (Finite a) (Finite b) = Finite (a + b) - - ozero = Infinite - oone = Finite 0 - --- constraints --------------------------------------------------- - --- nodes of the graph are either --- * flexible variables (with identifiers drawn from Int), --- * rigid variables (also identified by Ints), or --- * constants (like 0, infinity, or anything between) - -data Node rigid - = Rigid rigid - | Flex FlexId - deriving (Eq, Ord) - -instance Show rigid => Show (Node rigid) where - show (Flex i) = "?" ++ show i - show (Rigid r) = show r - -data Rigid = RConst Weight - | RVar RigidId - deriving (Eq, Ord) - -instance Show Rigid where - show (RVar i) = "v" ++ show i - show (RConst Infinite) = "#" - show (RConst (Finite n)) = show n - -type NodeId = Int -type RigidId = Int -type FlexId = Int -type Scope = RigidId -> Bool --- which rigid variables a flex may be instatiated to - -infinite (RConst Infinite) = True -infinite _ = False - --- isBelow r w r' --- checks, if r and r' are connected by w (meaning w not infinite) --- wether r + w <= r' --- precondition: not the same rigid variable -isBelow :: Rigid -> Weight -> Rigid -> Bool -isBelow _ Infinite _ = True -isBelow _ n (RConst Infinite) = True --- isBelow (RConst Infinite) n (RConst (Finite _)) = False -isBelow (RConst (Finite i)) (Finite n) (RConst (Finite j)) = i + n <= j -isBelow _ _ _ = False -- rigid variables are not related - --- a constraint is an edge in the graph -data Constrnt edgeLabel rigid flexScope - = NewFlex FlexId flexScope - | Arc (Node rigid) edgeLabel (Node rigid) --- Arc v1 k v2 at least one of v1,v2 is a VMeta (Flex), --- the other a VMeta or a VGen (Rigid) --- if k <= 0 this means $^(-k) v1 <= v2 --- otherwise v1 <= $^k v3 - -type Constraint = Constrnt Weight Rigid Scope - -arc :: Node Rigid -> Int -> Node Rigid -> Constraint -arc a k b = Arc a (Finite k) b - -instance Show Constraint where - show (NewFlex i s) = "SizeMeta(?" ++ show i ++ ")" - show (Arc v1 (Finite k) v2) - | k == 0 = show v1 ++ "<=" ++ show v2 - | k < 0 = show v1 ++ "+" ++ show (-k) ++ "<=" ++ show v2 - | otherwise = show v1 ++ "<=" ++ show v2 ++ "+" ++ show k - -type Constraints = [Constraint] - -emptyConstraints = [] - --- graph (matrix) ------------------------------------------------ - -data Graph edgeLabel rigid flexScope = Graph - { flexScope :: Map FlexId flexScope -- scope for each flexible var - , nodeMap :: Map (Node rigid) NodeId -- node labels to node numbers - , intMap :: Map NodeId (Node rigid) -- node numbers to node labels - , nextNode :: NodeId -- number of nodes (n) - , graph :: NodeId -> NodeId -> edgeLabel -- the edges (restrict to [0..n[) - } - --- the empty graph: no nodes, edges are all undefined (infinity weight) -initGraph :: SemiRing edgeLabel => Graph edgeLabel rigid flexScope -initGraph = Graph Map.empty Map.empty Map.empty 0 (\ x y -> ozero) - --- the Graph Monad, for constructing a graph iteratively -type GM edgeLabel rigid flexScope = State (Graph edgeLabel rigid flexScope) - -addFlex :: FlexId -> flexScope -> GM edgeLabel rigid flexScope () -addFlex x scope = do - st <- get - put $ st { flexScope = Map.insert x scope (flexScope st) } - - --- i <- addNode n returns number of node n. if not present, it is added first -addNode :: (Eq rigid, Ord rigid) => (Node rigid) -> GM edgeLabel rigid flexScope Int -addNode n = do - st <- get - case Map.lookup n (nodeMap st) of - Just i -> return i - Nothing -> do let i = nextNode st - put $ st { nodeMap = Map.insert n i (nodeMap st) - , intMap = Map.insert i n (intMap st) - , nextNode = i + 1 - } - return i - --- addEdge n1 k n2 --- improves the weight of egde n1->n2 to be at most k --- also adds nodes if not yet present -addEdge :: (Eq rigid, Ord rigid, SemiRing edgeLabel) => (Node rigid) -> edgeLabel -> (Node rigid) -> GM edgeLabel rigid flexScope () -addEdge n1 k n2 = do - i1 <- addNode n1 - i2 <- addNode n2 - st <- get - let graph' x y = if (x,y) == (i1,i2) then k `oplus` (graph st) x y - else graph st x y - put $ st { graph = graph' } - -addConstraint :: (Eq rigid, Ord rigid, SemiRing edgeLabel) => - Constrnt edgeLabel rigid flexScope -> GM edgeLabel rigid flexScope () -addConstraint (NewFlex x scope) = do - addFlex x scope - addEdge (Flex x) oone (Flex x) -- add dummy edge to make sure each meta variable - -- is in the matrix and gets solved -addConstraint (Arc n1 k n2) = addEdge n1 k n2 - -buildGraph :: (Eq rigid, Ord rigid, SemiRing edgeLabel) => - [Constrnt edgeLabel rigid flexScope] -> Graph edgeLabel rigid flexScope -buildGraph cs = execState (mapM_ addConstraint cs) initGraph - -mkMatrix :: Int -> (Int -> Int -> a) -> Matrix a -mkMatrix n g = array ((0,0),(n-1,n-1)) - [ ((i,j), g i j) | i <- [0..n-1], j <- [0..n-1]] - --- displaying matrices with row and column labels -------------------- - --- a matrix with row descriptions in b and column descriptions in c -data LegendMatrix a b c = LegendMatrix - { matrix :: Matrix a - , rowdescr :: Int -> b - , coldescr :: Int -> c - } - -instance (Show a, Show b, Show c) => Show (LegendMatrix a b c) where - show (LegendMatrix m rd cd) = - -- first show column description - let ((r,c),(r',c')) = bounds m - in foldr (\ j s -> "\t" ++ show (cd j) ++ s) "" [c .. c'] ++ - -- then output rows - foldr (\ i s -> "\n" ++ show (rd i) ++ - foldr (\ j t -> "\t" ++ show (m!(i,j)) ++ t) - (s) - [c .. c']) - "" [r .. r'] - --- solving the constraints ------------------------------------------- - --- a solution assigns to each flexible variable a size expression --- which is either a constant or a v + n for a rigid variable v -type Solution = Map Int MaxExpr - -emptySolution :: Solution -emptySolution = Map.empty - -extendSolution :: Solution -> Int -> SizeExpr -> Solution -extendSolution subst k v = Map.insertWith (++) k [v] subst - -type MaxExpr = [SizeExpr] --- newtype MaxExpr = MaxExpr { sizeExprs :: [SizeExpr] } deriving (Show) - -data SizeExpr = SizeVar Int Int -- e.g. x + 5 - | SizeConst Weight -- a number or infinity - -instance Show SizeExpr where - show (SizeVar n 0) = show (Rigid (RVar n)) - show (SizeVar n k) = show (Rigid (RVar n)) ++ "+" ++ show k - show (SizeConst (Finite i)) = show i - show (SizeConst Infinite) = "#" - --- sizeRigid r n returns the size expression corresponding to r + n -sizeRigid :: Rigid -> Int -> SizeExpr -sizeRigid (RConst k) n = SizeConst (inc k n) -sizeRigid (RVar i) n = SizeVar i n - -{- -apply :: SizeExpr -> Solution -> SizeExpr -apply e@(SizeExpr (Rigid _) _) phi = e -apply e@(SizeExpr (Flex x) i) phi = case Map.lookup x phi of - Nothing -> e - Just (SizeExpr v j) -> SizeExpr v (i + j) - -after :: Solution -> Solution -> Solution -after psi phi = Map.map (\ e -> e `apply` phi) psi --} - -{- -solve :: Constraints -> Maybe Solution -solve cs = if any (\ x -> x < Finite 0) d then Nothing - else Map. - where gr = buildGraph cs - n = nextNode gr - m = mkMatrix n (graph gr) - m' = warshall m - d = [ m!(i,i) | i <- [0 .. (n-1)] ] - ns = keys (nodeMap gr) --} - -{- compute solution - -a solution CANNOT exist if - - v < v for a rigid variable v - - v <= v' for rigid variables v,v' - - x < v for a flexible variable x and a rigid variable v - -thus, for each flexible x, only one of the following cases is possible - - r+n <= x+m <= infty for a unique rigid r (meaning r --(m-n)--> x) - x <= r+n for a unique rigid r (meaning x --(n)--> r) - -we are looking for the least values for flexible variables that solve -the constraints. Algorithm - -while flexible variables and rigid rows left - find a rigid variable row i - for all flexible columns j - if i --n--> j with n<=0 (meaning i+n <= j) then j = i + n - -while flexible variables j left - search the row j for entry i - if j --n--> i with n >= 0 (meaning j <= i + n) then j = i - - --} - -solve :: Constraints -> Maybe Solution -solve cs = traceSolve (show lm0) $ traceSolve (show lm) $ traceSolve (show cs) $ - let solution = if solvable then loop1 rigids emptySolution - else Nothing - in traceSolve ("solution = " ++ show solution) $ - solution - where -- compute the graph and its transitive closure m - gr = buildGraph cs - n = nextNode gr -- number of nodes - m0 = mkMatrix n (graph gr) - m = warshall m0 - - -- tracing only: build output version of transitive graph - legend i = fromJust $ Map.lookup i (intMap gr) -- trace only - lm0 = LegendMatrix m0 legend legend -- trace only - lm = LegendMatrix m legend legend -- trace only - - -- compute the sets of flexible and rigid node numbers - ns = Map.keys (nodeMap gr) - -- a set of flexible variables - flexs = foldl (\ l k -> case k of (Flex i) -> i : l - (Rigid _) -> l) [] ns - -- a set of rigid variables - rigids = foldl (\ l k -> case k of (Flex _) -> l - (Rigid i) -> i : l) [] ns - - -- rigid matrix indices - rInds = foldl (\ l r -> let Just i = Map.lookup (Rigid r) (nodeMap gr) - in i : l) [] rigids - - -- check whether there is a solution - -- d = [ m!(i,i) | i <- [0 .. (n-1)] ] -- diagonal --- a rigid variable might not be less than it self, so no -.. on the --- rigid part of the diagonal - solvable = all (\ x -> x >= oone) [ m!(i,i) | i <- rInds ] && --- a rigid variable might not be bounded below by infinity or --- bounded above by a constant --- it might not be related to another rigid variable - all (\ (r, r') -> r == r' || - let Just row = (Map.lookup (Rigid r) (nodeMap gr)) - Just col = (Map.lookup (Rigid r') (nodeMap gr)) - edge = m!(row,col) - in isBelow r edge r' ) - [ (r,r') | r <- rigids, r' <- rigids ] - && --- a flexible variable might not be strictly below a rigid variable - all (\ (x, v) -> - let Just row = (Map.lookup (Flex x) (nodeMap gr)) - Just col = (Map.lookup (Rigid (RVar v)) (nodeMap gr)) - edge = m!(row,col) - in edge >= Finite 0) - [ (x,v) | x <- flexs, (RVar v) <- rigids ] - - - inScope :: FlexId -> Rigid -> Bool - inScope x (RConst _) = True - inScope x (RVar v) = case Map.lookup x (flexScope gr) of - Just scope -> scope v - Nothing -> error $ "Warshall.inScope panic: flexible " ++ show x ++ " does not carry scope info when assigning it rigid variable " ++ show v - -{- loop1 - -while flexible variables and rigid rows left - find a rigid variable row i - for all flexible columns j - if i --n--> j with n<=0 (meaning i + n <= j) then - add i + n to the solution of j - --} - - loop1 :: [Rigid] -> Solution -> Maybe Solution - loop1 (r:rgds) subst = loop1 rgds subst' where - row = fromJust $ Map.lookup (Rigid r) (nodeMap gr) - subst' = - foldl (\ sub f -> - let col = fromJust $ Map.lookup (Flex f) (nodeMap gr) - in case (True -- inScope f r -- SEEMS WRONG TO IGNORE THINGS NOT IN SCOPE - , m!(row,col)) of --- Finite z | z <= 0 -> - (True, Finite z) -> - let trunc z | z >= 0 = 0 - | otherwise = -z - in extendSolution sub f (sizeRigid r (trunc z)) - _ -> sub - ) subst flexs - loop1 [] subst = case flexs List.\\ (Map.keys subst) of - [] -> Just subst - flexs' -> loop2 flexs' subst - -{- loop2 - -while flexible variables j left - search the row j for entry i - if j --n--> i with n >= 0 (meaning j <= i + n) then j = i - --} - loop2 :: [FlexId] -> Solution -> Maybe Solution - loop2 [] subst = Just subst - loop2 (f:flxs) subst = loop3 0 subst - where row = fromJust $ Map.lookup (Flex f) (nodeMap gr) - loop3 col subst | col >= n = - -- default to infinity - loop2 flxs (extendSolution subst f (SizeConst Infinite)) - loop3 col subst = - case Map.lookup col (intMap gr) of - Just (Rigid r) | not (infinite r) -> - case (True -- inScope f r - ,m!(row,col)) of - (True, Finite z) | z >= 0 -> - loop2 flxs (extendSolution subst f (sizeRigid r z)) - (_, Infinite) -> loop3 (col+1) subst - _ -> Nothing - _ -> loop3 (col+1) subst diff --git a/dist/build/miniagda/miniagda-tmp/Lexer.hs b/dist/build/miniagda/miniagda-tmp/Lexer.hs --- a/dist/build/miniagda/miniagda-tmp/Lexer.hs +++ b/dist/build/miniagda/miniagda-tmp/Lexer.hs @@ -1,5 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP,MagicHash #-} -{-# LINE 2 "Lexer.x" #-} +{-# LINE 2 "src/Lexer.x" #-} module Lexer where @@ -12,11 +13,9 @@ #endif #if __GLASGOW_HASKELL__ >= 503 import Data.Array -import Data.Char (ord) import Data.Array.Base (unsafeAt) #else import Array -import Char (ord) #endif #if __GLASGOW_HASKELL__ >= 503 import GHC.Exts @@ -27,6 +26,53 @@ {-# LINE 1 "templates/wrappers.hs" #-} {-# LINE 1 "" #-} {-# LINE 1 "" #-} +{-# LINE 8 "" #-} +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{-# LINE 8 "" #-} {-# LINE 1 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Alex wrapper code. @@ -34,9 +80,15 @@ -- This code is in the PUBLIC DOMAIN; you may copy it freely and use -- it for any purpose whatsoever. + + + + + import Data.Word (Word8) -{-# LINE 22 "templates/wrappers.hs" #-} +{-# LINE 28 "templates/wrappers.hs" #-} +import Data.Char (ord) import qualified Data.Bits -- | Encode a Haskell String to a list of Word8 values, in UTF8 format. @@ -87,11 +139,11 @@ in p' `seq` Just (b, (p', c, bs, s)) -{-# LINE 92 "templates/wrappers.hs" #-} +{-# LINE 101 "templates/wrappers.hs" #-} -{-# LINE 106 "templates/wrappers.hs" #-} +{-# LINE 119 "templates/wrappers.hs" #-} -{-# LINE 121 "templates/wrappers.hs" #-} +{-# LINE 137 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Token positions @@ -111,7 +163,7 @@ alexStartPos = AlexPn 0 1 1 alexMove :: AlexPosn -> Char -> AlexPosn -alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+alex_tab_size-1) `div` alex_tab_size)*alex_tab_size+1) alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1 alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) @@ -119,27 +171,27 @@ -- ----------------------------------------------------------------------------- -- Default monad -{-# LINE 242 "templates/wrappers.hs" #-} +{-# LINE 271 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Monad (with ByteString input) -{-# LINE 333 "templates/wrappers.hs" #-} +{-# LINE 374 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper -{-# LINE 360 "templates/wrappers.hs" #-} +{-# LINE 401 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper, ByteString version -{-# LINE 378 "templates/wrappers.hs" #-} +{-# LINE 421 "templates/wrappers.hs" #-} -{-# LINE 392 "templates/wrappers.hs" #-} +{-# LINE 437 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- @@ -162,7 +214,7 @@ -- ----------------------------------------------------------------------------- -- Posn wrapper, ByteString version -{-# LINE 424 "templates/wrappers.hs" #-} +{-# LINE 470 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- @@ -170,6 +222,8 @@ -- For compatibility with previous versions of Alex, and because we can. +alex_tab_size :: Int +alex_tab_size = 8 alex_base :: AlexAddr alex_base = AlexA# "\xf8\xff\xff\xff\x0a\x00\x00\x00\xdd\x00\x00\x00\xca\x00\x00\x00\x5d\x01\x00\x00\x30\x02\x00\x00\xb0\x02\x00\x00\x9f\x01\x00\x00\x00\x00\x00\x00\x21\x03\x00\x00\x00\x00\x00\x00\xa1\x03\x00\x00\x21\x04\x00\x00\x21\x05\x00\x00\xe1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x05\x00\x00\x00\x00\x00\x00\x93\x05\x00\x00\x93\x06\x00\x00\x53\x06\x00\x00\x00\x00\x00\x00\xfd\xff\xff\xff\x49\x07\x00\x00\x1c\x08\x00\x00\x00\x00\x00\x00\x2d\x07\x00\x00\xf5\x08\x00\x00\x49\x09\x00\x00\x9d\x09\x00\x00\xf1\x09\x00\x00\x45\x0a\x00\x00\x99\x0a\x00\x00\xed\x0a\x00\x00\x41\x0b\x00\x00\x95\x0b\x00\x00\xe9\x0b\x00\x00\x3d\x0c\x00\x00\x91\x0c\x00\x00\xe5\x0c\x00\x00\x39\x0d\x00\x00\x8d\x0d\x00\x00\xe1\x0d\x00\x00\x35\x0e\x00\x00\x89\x0e\x00\x00\xdd\x0e\x00\x00\x31\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x0f\x00\x00\xde\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\xff\xff\xff\xe1\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\xff\xff\xff\x00\x00\x00\x00\x46\x00\x00\x00\x2d\x10\x00\x00\x81\x10\x00\x00\xd5\x10\x00\x00\x29\x11\x00\x00\x7d\x11\x00\x00\xd1\x11\x00\x00\x25\x12\x00\x00\x79\x12\x00\x00\xcd\x12\x00\x00\x21\x13\x00\x00\x75\x13\x00\x00\xc9\x13\x00\x00\x1d\x14\x00\x00\x71\x14\x00\x00\xc5\x14\x00\x00\x19\x15\x00\x00\x6d\x15\x00\x00\xc1\x15\x00\x00\x15\x16\x00\x00\x69\x16\x00\x00\xbd\x16\x00\x00\x11\x17\x00\x00\x65\x17\x00\x00\xb9\x17\x00\x00\x0d\x18\x00\x00\x61\x18\x00\x00\xb5\x18\x00\x00\x09\x19\x00\x00\x5d\x19\x00\x00\xb1\x19\x00\x00\x05\x1a\x00\x00\x59\x1a\x00\x00\xad\x1a\x00\x00\x01\x1b\x00\x00\x55\x1b\x00\x00\xa9\x1b\x00\x00\xfd\x1b\x00\x00\x51\x1c\x00\x00\xa5\x1c\x00\x00\xf9\x1c\x00\x00\x4d\x1d\x00\x00\xa1\x1d\x00\x00\xf5\x1d\x00\x00\x49\x1e\x00\x00\x9d\x1e\x00\x00\xf1\x1e\x00\x00\x45\x1f\x00\x00\x99\x1f\x00\x00\xed\x1f\x00\x00\x41\x20\x00\x00\x95\x20\x00\x00\xe9\x20\x00\x00\x3d\x21\x00\x00\x91\x21\x00\x00\xe5\x21\x00\x00\x39\x22\x00\x00\x8d\x22\x00\x00\xe1\x22\x00\x00\x35\x23\x00\x00\x89\x23\x00\x00\xdd\x23\x00\x00\x31\x24\x00\x00\x85\x24\x00\x00\xd9\x24\x00\x00\x2d\x25\x00\x00\x81\x25\x00\x00\xd5\x25\x00\x00\x29\x26\x00\x00\x7d\x26\x00\x00\xd1\x26\x00\x00\x25\x27\x00\x00\x79\x27\x00\x00\xcd\x27\x00\x00\x21\x28\x00\x00\x75\x28\x00\x00\xc9\x28\x00\x00\x1d\x29\x00\x00\x71\x29\x00\x00\xc5\x29\x00\x00\x19\x2a\x00\x00\x6d\x2a\x00\x00"# @@ -183,7 +237,7 @@ alex_deflt = AlexA# "\xff\xff\x05\x00\x05\x00\xff\xff\xff\xff\x05\x00\xff\xff\x0f\x00\x0f\x00\x08\x00\x08\x00\xff\xff\xff\xff\x05\x00\x05\x00\x05\x00\x12\x00\x12\x00\x16\x00\x16\x00\x18\x00\x18\x00\x18\x00\xff\xff\x18\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# alex_accept = listArray (0::Int,160) [AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAcc (alex_action_3),AlexAcc (alex_action_4),AlexAcc (alex_action_5),AlexAcc (alex_action_6),AlexAcc (alex_action_7),AlexAcc (alex_action_8),AlexAcc (alex_action_9),AlexAcc (alex_action_10),AlexAcc (alex_action_11),AlexAcc (alex_action_12),AlexAcc (alex_action_13),AlexAcc (alex_action_14),AlexAcc (alex_action_15),AlexAcc (alex_action_16),AlexAcc (alex_action_17),AlexAcc (alex_action_18),AlexAcc (alex_action_19),AlexAcc (alex_action_20),AlexAcc (alex_action_21),AlexAcc (alex_action_22),AlexAcc (alex_action_23),AlexAcc (alex_action_24),AlexAcc (alex_action_25),AlexAcc (alex_action_26),AlexAcc (alex_action_27),AlexAcc (alex_action_28),AlexAcc (alex_action_29),AlexAcc (alex_action_30),AlexAcc (alex_action_31),AlexAcc (alex_action_32),AlexAcc (alex_action_33),AlexAcc (alex_action_34),AlexAcc (alex_action_35),AlexAcc (alex_action_36),AlexAcc (alex_action_37),AlexAcc (alex_action_38),AlexAcc (alex_action_39),AlexAcc (alex_action_40),AlexAcc (alex_action_41),AlexAcc (alex_action_42),AlexAcc (alex_action_43),AlexAcc (alex_action_44),AlexAcc (alex_action_45),AlexAcc (alex_action_46),AlexAcc (alex_action_47),AlexAcc (alex_action_48),AlexAcc (alex_action_49),AlexAcc (alex_action_50),AlexAcc (alex_action_51),AlexAcc (alex_action_52),AlexAcc (alex_action_53),AlexAcc (alex_action_54),AlexAcc (alex_action_55),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_57)] -{-# LINE 80 "Lexer.x" #-} +{-# LINE 80 "src/Lexer.x" #-} data Token = Id String AlexPosn | QualId (String, String) AlexPosn @@ -372,6 +426,53 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "" #-} {-# LINE 1 "" #-} +{-# LINE 9 "" #-} +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{-# LINE 9 "" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- ----------------------------------------------------------------------------- -- ALEX TEMPLATE @@ -428,8 +529,8 @@ narrow32Int# i where i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) @@ -469,30 +570,30 @@ alexScanUser user input (I# (sc)) = case alex_scan_tkn user input 0# input sc AlexNone of - (AlexNone, input') -> - case alexGetByte input of - Nothing -> + (AlexNone, input') -> + case alexGetByte input of + Nothing -> - AlexEOF - Just _ -> + AlexEOF + Just _ -> - AlexError input' + AlexError input' - (AlexLastSkip input'' len, _) -> + (AlexLastSkip input'' len, _) -> - AlexSkip input'' len + AlexSkip input'' len - (AlexLastAcc k input''' len, _) -> + (AlexLastAcc k input''' len, _) -> - AlexToken input''' len k + AlexToken input''' len k -- Push the input through the DFA, remembering the most recent accepting @@ -501,7 +602,7 @@ alex_scan_tkn user orig_input len input s last_acc = input `seq` -- strict in the input let - new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) + new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) in new_acc `seq` case alexGetByte input of @@ -515,23 +616,23 @@ base = alexIndexInt32OffAddr alex_base s offset = (base +# ord_c) check = alexIndexInt16OffAddr alex_check offset - + new_s = if GTE(offset,0#) && EQ(check,ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in case new_s of - -1# -> (new_acc, input) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) + -1# -> (new_acc, input) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) -- note that the length is increased ONLY if this is the 1st byte in a char encoding) - new_input new_s new_acc + new_input new_s new_acc } where - check_accs (AlexAccNone) = last_acc - check_accs (AlexAcc a ) = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkip) = AlexLastSkip input (I# (len)) + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip) = AlexLastSkip input (I# (len)) {-# LINE 198 "templates/GenericTemplate.hs" #-} data AlexLastAcc a @@ -540,15 +641,11 @@ | AlexLastSkip !AlexInput !Int instance Functor AlexLastAcc where - fmap f AlexNone = AlexNone + fmap _ AlexNone = AlexNone fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z - fmap f (AlexLastSkip x y) = AlexLastSkip x y + fmap _ (AlexLastSkip x y) = AlexLastSkip x y data AlexAcc a user = AlexAccNone | AlexAcc a | AlexAccSkip -{-# LINE 242 "templates/GenericTemplate.hs" #-} - --- used by wrappers -iUnbox (I# (i)) = i diff --git a/dist/build/miniagda/miniagda-tmp/Parser.hs b/dist/build/miniagda/miniagda-tmp/Parser.hs --- a/dist/build/miniagda/miniagda-tmp/Parser.hs +++ b/dist/build/miniagda/miniagda-tmp/Parser.hs @@ -13,8 +13,10 @@ import Concrete (Name,patApp) import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts +import Control.Applicative(Applicative(..)) +import Control.Monad (ap) --- parser produced by Happy Version 1.19.3 +-- parser produced by Happy Version 1.19.5 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -2403,6 +2405,12 @@ happyIdentity = HappyIdentity happyRunIdentity (HappyIdentity a) = a +instance Functor HappyIdentity where + fmap f (HappyIdentity a) = HappyIdentity (f a) + +instance Applicative HappyIdentity where + pure = return + (<*>) = ap instance Monad HappyIdentity where return = HappyIdentity (HappyIdentity p) >>= q = q p @@ -2428,8 +2436,54 @@ parseError (x : xs) = error ("Parse error at token " ++ T.prettyTok x) {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} {-# LINE 1 "" #-} +{-# LINE 10 "" #-} +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{-# LINE 10 "" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp diff --git a/src/Abstract.hs b/src/Abstract.hs new file mode 100644 --- /dev/null +++ b/src/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 :: (a -> Maybe a) -> Measure a -> Maybe (Measure a) +applyLastM f (Measure mu) = Measure <$> loop mu + where loop [] = fail "empty measure" + loop [e] = (:[]) <$> f e + loop (e:es) = (e:) <$> loop es + +instance HasPred a => HasPred (Measure a) where + predecessor mu = applyLastM predecessor mu + +data Bound a = Bound { ltle :: LtLe, leftBound :: Measure a, rightBound :: Measure a } -- mu < mur of mu <= mu' + deriving (Eq,Ord,Functor,Foldable,Traversable) + +instance Show a => Show (Bound a) where + show (Bound Lt mu1 mu2) = show mu1 ++ " < " ++ show mu2 + show (Bound Le mu1 mu2) = show mu1 ++ " <= " ++ show mu2 + +{- +instance (HasPred a, Show a) => Show (Bound a) where + show (Bound mu1 mu2) = case predecessor mu2 of + Just mu2 -> show mu1 ++ " <= " ++ show mu2 + Nothing -> show mu1 ++ " < " ++ show mu2 +-} + +-- TODO: properly implement bounds mu <= mu' such that mu <= # is +-- represented correctly + +-- tagging expressions ----------------------------------------------- + +data Tag + = Erased -- ^ Expression will be erased. + | Cast -- ^ Expression will need to be casted. + deriving (Eq,Ord,Show) + +type Tags = [Tag] + +inTags :: Tag -> Tags -> Bool +inTags = elem + +noTags = [] + +data Tagged a = Tagged { tags :: Tags , unTag :: a } + deriving (Eq,Ord,Functor,Foldable,Traversable) + +instance Show a => Show (Tagged a) where + show (Tagged tags a) = + bracketsIf (Erased `inTags` tags) $ + showCast (Cast `inTags` tags) $ + show a + +showCast :: Bool -> String -> String +showCast True s = "'cast" ++ Util.parens s +showCast False s = s + +instance Pretty a => Pretty (Tagged a) where + prettyPrec k (Tagged [] a) = prettyPrec k a + prettyPrec _ (Tagged tags a) = + prettyErased (Erased `inTags` tags) $ + prettyCast (Cast `inTags` tags) $ + pretty a + +prettyErased True doc = brackets doc +prettyErased False doc = doc + +prettyCast True doc = text "'cast" <> PP.parens doc +prettyCast False doc = doc + +-- expressions ------------------------------------------------------- + +data Expr + = Sort (Sort Expr) -- ^ @Size@ @Set@ @CoSet@ + -- sizes + | Zero + | Succ Expr + | Infty + | Max [Expr] -- ^ (list has at least 2 elements) + | Plus [Expr] -- ^ (list has at least 2 elements) + -- identifiers + | Meta MVar -- ^ meta-variable + | Var Name -- ^ variables are named + | Def DefId -- ^ identifiers in the signature +{- + | Con Co Name [Expr] -- constructors applied to arguments + | Def Name -- fun/cofun ? + | Let Name -- definition (non-recursive) +-} + -- dependently typed lambda calculus + | Record RecInfo [(Name,Expr)] -- ^ record { p1 = e1; ...; pn = en } + | Proj PrePost Name -- ^ proj _ or _ .proj + | Pair Expr Expr + | Case Expr (Maybe Type) [Clause] + -- ^ Type is @Nothing@ in input, @Just@ after t.c. + | LLet LBind Telescope Expr Expr + -- ^ @let [x : A] = t in u@, @let [x] tel = t in u@ + -- after t.c. @Telescope@ is empty (fused into @LBind@) + | App Expr Expr + | Lam Dec Name Expr + | Quant PiSigma TBind Expr + | Sing Expr Expr -- 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/src/Abstract.hs-boot b/src/Abstract.hs-boot new file mode 100644 --- /dev/null +++ b/src/Abstract.hs-boot @@ -0,0 +1,4 @@ +module Abstract where + +data TBinding a + diff --git a/src/Collection.hs b/src/Collection.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Concrete.hs b/src/Concrete.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Eval.hs b/src/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Eval.hs @@ -0,0 +1,2359 @@ +{-# LANGUAGE TupleSections, FlexibleInstances, FlexibleContexts, NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} + +-- Activate this flag if i < $i should only hold for i < #. +-- #define STRICTINFTY + +module Eval where + +import Prelude hiding (mapM, null, pi) + +import Control.Applicative +import Control.Monad.Identity hiding (mapM) +import Control.Monad.State hiding (mapM) +import Control.Monad.Except hiding (mapM) +import Control.Monad.Reader hiding (mapM) + +import qualified Data.Array as Array +import Data.Maybe -- fromMaybe +import Data.Monoid hiding ((<>)) +import Data.List as List hiding (null) -- find +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Foldable (foldMap) +import Data.Traversable (Traversable, mapM, traverse) +import qualified Data.Traversable as Traversable + +import Debug.Trace (trace) + +import Abstract +import Polarity as Pol +import Value +import TCM +import PrettyTCM +import Warshall -- positivity checking + +import TraceError +import Util + + +traceEta msg a = a -- trace msg a +traceEtaM msg = return () -- traceM msg +{- +traceEta msg a = trace msg a +traceEtaM msg = traceM msg +-} + +traceRecord msg a = a +traceRecordM msg = return () + + +traceMatch msg a = a -- trace msg a +traceMatchM msg = return () -- traceM msg +{- +traceMatch msg a = trace msg a +traceMatchM msg = traceM msg +-} + +traceLoop msg a = a -- trace msg a +traceLoopM msg = return () -- traceM msg +{- +traceLoop msg a = trace msg a +traceLoopM msg = traceM msg +-} + +traceSize msg a = a -- trace msg a +traceSizeM msg = return () -- traceM msg +{- +traceSize msg a = trace msg a +traceSizeM msg = traceM msg +-} + +failValInv :: (MonadError TraceError m) => Val -> m a +failValInv v = throwErrorMsg $ "internal error: value " ++ show v ++ " violates representation invariant" + +-- evaluation with rewriting ------------------------------------- + +{- + +Rewriting rules have the form + + blocked --> pattern + +this means that at the root, at most one rewriting step is possible. +Rewriting rules are considered computational, since they trigger new +(symbolic) computations. At least they have to be applied in + +- pattern matching +- equality checking +When a new rule b --> p is added, b should be in --> normal form. +Otherwise there could be inconsistencies, like adding both rules + + b --> true + b --> false + +If after adding b --> true b is rewritten to nf, then the second rule +would be true --> false, which can be captured by MiniAgda. + +Also, after adding a new rule, it could be used to rewrite the old rules. + +Implementation: + +- add a set of local rewriting rules to the context (not to the state) +- keep values in --> weak head normal form +- untyped equality test between values + + -} + +class Reval a where + reval' :: Valuation -> a -> TypeCheck a + reval :: a -> TypeCheck a + reval = reval' emptyVal + +instance Reval a => Reval (Maybe a) where + reval' valu ma = Traversable.traverse (reval' valu) ma + +instance Reval b => Reval (a,b) where + reval' valu (x,v) = (x,) <$> reval' valu v + +instance Reval a => Reval [a] where + reval' valu vs = mapM (reval' valu) vs + +instance Reval Env where + reval' valu (Environ rho mmeas) = + flip Environ mmeas <$> reval' valu rho + -- no need to reevaluate mmeas, since only sizes + +-- | When combining valuations, the old one takes priority. +-- @[sigma][tau]v = [[sigma]tau]v@ +instance Reval Valuation where + reval' valu (Valuation valu') = Valuation . (++ valuation valu) <$> + reval' valu valu' + +instance Reval a => Reval (Measure a) where + reval' valu beta = Traversable.traverse (reval' valu) beta + +instance Reval a => Reval (Bound a) where + reval' valu beta = Traversable.traverse (reval' valu) beta + +instance Reval Val where + reval' valu u = traceLoop ("reval " ++ show u) $ do + let reval v = reval' valu v + reEnv rho = reval' valu rho + reFun fv = reval' valu fv + case u of + VSort (CoSet v) -> VSort . CoSet <$> reval v + VSort{} -> return u + VInfty -> return u + VZero -> return u + VSucc{} -> return u -- no rewriting in size expressions + VMax{} -> return u + VPlus{} -> return u + VProj{} -> return u -- cannot rewrite projection + VPair v1 v2 -> VPair <$> reval v1 <*> reval v2 + VRecord ri rho -> VRecord ri <$> mapAssocM reval rho + + VApp v vl -> do + v' <- reval v + vl' <- mapM reval vl + w <- foldM app v' vl' + reduce w -- since we only have rewrite rules at base types + -- we do not need to reduces prefixes of w + + VDef{} -> return $ VApp u [] -- restore invariant + -- CAN'T rewrite defined fun/data + VGen i -> reduce (valuateGen i valu) -- CAN rewrite variable + + VCase v tv env cl -> do + v' <- reval v + tv' <- reval tv + env' <- reEnv env + evalCase v' tv' env' cl + + VBelow ltle v -> VBelow ltle <$> reval v + VGuard beta v -> VGuard <$> reval beta <*> reval v + VQuant pisig x dom fv -> + VQuant pisig x + <$> Traversable.mapM reval dom + <*> reFun fv + {- + VQuant pisig x dom env b -> do + dom' <- Traversable.mapM reval dom + env' <- reEnv env + return $ VQuant pisig x dom' env' b + -} + VConst v -> VConst <$> reval' valu v + VLam x env e -> flip (VLam x) e <$> reval' valu env + VAbs x i v valu' -> VAbs x i v <$> reval' valu valu' + VUp v tv -> up False ==<< (reval' valu v, reval' valu tv) -- do not force at this point + + VClos env e -> do env' <- reEnv env + return $ VClos env' e + + VMeta i env k -> do env' <- reEnv env + return $ VMeta i env' k + + VSing v tv -> vSing ==<< (reval v, reval tv) + VIrr -> return u + v -> throwErrorMsg $ "NYI : reval " ++ show v + + +-- TODO: singleton Sigma types +-- = 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 + -- throwErrorMsg $ "panic: whnf " ++ show e ++ " : no measure in environment " ++ show env + Just muv' -> return $ VGuard (Bound Lt muv muv') bv + + Quant Pi (TBound (Bound ltle mu mu')) b -> do + muv <- whnfMeasure env mu + muv' <- whnfMeasure env mu' + bv <- whnf env b -- not adding measure constraint to context! + return $ VGuard (Bound ltle muv muv') bv + + Sing e t -> do tv <- whnf env t + sing env e tv + + Pair e1 e2 -> VPair <$> whnf env e1 <*> whnf env e2 + Proj fx n -> return $ VProj fx n + + Record ri@(NamedRec Cons _ _ _) rs -> VRecord ri <$> mapAssocM (whnf env) rs + + -- coinductive and anonymous records are treated lazily: + Record ri rs -> return $ VRecord ri $ mapAssoc (mkClos env) rs + +{- +-- ALT: filter out all erased arguments from application + App e1 el -> do v1 <- whnf env e1 + vl <- liftM (filter (/= VIrr)) $ mapM (whnf env) el + app v1 vl +-} + App f e -> do vf <- whnf env f + let ve = mkClos env e + app vf ve +{- + App e1 el -> do v1 <- whnf env e1 + vl <- mapM (whnf env) el + app v1 vl +-} + + Case e (Just t) cs -> do + v <- whnf env e + vt <- whnf env t + evalCase v vt env cs + -- trace ("case head evaluates to " ++ showVal v) $ return () + + Sort s -> whnfSort env s >>= return . vSort + Infty -> return VInfty + Zero -> return VZero + Succ e1 -> do v <- whnf env e1 -- succ is strict + return $ succSize v + + Max es -> do vs <- mapM (whnf env) es -- max is strict + return $ maxSize vs + Plus es -> do vs <- mapM (whnf env) es -- plus is strict + return $ plusSizes vs + + Def (DefId LetK n) -> do + item <- lookupSymbQ n + whnfClos (definingVal item) + + Def (DefId (ConK DefPat) n) -> whnfClos . definingVal =<< lookupSymbQ n +-- Def (DefId (ConK DefPat) n) -> throwErrorMsg $ "internal error: whnf of defined pattern " ++ show n + Def id -> return $ vDef id +{- + Con co n -> return $ VCon co n + + Def n -> return $ VDef n + + Let n -> do sig <- gets signature + let (LetSig _ v) = lookupSig n sig + return v +-- let (LetSig _ e) = lookupSig n sig +-- whnf [] e +-} + Var y -> lookupEnv env y >>= whnfClos + Ann e -> whnf env (unTag e) -- return VIrr -- NEED TO KEEP because of eta-exp! + Irr -> return VIrr + e -> throwErrorMsg $ "NYI whnf " ++ show e + +whnfMeasure :: Env -> Measure Expr -> TypeCheck (Measure Val) +whnfMeasure rho (Measure mu) = mapM (whnf rho) mu >>= return . Measure + +whnfSort :: Env -> Sort Expr -> TypeCheck (Sort Val) +whnfSort rho (SortC c) = return $ SortC c +whnfSort rho (CoSet e) = whnf rho e >>= return . CoSet +whnfSort rho (Set e) = whnf rho e >>= return . Set + +whnfClos :: Clos -> TypeCheck Val +whnfClos v = -- trace ("whnfClos " ++ show v) $ + case v of + (VClos e rho) -> whnf e rho + -- (VApp (VProj Pre n) [u]) -> app u (VProj Post n) -- NO EFFECT + (VApp (VDef (DefId FunK n)) vl) -> appDef n vl -- THIS IS TO SOLVE A PROBLEM + v -> return v +{- THE PROBLEM IS that + (tail (x Up Stream)) Up Stream is a whnf, because Up Stream is lazy + in equality checking this is a problem when the Up is removed. +-} + +-- evaluate in standard environment +whnf' :: Expr -> TypeCheck Val +whnf' e = do + env <- getEnv + whnf env e + +-- = 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 (throwErrorMsg $ "app: projection " ++ show n ++ " not found in " ++ show u) + whnfClos (lookup n rho) + VDef (DefId FunK n) -> appDef_ n [v] + VApp (VDef (DefId FunK n)) vl -> appDef_ n (vl ++ [v]) + VApp h@(VDef (DefId (ConK Cons) n)) vl -> do + v <- whnfClos v -- inductive constructors are strict! + return $ VApp h (vl ++ [v]) +-- VDef n -> appDef n [v] +-- VApp (VDef id) vl -> VApp (VDef id) (vl ++ [v]) + VApp v1 vl -> return $ VApp v1 (vl ++ [v]) + +-- VSing is a type! +-- VSing u (VQuant Pi x dom fu) -> vSing <$> app u v <*> app fu v + + VLam x env e -> whnf (update env x v) e + VConst u -> whnfClos u + VAbs x i u valu -> flip reval' u =<< updateValu valu i v + VUp u (VQuant Pi x dom fu) -> up False ==<< (app u v, app fu v) + +{- + VUp u1 (VQuant Pi x dom rho b) -> do +{- +-- ALT: erased functions are not applied to their argument! + v1 <- if erased dec then return v else app v [w] -- eta-expand w ?? +-} + v1 <- app u1 v -- eta-expand v ?? + bv <- whnf (update rho x v) b + up False v1 bv +-} + VUp u1 (VApp (VDef (DefId DatK n)) vl) -> do + u' <- force u + app u' v + + VIrr -> return VIrr +{- 2010-11-01 this breaks extraction for System U example + VIrr -> throwErrorMsg $ "app internal error: " ++ show (VApp u [v]) +-} + _ -> return $ VApp u [v] +-- +-- app :: Val -> [Val] -> TypeCheck Val +-- app u [] = return $ u +-- app u c = do +-- case (u,c) of +-- (VApp u2 c2,_) -> app u2 (c2 ++ c) +-- (VLam x env e,(v:vl)) -> do v' <- whnf (update env x v) e +-- app v' vl +-- (VDef n,_) -> appDef n c +-- (VUp v (VPi dec x av rho b), w:wl) -> do +-- {- +-- -- ALT: erased functions are not applied to their argument! +-- v1 <- if erased dec then return v else app v [w] -- eta-expand w ?? +-- -} +-- v1 <- app v [w] -- eta-expand w ?? +-- bv <- whnf (update rho x w) b +-- v2 <- up v1 bv +-- app v2 wl +-- {- +-- -- ALT: VIrr consumes applications +-- (VIrr,_) -> return VIrr +-- -} +-- (VIrr,_) -> throwErrorMsg $ "app internal error: " ++ show (VApp u c) +-- _ -> return $ VApp u c + + +-- unroll a corecursive definition one time (until constructor appears) +force' :: Bool -> Val -> TypeCheck (Bool, Val) +force' b (VSing v tv) = do -- for singleton types, force type! + (b',tv') <- force' b tv + return (b', VSing v tv') +force' b (VUp v tv) = up True v tv >>= \ v' -> return (True, v') -- force eta expansion +force' b (VClos rho e) = do + v <- whnf rho e + force' b v +force' b v@(VDef (DefId FunK n)) = failValInv v +{- + --trace ("force " ++ show v) $ + do sig <- gets signature + case lookupSig n sig of + (FunSig CoInd t cl True) -> do m <- matchClauses [] cl [] + case m of + Just v' -> force v' + Nothing -> return v + _ -> return v +-} +force' b v@(VApp (VDef (DefId FunK n)) vl) = enterDoc (text "force" <+> prettyTCM v) $ + do sig <- gets signature + case Map.lookup n sig of + Just (FunSig isCo t ki ar cl True _) -> traceMatch ("forcing " ++ show v) $ + do m <- matchClauses emptyEnv cl vl + case m of + Just v' -> traceMatch ("forcing " ++ show n ++ " succeeded") $ + force' True v' + Nothing -> traceMatch ("forcing " ++ show n ++ " failed") $ + return (b, v) + _ -> return (b, v) +force' b v = return (b, v) + +force :: Val -> TypeCheck Val +force v = -- trace ("forcing " ++ show v) $ + liftM snd $ force' False v + +-- apply a recursive function +-- corecursive ones are not expanded even if the arity is exceeded +-- this is because a coinductive type needs to be destructed by pattern matching +appDef :: QName -> [Val] -> TypeCheck Val +appDef n vl = --trace ("appDef " ++ n) $ + do + -- identifier might not be in signature yet, e.g. ind.-rec.def. + sig <- gets signature + case (Map.lookup n sig) of + Just (FunSig { isCo = Ind, arity = ar, clauses = cl, isTypeChecked = True }) + | length vl >= fullArity ar -> do + m <- matchClauses emptyEnv cl vl + case m of + Nothing -> return $ VApp (VDef (DefId FunK n)) vl + Just v2 -> return v2 + _ -> return $ VApp (VDef (DefId FunK n)) vl + +-- reflection and reification --------------------------------------- + +-- TODO: eta for builtin sigma-types !? + +-- up force v tv +-- force==True also expands at coinductive type +up :: Bool -> Val -> TVal -> TypeCheck Val +up f (VUp v tv') tv = up f v tv +up f v tv@VQuant{ vqPiSig = Pi } = return $ VUp v tv +up f _ (VSing v vt) = up f v vt +up f v (VDef d) = failValInv $ VDef d +up f v (VApp (VDef (DefId DatK d)) vl) = upData f v d vl +up f v _ = return v + +{- Most of the code to eta expand on data types is in + TypeChecker.hs "typeCheckDeclaration" + + Currently, eta expansion only happens at data *types* with exactly +one constructor. In a first step, this will be extended to +non-recursive pattern inductive families. + +The strategy is: match type value with result type for all the constructors +0. if there are no matches, eta expand to * (VIrr) +1. if there is exactly one match, eta expand accordingly using destructors +2. if there are more matches, do not eta-expand + +up{Vec A (suc n)} x = vcons A n (head A n x) (tail A n x) + +up{Vec Bool (suc zero)} x + = vcons Bool zero (head Bool zero x) (tail Bool zero x) + +For vcons +- the patterns of Vec : (A : Set) -> Nat -> Set are [A,suc n] +- matching Bool,suc zero against A,suc n yields A=Bool,n=zero +- this means we can eta expand to vcons +- go through the fields of vcons + - if Index use value obtained by matching + - if Field destr, use destr x + +-} + +-- matchingConstructors is for use in checkPattern +-- matchingConstructors (D vs) returns all the constructors +-- each as tuple (ci,rho) +-- of family D whose target matches (D vs) under substitution rho +matchingConstructors :: Val -> TypeCheck (Maybe [(ConstructorInfo,Env)]) +matchingConstructors v@(VDef d) = failValInv v -- matchingConstructors' d [] +matchingConstructors (VApp (VDef (DefId DatK d)) vl) = matchingConstructors' d vl >>= return . Just +matchingConstructors v = return Nothing +-- throwErrorMsg $ "matchingConstructors: not a data type: " ++ show v -- return [] + +matchingConstructors' :: QName -> [Val] -> TypeCheck [(ConstructorInfo,Env)] +matchingConstructors' n vl = do + sige <- lookupSymbQ n + case sige of + (DataSig {symbTyp = dv, constructors = cs}) -> -- if (null cs) then ret [] else do -- no constructor + matchingConstructors'' True vl dv cs + +-- matchingConstructors'' +-- Arguments: +-- symm symmetric match +-- vl arguments to D (instance of D) +-- dv complete type value of D +-- cs constructors +-- Returns a list [(ci,rho)] of matching constructors together with the +-- environments which are solutions for the free variables in the constr.type +-- this is also for use in upData +matchingConstructors'' :: Bool -> [Val] -> Val -> [ConstructorInfo] -> TypeCheck [(ConstructorInfo,Env)] +matchingConstructors'' symm vl dv cs = do + vl <- mapM whnfClos vl + compressMaybes <$> do + forM cs $ \ ci -> do + let ps = snd (cPatFam ci) + -- list of patterns ps where D ps is the constructor target + fmap (ci,) <$> nonLinMatchList symm emptyEnv ps vl dv + + +data MatchingConstructors a + = NoConstructor + | OneConstructor a + | ManyConstructors + | UnknownConstructors + deriving (Eq,Show) + +getMatchingConstructor + :: Bool -- eta : must the field etaExpand be set of the data type + -> QName -- d : the name of the data types + -> [Val] -- vl : the arguments of the data type + -> TypeCheck (MatchingConstructors + ( Co -- co : coinductive type? + , [Val] -- parvs : the parameter half of the arguments + , Env -- rho : the substitution for the index variables to arrive at d vl + , [Val] -- indvs : the index values of the constructor + , ConstructorInfo -- ci : the only matching constructor + )) +getMatchingConstructor eta n vl = traceRecord ("getMatchingConstructor " ++ show (n, vl)) $ + do + -- when checking a mutual data decl, the sig entry of the second data + -- is not yet in place when checking the first, thus, lookup may fail + sig <- gets signature + case Map.lookup n sig of + Just (DataSig {symbTyp = dv, numPars = npars, isCo = co, constructors = cs, etaExpand}) | eta `implies` etaExpand -> + if (null cs) then return NoConstructor else do -- no constructor: empty type + -- for each constructor, match its core against the type + -- produces a list of maybe (c.info, environment) + cenvs <- matchingConstructors'' False vl dv cs + traceRecordM $ "Matching constructors: " ++ show cenvs + case cenvs of + -- exactly one matching constructor: can eta expand +-- [(ci,env)] -> if not (eta `implies` cEtaExp ci) then return UnknownConstructors else do + [(ci,env)] -> if eta && not (cEtaExp ci) then return UnknownConstructors else do + -- get list of index values from environment + let fis = cFields ci + let indices = filter (\ fi -> fClass fi == Index) fis + let indvs = map (\ fi -> lookupPure env (fName fi)) indices + let (pars, _) = splitAt npars vl + return $ OneConstructor (co, pars, env, indvs, ci) + -- more or less than one matching constructors: cannot eta expand + l -> -- trace ("getMatchingConstructor: " ++ show (length l) ++ " patterns match at type " ++ show n ++ show vl) $ + return ManyConstructors + _ -> traceRecord ("no eta expandable type") $ return UnknownConstructors + +getFieldsAtType + :: QName -- d : the name of the data types + -> [Val] -- vl : the arguments of the data type + -> TypeCheck + (Maybe -- Nothing if not a record type + [(Name -- list of projection names + ,TVal)]) -- and their instantiated type R ... -> C +getFieldsAtType n vl = do + mc <- getMatchingConstructor False n vl + case mc of + OneConstructor (_, pars, _, indvs, ci) -> do + let pi = pars ++ indvs + -- for each argument of constructor, get value + let arg (FieldInfo { fName = x, fClass = Index }) = return [] + arg (FieldInfo { fName = d, fClass = Field _ }) = do + -- lookup type sig t of destructor d + t <- lookupSymbTyp d + -- pi-apply destructor type to parameters and indices + t' <- piApps t pi + return [(d,t')] + Just . concat <$> mapM arg (cFields ci) + _ -> return Nothing + +-- similar to piApp, but for record types and projections +projectType :: TVal -> Name -> Val -> TypeCheck TVal +projectType tv p rv = do + let fail1 = failDoc (text "expected record type when taking the projection" <+> prettyTCM (Proj Post p) <> comma <+> text "but found type" <+> prettyTCM tv) + let fail2 = failDoc (text "record type" <+> prettyTCM tv <+> text "does not have field" <+> prettyTCM p) + case tv of + VApp (VDef (DefId DatK d)) vl -> do + mfs <- getFieldsAtType d vl + case mfs of + Nothing -> fail1 + Just ptvs -> + case lookup p ptvs of + Nothing -> fail2 + Just tv -> piApp tv rv -- apply to record arg + _ -> fail1 + +-- eta expand v at data type n vl +upData :: Bool -> Val -> QName -> [Val] -> TypeCheck Val +upData force v n vl = -- trace ("upData " ++ show v ++ " at " ++ n ++ show vl) $ + do + let ret v' = traceEta ("Eta-expanding: " ++ show v ++ " --> " ++ show v' ++ " at type " ++ show n ++ show vl) $ return v' + mc <- getMatchingConstructor True n vl + case mc of + NoConstructor -> ret VIrr + OneConstructor (co, pars, env, indvs, ci) -> + -- lazy eta-expansion for coinductive records like streams! + if (co==CoInd && not force) then return $ VUp v (VApp (VDef $ DefId DatK n) vl) else do + -- get list of index values from environment + let fis = cFields ci + let piv = pars ++ indvs ++ [v] + -- for each argument of constructor, get value + let arg (FieldInfo { fName = x, fClass = Index }) = + lookupEnv env x + arg (FieldInfo { fName = d, fClass = Field _ }) = do + -- lookup type sig t of destructor d + LetSig {symbTyp = t, definingVal = w} <- lookupSymb d + -- pi-apply destructor type to parameters, indices and value v + t' <- piApps t piv + -- recursively eta expand (d 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 = throwErrorMsg $ "matchList internal error: inequal length while trying to match patterns " ++ show pl ++ " against values " ++ show vl + +-- * Typed Non-linear Matching ----------------------------------------- + +type GenToPattern = [(Int,Pattern)] +type MatchState = (Env, GenToPattern) + +-- @nonLinMatch True@ allows also instantiation in v0 +-- this is useful for finding all matching constructors +-- for an erased argument in checkPattern +nonLinMatch :: Bool -> Bool -> MatchState -> Pattern -> Val -> TVal -> TypeCheck (Maybe MatchState) +nonLinMatch undot symm st p v0 tv = traceMatch ("matching pattern " ++ show (p,v0)) $ do + -- force against constructor pattern + v <- case p of + ConP{} -> force v0 + PairP{} -> force v0 + _ -> whnfClos v0 + case (p,v) of + (ErasedP{}, _) -> return $ Just st + (DotP{} , _) -> return $ Just st + (_, VGen i) | symm -> return $ Just $ mapSnd ((i,p):) st -- no check in case of non-lin! + (VarP x, _) -> matchVarP x v + (SizeP _ x, _) -> matchVarP x v + (ProjP x, VProj Post y) | x == y -> return $ Just st + (ConP _ c pl, VApp (VDef (DefId (ConK _) c')) vl) | nameInstanceOf c c' -> do + vc <- conLType c tv + nonLinMatchList' undot symm st pl vl vc + -- Here, we do accept dotted constructors, since we are abusing this for unification. + (ConP _ c pl, VRecord (NamedRec _ c' _ dotted) rs) | nameInstanceOf c c' -> do + when undot $ clearDotted dotted + vc <- conLType c tv + nonLinMatchList' undot symm st pl (map snd rs) vc + -- if the match against an unconfirmed constructor + -- we can succeed, but not compute a sensible environment + (_, VRecord (NamedRec _ c' _ dotted) rs) | isDotted dotted && not undot -> return $ Just st + (p@(ConP pi _ _), v) | coPat pi == DefPat -> do + p <- expandDefPat p + nonLinMatch undot symm st p v tv + (PairP p1 p2, VPair v1 v2) -> do + tv <- force tv + case tv of + VQuant Sigma x dom fv -> do + nonLinMatch undot symm st p1 v1 (typ dom) `bindMaybe` \ st -> do + nonLinMatch undot symm st p2 v2 =<< app fv v1 + _ -> failDoc $ text "nonLinMatch: expected" <+> prettyTCM tv <+> text "to be a Sigma-type (&)" + (SuccP p', v) -> (predSize <$> whnfClos v) `bindMaybe` \ v' -> + nonLinMatch undot symm st p' v' tv + _ -> return Nothing + where + -- Check that the previous solution for @x@ is equal to @v@. + -- Here, we need the type! + matchVarP x v = do + let env = fst st + case find ((x ==) . fst) $ envMap $ fst st of + Nothing -> return $ Just $ mapFst (\ env -> update env x v) st + Just (y,v') -> ifM (eqValBool tv v v') (return $ Just st) (return Nothing) + +-- nonLinMatchList symm env ps vs tv +-- typed non-linear matching of patterns ps against values vs at type tv +-- env is the accumulator for the solution of the matching +nonLinMatchList :: Bool -> Env -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe Env) +nonLinMatchList symm env ps vs tv = + fmap fst <$> nonLinMatchList' False symm (env, []) ps vs tv + +nonLinMatchList' :: Bool -> Bool -> MatchState -> [Pattern] -> [Val] -> TVal -> TypeCheck (Maybe MatchState) +nonLinMatchList' undot symm st [] [] tv = return $ Just st +nonLinMatchList' undot symm st (p:pl) (v:vl) tv = do + tv <- force tv + case tv of + VQuant Pi x dom fv -> + nonLinMatch undot symm st p v (typ dom) `bindMaybe` \ st' -> + nonLinMatchList' undot symm st' pl vl =<< app fv v + _ -> throwErrorMsg $ "nonLinMatchList': cannot match in absence of pi-type" +nonLinMatchList' _ _ _ _ _ _ = return Nothing + + +-- | Expand a top-level pattern synonym +expandDefPat :: Pattern -> TypeCheck Pattern +expandDefPat p@(ConP pi c ps) | coPat pi == DefPat = do + PatSig ns pat v <- lookupSymbQ c + unless (length ns == length ps) $ + throwErrorMsg ("underapplied defined pattern in " ++ show p) + let pat' = if dottedPat pi then dotConstructors pat else pat + return $ patSubst (zip ns ps) pat' +expandDefPat p = return p + +--------------------------------------------------------------------------- +-- * Unification +--------------------------------------------------------------------------- + +instance Monoid (TypeCheck Bool) where + mempty = return True + mappend = andLazy + mconcat = andM + +-- | Occurrence check @nocc ks v@ (used by 'SPos' and 'TypeCheck'). +-- Checks that generic values @ks@ does not occur in value @v@. +-- In the process, @tv@ is normalized. +class Nocc a where + nocc :: [Int] -> a -> TypeCheck Bool + +instance Nocc a => Nocc [a] where + nocc = foldMap . nocc + +instance Nocc a => Nocc (Dom a) where + nocc = foldMap . nocc + +instance Nocc a => Nocc (Measure a) where + nocc = foldMap . nocc + +instance Nocc a => Nocc (Bound a) where + nocc = foldMap . nocc + +instance (Nocc a, Nocc b) => Nocc (a,b) where + nocc ks (a, b) = nocc ks a `andLazy` nocc ks b + +instance Nocc a => Nocc (Sort a) where + nocc ks (Set v) = nocc ks v + nocc ks (CoSet v) = nocc ks v + nocc ks (SortC _) = mempty + +instance Nocc Val where + nocc ks v = do + -- traceM ("nocc " ++ show v) + v <- whnfClos v + case v of + -- neutrals + VGen k -> return $ not $ k `elem` ks + VApp v1 vl -> nocc ks $ v1 : vl + VDef{} -> mempty + VProj{} -> mempty + -- Binders: + -- ALT: do not evaluate under binders (just check environment). + -- This is less precise but more efficient. Can give false alarms. + -- Still sound. (Should maybe done first, like in Agda). + VQuant pisig x dom fv -> nocc ks dom `mappend` do + underAbs x dom fv $ \ _i _xv bv -> nocc ks bv + fv@(VLam x env b) -> underAbs' x fv $ \ _xv bv -> nocc ks bv + fv@(VAbs x i u valu) -> underAbs' x fv $ \ _xv bv -> nocc ks bv + fv@(VConst v) -> underAbs' noName fv $ \ _xv bv -> nocc ks bv + -- pairs + VRecord _ rs -> nocc ks $ map snd rs + VPair v w -> nocc ks (v, w) + -- sizes + VZero -> mempty + VSucc v -> nocc ks v + VInfty -> mempty + VMax vl -> nocc ks vl + VPlus vl -> nocc ks vl + VSort s -> nocc ks s + VMeasured mu tv -> nocc ks (mu, tv) + VGuard beta tv -> nocc ks (beta, tv) + VBelow ltle v -> nocc ks v + VSing v tv -> nocc ks (v, tv) + VUp v tv -> nocc ks (v, tv) + VIrr -> mempty + VCase v tv env cls -> nocc ks $ v : tv : map snd (envMap env) + -- impossible: closure (reduced away) + VClos{} -> throwErrorMsg $ "internal error: nocc " ++ show (ks,v) + + +-- heterogeneous typed equality and subtyping ------------------------ + +eqValBool :: TVal -> Val -> Val -> TypeCheck Bool +eqValBool tv v v' = errorToBool $ eqVal tv v v' +-- eqValBool tv v v' = (eqVal tv v v' >> return True) `catchError` (\ _ -> return False) + +eqVal :: TVal -> Val -> Val -> TypeCheck () +eqVal tv = leqVal' N mixed (Just (One tv)) + + +-- force history +data Force = N | L | R -- not yet, left , right + deriving (Eq,Show) + +class Switchable a where + switch :: a -> a + +instance Switchable Force where + switch L = R + switch R = L + switch N = N + +instance Switchable Pol where + switch = polNeg + +instance Switchable (a,a) where + switch (a,b) = (b,a) + +instance Switchable a => Switchable (Maybe a) where + switch = fmap switch + +{- +-- WONTFIX: FOR THE FOLLOWING TO BE SOUND, ONE NEEDS COERCIVE SUBTYPING! +-- the problem is that after extraction, erased arguments are gone! +-- a function which does not use its argument can be used as just a function +-- [A] -> A <= A -> A +-- A <= [A] +leqDec :: Pol -> Dec -> Dec -> Bool +leqDec SPos dec1 dec2 = erased dec2 || not (erased dec1) +leqDec Neg dec1 dec2 = erased dec1 || not (erased dec2) +leqDec mixed dec1 dec2 = erased dec1 == erased dec2 +-} + +-- subtyping for erasure disabled +-- but subtyping for polarities! +leqDec :: Pol -> Dec -> Dec -> Bool +leqDec p dec1 dec2 = erased dec1 == erased dec2 + && relPol p leqPol (polarity dec1) (polarity dec2) + +-- subtyping --------------------------------------------------------- + +subtype :: Val -> Val -> TypeCheck () +subtype v1 v2 = -- enter ("subtype " ++ show v1 ++ " <= " ++ show v2) $ + leqVal' N Pos Nothing v1 v2 + +-- Pol ::= Pos | Neg | mixed +leqVal :: Pol -> TVal -> Val -> Val -> TypeCheck () +leqVal p tv = leqVal' N p (Just (One tv)) + +type MT12 = Maybe (OneOrTwo TVal) + +-- view the shape of a type or a pair of types +data TypeShape + = ShQuant PiSigma + (OneOrTwo Name) + (OneOrTwo Domain) + (OneOrTwo FVal) -- both are function types + | ShSort SortShape -- sort of same shape + | ShData QName (OneOrTwo TVal)-- same data, but with possibly different args + | ShNe (OneOrTwo TVal) -- both neutral + | ShSing Val TVal -- 1 and singleton + | ShSingL Val TVal TVal -- 2 and the left is a singleton + | ShSingR TVal Val TVal -- 2 and the right is a singleton + | ShNone + deriving (Eq, Ord) + +data SortShape + = ShSortC Class -- same sort constant + | ShSet (OneOrTwo Val) -- Set i and Set j + | ShCoSet (OneOrTwo Val) -- CoSet i and CoSet j + deriving (Eq, Ord) + +shSize = ShSort (ShSortC Size) + +-- typeView does not normalize! +typeView :: TVal -> TypeShape +typeView tv = + case tv of + VQuant pisig x dom fv -> ShQuant pisig (One x) (One dom) (One fv) + VBelow{} -> shSize + VSort s -> ShSort (sortView s) + VSing v tv -> ShSing v tv + VApp (VDef (DefId DatK n)) vs -> ShData n (One tv) + VApp (VDef (DefId FunK n)) vs -> ShNe (One tv) -- stuck fun + VApp (VGen i) vs -> ShNe (One tv) -- type variable + VGen i -> ShNe (One tv) -- type variable + VCase{} -> ShNe (One tv) -- stuck case + _ -> ShNone -- error $ "typeView " ++ show tv + +sortView :: Sort Val -> SortShape +sortView s = + case s of + SortC c -> ShSortC c + Set v -> ShSet (One v) + CoSet v -> ShCoSet (One v) + +typeView12 :: (Functor m, Monad m, MonadError TraceError m) => OneOrTwo TVal -> m TypeShape +-- typeView12 :: OneOrTwo TVal -> TypeCheck TypeShape +typeView12 (One tv) = return $ typeView tv +typeView12 (Two tv1 tv2) = + case (tv1, tv2) of + (VQuant pisig1 x1 dom1 fv1, VQuant pisig2 x2 dom2 fv2) + | pisig1 == pisig2 && erased (decor dom1) == erased (decor dom2) -> + return $ ShQuant pisig1 (Two x1 x2) (Two dom1 dom2) (Two fv1 fv2) + (VSort s1, VSort s2) -> ShSort <$> sortView12 (Two s1 s2) + (VSing v tv, _) -> return $ ShSingL v tv tv2 + (_, VSing v tv) -> return $ ShSingR tv1 v tv + _ -> case (typeView tv1, typeView tv2) of + (ShSort s1, ShSort s2) | s1 == s2 -> return $ ShSort $ s1 + (ShData n1 _, ShData n2 _) | n1 == n2 -> return $ ShData n1 (Two tv1 tv2) + (ShNe{} , ShNe{} ) -> return $ ShNe (Two tv1 tv2) + _ -> throwErrorMsg $ "type " ++ show tv1 ++ " has different shape than " ++ show tv2 + +sortView12 :: (Monad m, MonadError TraceError m) => OneOrTwo (Sort Val) -> m SortShape +sortView12 (One s) = return $ sortView s +sortView12 (Two s1 s2) = + case (s1, s2) of + (SortC c1, SortC c2) | c1 == c2 -> return $ ShSortC c1 + (Set v1, Set v2) -> return $ ShSet (Two v1 v2) + (CoSet v1, CoSet v2) -> return $ ShCoSet (Two v1 v2) + _ -> throwErrorMsg $ "sort " ++ show s1 ++ " has different shape than " ++ show s2 + +whnf12 :: OneOrTwo Env -> OneOrTwo Expr -> TypeCheck (OneOrTwo Val) +whnf12 env12 e12 = Traversable.traverse id $ zipWith12 whnf env12 e12 + +app12 :: OneOrTwo Val -> OneOrTwo Val -> TypeCheck (OneOrTwo Val) +app12 fv12 v12 = Traversable.traverse id $ zipWith12 app fv12 v12 + +-- if m12 = Nothing, we are checking subtyping, otherwise we are +-- comparing objects or higher-kinded types +-- if two types are given (heterogeneous equality), they need to be +-- of the same shape, otherwise they cannot contain common terms +leqVal' :: Force -> Pol -> MT12 -> Val -> Val -> TypeCheck () +leqVal' f p mt12 u1' u2' = local (\ cxt -> cxt { consistencyCheck = False }) $ do + -- 2013-03-30 During subtyping, it is fine to add any size hypotheses. + l <- getLen + ren <- getRen + enterDoc (case mt12 of + Nothing -> -- text ("leqVal' (subtyping) " ++ show (Map.toList $ ren) ++ " |-") + text "leqVal' (subtyping) " + <+> prettyTCM u1' <+> text (" <=" ++ show p ++ " ") + <+> prettyTCM u2' + Just (One tv) -> -- text ("leqVal' " ++ show (Map.toList $ ren) ++ " |-") + text "leqVal' " + <+> prettyTCM u1' <+> text (" <=" ++ show p ++ " ") + <+> prettyTCM u2' <+> colon + <+> prettyTCM tv + Just (Two tv1 tv2) -> -- text ("leqVal' " ++ show (Map.toList $ ren) ++ " |-") + text "leqVal' " + <+> prettyTCM u1' <+> colon + <+> prettyTCM tv1 <+> text (" <=" ++ show p ++ " ") + <+> prettyTCM u2' <+> colon + <+> prettyTCM tv2) $ do +{- + ce <- ask + trace (("rewrites: " +?+ show (rewrites ce)) ++ " leqVal': " ++ show ce ++ "\n |- " ++ show u1' ++ "\n <=" ++ show p ++ " " ++ show u2') $ +-} + mt12f <- mapM (mapM force) mt12 -- leads to LOOP, see HungryEta.ma + sh12 <- case mt12f of + Nothing -> return Nothing + Just tv12 -> case runExcept $ typeView12 tv12 of + Right sh -> return $ Just sh + Left err -> (recoverFail $ show err) >> return Nothing + case sh12 of + + -- subtyping directed by common type shape + + Just (ShSing{}) -> return () -- two terms are equal at singleton type! + Just (ShSingL v1 tv1' tv2) -> leqVal' f p (Just (Two tv1' tv2)) v1 u2' + Just (ShSingR tv1 v2 tv2') -> leqVal' f p (Just (Two tv1 tv2')) u1' v2 + Just (ShSort (ShSortC Size)) -> leqSize p u1' u2' + +{- functions are compared pointwise + + Gamma, p(x:A) |- t x : B <= Gamma', p'(x:A') |- t' x : B' + ---------------------------------------------------------- + Gamma |- t : p(x:A) -> B <= Gamma' |- t' : p'(x:A') -> B' +-} + Just (ShQuant Pi x12 dom12 fv12) -> do + x <- do + let x = name12 x12 + if null (suggestion x) then do + case (u1', u2') of + (VLam x _ _, _) -> return x + (_, VLam x _ _) -> return x + _ -> return x + else return x + newVar x dom12 $ \ _ xv12 -> do + u1' <- app u1' (first12 xv12) + u2' <- app u2' (second12 xv12) + tv12 <- app12 fv12 xv12 + leqVal' f p (Just tv12) u1' u2' +{- + Just (VPi x1 dom1 env1 b1, VPi x2 dom2 env2 b2) -> + new2 x1 (dom1, dom2) $ \ (xv1, xv2) -> do + u1' <- app u1' xv1 + u2' <- app u2' xv2 + tv1' <- whnf (update env1 x1 xv1) b1 + tv2' <- whnf (update env2 x2 xv2) b2 + leqVal' f p (Just (tv1', tv2')) u1' u2' +-} + + + -- structural subtyping (not directed by types) + + _ -> do + u1 <- reduce =<< whnfClos u1' + u2 <- reduce =<< whnfClos u2' + + let tryForcing fallback = do + (f1,u1f) <- force' False u1 + (f2,u2f) <- force' False u2 + case (f1,f2) of -- (u1f /= u1,u2f /= u2) of + + (True,False) | f /= R -> -- only unroll one side + enter ("forcing LHS") $ + leqVal' L p mt12 u1f u2 + (False,True) | f /= L -> + enter ("forcing RHS") $ + leqVal' R p mt12 u1 u2f + _ -> -- enter ("not forcing " ++ show (f1,f2,f)) $ + fallback + + leqCons n1 vl1 n2 vl2 = do + unless (n1 == n2) $ + recoverFail $ + "leqVal': head mismatch " ++ show u1 ++ " != " ++ show u2 + case mt12 of + Nothing -> recoverFail $ "leqVal': cannot compare constructor terms without type" + Just tv12 -> do + ct12 <- Traversable.mapM (conType n1) tv12 + leqVals' f p ct12 vl1 vl2 + return () +{- + leqStructural u1 u2 where + leqStructural u1 u2 = +-} + case (u1,u2) of + +{- + C = C' (proper: C' entails C, but I do not want to implement entailment) + Gamma, C |- A <= Gamma', C' |- A' + ----------------------------------------- + Gamma |- C ==> A <= Gamma' |- C' ==> A' +-} + (VGuard beta1 bv1, VGuard beta2 bv2) -> do + entailsGuard (switch p) beta1 beta2 + leqVal' f p Nothing bv1 bv2 + + (VGuard beta u1, u2) | p `elem` [Neg,Pos] -> + addOrCheckGuard (switch p) beta $ + leqVal' f p Nothing u1 u2 + + (u1, VGuard beta u2) | p `elem` [Neg,Pos] -> + addOrCheckGuard p beta $ + leqVal' f p Nothing u1 u2 + {- + p' <= p + Gamma' |- A' <= Gamma |- A + Gamma, p(x:A) |- B <= Gamma', p'(x:A') |- B' + --------------------------------------------------------- + Gamma |- p(x:A) -> B : s <= Gamma' |- p'(x:A') -> B' : s' +-} + (VQuant piSig1 x1 dom1@(Domain av1 _ dec1) fv1, + VQuant piSig2 x2 dom2@(Domain av2 _ dec2) fv2) -> do + let p' = if piSig1 == Pi then switch p else p + if piSig1 /= piSig2 || not (leqDec p' dec1 dec2) then + recoverFailDoc $ text "subtyping" <+> prettyTCM u1 <+> text (" <=" ++ show p ++ " ") <+> prettyTCM u2 <+> text "failed" + else do + leqVal' (switch f) p' Nothing av1 av2 + -- take smaller domain + let dom = if (p' == Neg) then dom2 else dom1 + let x = bestName $ if p' == Neg then [x2,x1] else [x1,x2] + new x dom $ \ xv -> do + bv1 <- app fv1 xv + bv2 <- app fv2 xv + enterDoc (text "comparing codomain" <+> prettyTCM bv1 <+> text "with" <+> prettyTCM bv2) $ + leqVal' f p Nothing bv1 bv2 + + (VSing v1 av1, VSing v2 av2) -> do + leqVal' f p Nothing av1 av2 + leqVal' N mixed (Just (Two av1 av2)) v1 v2 -- compare for eq. + + (VSing v1 av1, VBelow ltle v2) | av1 == vSize && p == Pos -> do + v1 <- whnfClos v1 + leSize ltle p v1 v2 + +{- 2012-01-28 now vSize is VBelow Le Infty + + -- extra cases since vSize is not implemented as VBelow Le Infty + (u1,u2) | isVSize u1 && isVSize u2 -> return () + (VSort (SortC Size), VBelow{}) -> leqStructural (VBelow Le VInfty) u2 + (VBelow{}, VSort (SortC Size)) -> leqStructural u1 (VBelow Le VInfty) +-} + -- care needed to not make <=# a subtype of <# + (VBelow ltle1 v1, VBelow ltle2 v2) -> + case (p, ltle1, ltle2) of + _ | ltle1 == ltle2 -> leSize Le p v1 v2 + (Neg, Le, Lt) -> leSize Le p (vSucc v1) v2 + (Neg, Lt, Le) -> leSize Lt p v1 v2 -- careful here + (p , Lt, Le) -> leSize Le p v1 (vSucc v2) + (p , Le, Lt) -> leSize Lt p v1 v2 -- careful here + + -- unresolved eta-expansions (e.g. at coinductive type) + (VUp v1 av1, VUp v2 av2) -> do + -- leqVal' f p Nothing av1 av2 -- do not compare types + leqVal' f p (Just (Two av1 av2)) v1 v2 -- OR: Just(tv1,tv2) ? + (VUp v1 av1, u2) -> leqVal' f p mt12 v1 u2 + (u1, VUp v2 av2) -> leqVal' f p mt12 u1 v2 + + (VRecord (NamedRec _ n1 _ _) rs1, VRecord (NamedRec _ n2 _ _) rs2) -> + leqCons n1 (map snd rs1) n2 (map snd rs2) + +{- + -- the following three cases should be impossible + -- but aren't. I gave up on this bug -- 2012-01-25 + -- FOUND IT + + (VRecord (NamedRec _ n1 _) rs1, + VApp v2@(VDef (DefId (ConK _) n2)) vl2) -> leqCons n1 (map snd rs1) n2 vl2 + + (VApp v1@(VDef (DefId (ConK _) n1)) vl1, + VRecord (NamedRec _ n2 _) rs2) -> leqCons n1 vl1 n2 (map snd rs2) + + (VApp v1@(VDef (DefId (ConK _) n1)) vl1, + VApp v2@(VDef (DefId (ConK _) n2)) vl2) -> leqCons n1 vl1 n2 vl2 +-} + + -- smart equality is not transitive + (VCase v1 tv1 env1 cl1, VCase v2 tv2 env2 cl2) -> do + leqVal' f p (Just (Two tv1 tv2)) v1 v2 -- FIXED: do not have type here, but v1,v2 are neutral + leqClauses f p mt12 v1 tv1 env1 cl1 env2 cl2 + +{- REMOVED, NOT TRANSITIVE + (VCase v env cl, v2) -> leqCases (switch f) (switch p) (switch mt12) v2 v env cl + (v1, VCase v env cl) -> leqCases f p mt12 v1 v env cl +-} + (VSing v1 av1, av2) -> leqVal' f p Nothing av1 av2 -- subtyping ax + (VSort s1, VSort s2) -> leqSort p s1 s2 + (a1,a2) | a1 == a2 -> return () + (u1,u2) -> tryForcing $ + case (u1,u2) of + (VApp v1 vl1, VApp v2 vl2) -> leqApp f p v1 vl1 v2 vl2 + (VApp v1 vl1, u2) -> leqApp f p v1 vl1 u2 [] + (u1, VApp v2 vl2) -> leqApp f p u1 [] v2 vl2 + _ -> leqApp f p u1 [] u2 [] + +leqClauses :: Force -> Pol -> MT12 -> Val -> TVal -> Env -> [Clause] -> Env -> [Clause] -> TypeCheck () +leqClauses f pol mt12 v tvp env1 cls1 env2 cls2 = loop cls1 cls2 where + loop cls1 cls2 = case (cls1,cls2) of + ([],[]) -> return () + (Clause _ [p1] mrhs1 : cls1', Clause _ [p2] mrhs2 : cls2') -> do + ns <- flip execStateT [] $ alphaPattern p1 p2 + case (mrhs1, mrhs2) of + (Nothing, Nothing) -> return () + (Just e1, Just e2) -> do + let tv = maybe vTopSort first12 mt12 + let tv012 = maybe [] toList12 mt12 + addPattern (tvp `arrow` tv) p2 env2 $ \ _ pv env2' -> + addRewrite (Rewrite v pv) tv012 $ \ tv012 -> do + let env1' = env2' { envMap = compAssoc ns (envMap env2') } + v1 <- whnf (appendEnv env1' env1) e1 + v2 <- whnf (appendEnv env2' env2) e2 + leqVal' f pol (toMaybe12 tv012) v1 v2 + loop cls1' cls2' +{- +-- naive implementation for now +leqClauses :: Force -> Pol -> MT12 -> Val -> TVal -> Env -> [Clause] -> Env -> [Clause] -> TypeCheck () +leqClauses f pol mt12 v tvp env1 cls1 env2 cls2 = loop cls1 cls2 where + loop cls1 cls2 = case (cls1,cls2) of + ([],[]) -> return () + (Clause _ [p1] mrhs1 : cls1', Clause _ [p2] mrhs2 : cls2') -> do + eqPattern p1 p2 + case (mrhs1, mrhs2) of + (Nothing, Nothing) -> return () + (Just e1, Just e2) -> do + let tv = maybe vTopSort first12 mt12 + let tv012 = maybe [] toList12 mt12 + addPattern (tvp `arrow` tv) p1 env1 $ \ _ pv env' -> + addRewrite (Rewrite v pv) tv012 $ \ tv012 -> do + v1 <- whnf (appendEnv env' env1) e1 + v2 <- whnf (appendEnv env' env2) e2 + leqVal' f pol (toMaybe12 tv012) v1 v2 + loop cls1' cls2' + +eqPattern :: Pattern -> Pattern -> TypeCheck () +eqPattern p1 p2 = if p1 == p2 then return () else throwErrorMsg $ "pattern " ++ show p1 ++ " != " ++ show p2 +-} + +type NameMap = [(Name,Name)] + +alphaPattern :: Pattern -> Pattern -> StateT NameMap TypeCheck () +alphaPattern p1 p2 = do + let failure = throwErrorMsg $ "pattern " ++ show p1 ++ " != " ++ show p2 + alpha x1 x2 = do + ns <- get + case lookup x1 ns of + Nothing -> put $ (x1,x2) : ns + Just x2' | x2 == x2' -> return () + | otherwise -> failure + case (p1,p2) of + (VarP x1, VarP x2) -> alpha x1 x2 + (ConP pi1 n1 ps1, ConP pi2 n2 ps2) | pi1 == pi2 && n1 == n2 -> + zipWithM_ alphaPattern ps1 ps2 + (SuccP p1, SuccP p2) -> alphaPattern p1 p2 + (SizeP _ x1, SizeP _ x2) -> alpha x1 x2 + (PairP p11 p12, PairP p21 p22) -> do + alphaPattern p11 p21 + alphaPattern p12 p22 + (ProjP n1, ProjP n2) -> unless (n1 == n2) failure + (DotP _, DotP _) -> return () + (AbsurdP, AbsurdP) -> return () + (ErasedP p1, ErasedP p2) -> alphaPattern p1 p2 + (UnusableP p1, UnusableP p2) -> alphaPattern p1 p2 + _ -> failure + +-- leqCases f p tv1 v1 v tv env cl +-- checks whether v1 <=p (VCase v tv env cl) : tv1 +leqCases :: Force -> Pol -> MT12 -> Val -> Val -> TVal -> Env -> [Clause] -> TypeCheck () +leqCases f pol mt12 v1 v tvp env cl = do + vcase <- evalCase v tvp env cl + case vcase of + (VCase v tvp env cl) -> mapM_ (leqCase f pol mt12 v1 v tvp env) cl + v2 -> leqVal' f pol mt12 v1 v2 + +-- absurd cases need not be checked +leqCase :: Force -> Pol -> MT12 -> Val -> Val -> TVal -> Env -> Clause -> TypeCheck () +leqCase f pol mt12 v1 v tvp env (Clause _ [p] Nothing) = return () +leqCase f pol mt12 v1 v tvp env (Clause _ [p] (Just e)) = enterDoc (text "leqCase" <+> prettyTCM v <+> text " --> " <+> text (show p ++ " |- ") <+> prettyTCM v1 <+> text (" <=" ++ show pol ++ " ") <+> prettyTCM (VClos env e)) $ do -- ++ " : " ++ show mt12) $ +-- the dot patterns inside p are only valid in environment env + let tv = case mt12 of + Nothing -> vTopSort + Just tv12 -> second12 tv12 + addPattern (tvp `arrow` tv) p env $ \ _ pv env' -> + addRewrite (Rewrite v pv) [tv,v1] $ \ [tv',v1'] -> do + v2 <- whnf (appendEnv env' env) e + v2' <- reval v2 -- 2010-09-10, WHY? + let mt12' = fmap (mapSecond12 (const tv')) mt12 + leqVal' f pol mt12' v1' v2' + +-- compare spines (see rule Al-App-Ne, Abel, MSCS 08) +-- q ::= mixed | Pos | Neg +leqVals' :: Force -> Pol -> OneOrTwo TVal -> [Val] -> [Val] -> TypeCheck (OneOrTwo TVal) +leqVals' f q tv12 vl1 vl2 = do + sh12 <- typeView12 =<< mapM force tv12 + case (vl1, vl2, sh12) of + + ([], [], _) -> return tv12 + + (VProj Post p1 : vs1, VProj Post p2 : vs2, ShData d _) -> do + unless (p1 == p2) $ + recoverFailDoc $ text "projections" + <+> prettyTCM p1 <+> text "and" + <+> prettyTCM p2 <+> text "differ!" + -- recoverFail $ "projections " ++ show p1 ++ " and " ++ show p2 ++ " differ!" + tv12 <- mapM (\ tv -> projectType tv p1 VIrr) tv12 + leqVals' f q tv12 vs1 vs2 + + (w1:vs1, w2:vs2, ShQuant Pi x12 dom12 fv12) -> do + let p = oneOrTwo id polAnd (fmap (polarity . decor) dom12) + let dec = Dec p -- WAS: , erased = erased $ decor $ first12 dom12 } + v1 <- whnfClos w1 + v2 <- whnfClos w2 + tv12 <- do + if erased p -- WAS: (erased dec || p == Pol.Const) + -- we have skipped an argument, so proceed with two types! + then app12 (toTwo fv12) (Two v1 v2) + else do + let q' = polComp p q + applyDec dec $ + leqVal' f q' (Just $ fmap typ dom12) v1 v2 + -- we have not skipped comparison, so proceed (1/2) as we came in + case fv12 of + Two{} -> app12 fv12 (Two v1 v2) + One fv -> One <$> app fv v1 + -- type is invariant, so it does not matter which one we take + leqVals' f q tv12 vs1 vs2 + + _ -> failDoc $ text "leqVals': not (compatible) function types or mismatch number of arguments when comparing " + <+> prettyTCM vl1 <+> text " to " + <+> prettyTCM vl2 <+> text " at type " + <+> prettyTCM tv12 +-- _ -> throwErrorMsg $ "leqVals': not (compatible) function types or mismatch number of arguments when comparing " ++ show vl1 ++ " to " ++ show vl2 ++ " at type " ++ show tv12 + +{- +leqVals' f q (VPi x1 dom1@(Domain av1 _ dec1) env1 b1, + VPi x2 dom2@(Domain av2 _ dec2) env2 b2) + (w1:vs1) (w2:vs2) | dec1 == dec2 = do + let p = polarity dec1 + v1 <- whnfClos w1 + v2 <- whnfClos w2 + when (not (erased dec1)) $ + applyDec dec1 $ leqVal' f (polComp p q) (Just (av1,av2)) v1 v2 + tv1 <- whnf (update env1 x1 v1) b1 + tv2 <- whnf (update env2 x2 v2) b2 + leqVals' f q (tv1,tv2) vs1 vs2 +-} + +{- +leqNe :: Force -> Val -> Val -> TypeCheck TVal +leqNe f v1 v2 = --trace ("leqNe " ++ show v1 ++ "<=" ++ show v2) $ + do case (v1,v2) of + (VGen k1, VGen k2) -> if k1 == k2 then do + dom <- lookupGem k1 + return $ typ dom + else throwErrorMsg $ "gen mismatch " ++ show k1 ++ " " ++ show k2 +-} + +-- leqApp f pol v1 vs1 v2 vs2 checks v1 vs1 <=pol v2 vs2 +-- pol ::= Param | Pos | Neg +leqApp :: Force -> Pol -> Val -> [Val] -> Val -> [Val] -> TypeCheck () +leqApp f pol v1 w1 v2 w2 = {- trace ("leqApp: " -- ++ show delta ++ " |- " + ++ show v1 ++ show w1 ++ " <=" ++ show pol ++ " " ++ show v2 ++ show w2) $ -} +{- + do let headMismatch = recoverFail $ + "leqApp: head mismatch " ++ show v1 ++ " != " ++ show v2 +-} + do let headMismatch = recoverFailDoc $ text "leqApp: head mismatch" + <+> prettyTCM v1 <+> text "!=" <+> prettyTCM v2 + let emptyOrUnit u1 u2 = + unlessM (isEmptyType u1) $ unlessM (isUnitType u2) $ headMismatch + case (v1,v2) of +{- IMPOSSIBLE: + (VApp v1 [], v2) -> leqApp f pol v1 w1 v2 w2 + (v1, VApp v2 []) -> leqApp f pol v1 w1 v2 w2 +-} +{- + (VApp{}, _) -> throwErrorMsg $ "leqApp: internal error: hit application v1 = " ++ show v1 + (_, VApp{}) -> throwErrorMsg $ "leqApp: internal error: hit application v2 = " ++ show v2 +-} + + (VUp v1 _, v2) -> leqApp f pol v1 w1 v2 w2 + (v1, VUp v2 _) -> leqApp f pol v1 w1 v2 w2 + + (VGen k1, VGen k2) | k1 == k2 -> do + tv12 <- (fmap typ . domain) <$> lookupGen k1 + leqVals' f pol tv12 w1 w2 + return () +{- + (VGen k1, VGen k2) -> + if k1 /= k2 + then headMismatch + else do tv12 <- (fmap typ . domain) <$> lookupGen k1 + leqVals' f pol tv12 w1 w2 + return () +-} +{- + (VCon _ n, VCon _ m) -> + if n /= m + then throwErrorMsg $ + "leqApp: head mismatch " ++ show v1 ++ " != " ++ show v2 + else do + sige <- lookupSymb n + case sige of + (ConSig tv) -> -- constructor + leqVals' f tv (repeat mixed) w1 w2 >> return () +-} + + (VDef n, VDef m) | n == m -> do + tv <- lookupSymbTypQ (idName n) + leqVals' f pol (One tv) w1 w2 + return () + + -- check for least or greatest type + + (u1,u2) -> if pol == Pos then emptyOrUnit u1 u2 else + if pol == Neg then emptyOrUnit u2 u1 else headMismatch + +{- + -- least type + (VDef (DefId DatK n), v2) | pol == Pos -> + ifM (isEmptyData n) (return ()) headMismatch + (v1, VDef (DefId DatK n)) | pol == Neg -> + ifM (isEmptyData n) (return ()) headMismatch +-} +{- + (VDef n, VDef m) -> + if (name n) /= (name m) then do + bot <- if pol==Neg then isEmptyData $ name m else + if pol==Pos then isEmptyData $ name n else return False + if bot then return () else headMismatch + else do + tv <- lookupSymbTyp (name n) + leqVals' f pol (One tv) w1 w2 + return () +-} +{- + sig <- gets signature + case lookupSig (name n) sig of + (DataSig{ numPars = p, positivity = pos, isSized = s, isCo = co, symbTyp = tv }) -> -- data type + let positivitySizeIndex = if s /= Sized then mixed else + if co == Ind then Pos else Neg + pos' = -- trace ("leqApp: posOrig = " ++ show (pos ++ [positivitySizeIndex])) $ + map (polComp pol) (pos ++ positivitySizeIndex : repeat mixed) -- the polComp will replace all SPos by Pos + in leqVals' f tv pos' w1 w2 + >> return () + +-- otherwise, we are dealing with a (co) recursive function or a constructor + entry -> leqVals' f (symbTyp entry) (repeat mixed) w1 w2 >> return () +-} + +{- + _ -> headMismatch + + _ -> recoverFail $ "leqApp: " ++ show v1 ++ show w1 ++ " !<=" ++ show pol ++ " " ++ show v2 ++ show w2 +-} + +isEmptyType :: TVal -> TypeCheck Bool +isEmptyType (VDef (DefId DatK n)) = isEmptyData n +isEmptyType _ = return False + +isUnitType :: TVal -> TypeCheck Bool +isUnitType (VDef (DefId DatK n)) = isUnitData n +isUnitType _ = return False + +-- comparing sorts and sizes ----------------------------------------- + +leqSort :: Pol -> Sort Val -> Sort Val -> TypeCheck () +leqSort p = relPolM p leqSort' +{- +leqSort mixed s1 s2 = leqSort' s1 s2 >> leqSort' s2 s1 +leqSort Neg s1 s2 = leqSort' s2 s1 +leqSort Pos s1 s2 = leqSort' s1 s2 +-} + +leqSort' :: Sort Val -> Sort Val -> TypeCheck () +leqSort' s1 s2 = do +-- let err = "universe test " ++ show s1 ++ " <= " ++ show s2 ++ " failed" + let err = text "universe test" + <+> prettyTCM s1 <+> text "<=" + <+> prettyTCM s2 <+> text "failed" + case (s1,s2) of + (_ , Set VInfty) -> return () + (SortC c , SortC c') | c == c' -> return () + (Set v1 , Set v2) -> leqSize Pos v1 v2 + (CoSet VInfty , Set v) -> return () + (Set VZero , CoSet{}) -> return () + (CoSet v1 , CoSet v2) -> leqSize Neg v1 v2 + _ -> recoverFailDoc err + +minSize :: Val -> Val -> Maybe Val +minSize v1 v2 = + case (v1,v2) of + (VZero,_) -> return VZero + (_,VZero) -> return VZero + (VInfty,_) -> return v2 + (_,VInfty) -> return v1 + (VMax vs,_) -> maxMins $ map (\ v -> minSize v v2) vs + (_,VMax vs) -> maxMins $ map (\ v -> minSize v1 v) vs + (VSucc v1', VSucc v2') -> fmap succSize $ minSize v1' v2' + (VGen i, VGen j) -> if i == j then return $ VGen i else Nothing + (VSucc v1', VGen j) -> minSize v1' v2 + (VGen i, VSucc v2') -> minSize v1 v2' + +maxMins :: [Maybe Val] -> Maybe Val +maxMins mvs = case compressMaybes mvs of + [] -> Nothing + vs' -> return $ maxSize vs' + +-- substaging on size values +leqSize :: Pol -> Val -> Val -> TypeCheck () +leqSize = leSize Le + +ltSize :: Val -> Val -> TypeCheck () +ltSize = leSize Lt Pos + +leSize :: LtLe -> Pol -> Val -> Val -> TypeCheck () +leSize ltle pol v1 v2 = enterDoc (text "leSize" + <+> prettyTCM v1 <+> text (show ltle ++ show pol) + <+> prettyTCM v2) $ +-- enter ("leSize " ++ show v1 ++ " " ++ show ltle ++ show pol ++ " " ++ show v2) $ + traceSize ("leSize " ++ show v1 ++ " " ++ show ltle ++ show pol ++ " " ++ show v2) $ + do case (v1,v2) of + _ | v1 == v2 && ltle == Le -> return () -- TODO: better handling of sums! + (VSucc v1,VSucc v2) -> leSize ltle pol v1 v2 +{- + (VGen i1,VGen i2) -> do + d <- getSizeDiff i1 i2 -- check size relation from constraints + case d of + Nothing -> recoverFail $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2 + Just k -> case (pol,k) of + (_, 0) | pol == mixed -> return () + (Pos, _) | k >= 0 -> return () + (Neg, _) | k <= 0 -> return () + _ -> recoverFail $ "leqSize: " ++ show v1 ++ " !<=" ++ show pol ++ " " ++ show v2 ++ " failed" +-} +{- + if v1 == v2 then return () + else throwErrorMsg $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2 +-} + (VInfty,VInfty) | ltle == Le -> return () + | otherwise -> recoverFail "leSize: # < # failed" + (VApp h1 tl1,VApp h2 tl2) -> leqApp N pol h1 tl1 h2 tl2 + _ -> relPolM pol (leSize' ltle) v1 v2 + +leqSize' :: Val -> Val -> TypeCheck () +leqSize' = leSize' Le + +leSize' :: LtLe -> Val -> Val -> TypeCheck () +leSize' ltle v1 v2 = -- enter ("leSize' " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2) $ + enterDoc (text "leSize'" <+> prettyTCM v1 <+> text (show ltle) <+> prettyTCM v2) $ + traceSize ("leSize' " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2) $ + do let failure = recoverFailDoc $ text "leSize':" + <+> prettyTCM v1 <+> text (show ltle) + <+> prettyTCM v2 <+> text "failed" + -- err = "leSize': " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2 ++ " failed" + case (v1,v2) of + (VZero,_) | ltle == Le -> return () + (VSucc{}, VZero) -> failure + (VInfty, VZero) -> failure + (VGen{}, VZero) -> failure + (VMax vs,_) -> mapM_ (\ v -> leSize' ltle v v2) vs -- all v in vs <= v2 + (_,VMax vs) -> foldr1 orM $ map (leSize' ltle v1) vs -- this produces a disjunction +-- (_,VMax _) -> addLe ltle v1 v2 -- this produces a disjunction + (_,VInfty) | ltle == Le -> return () + (VZero, VInfty) -> return () + (VMeta{},VZero) -> addLe ltle v1 v2 +{- + (0,VMeta i n', VMeta j m') -> + let (n,m) = if bal <= 0 then (n', m' - bal) else (n' + bal, m') in +-} + (VMeta i rho n, VMeta j rho' m) -> + addLe ltle (VMeta i rho (n - min n m)) + (VMeta j rho' (m - min n m)) + (VMeta i rho n, VSucc v2) | n > 0 -> leSize' ltle (VMeta i rho (n-1)) v2 + (VMeta i rho n, v2) -> addLe ltle v1 v2 + (VSucc v1, VMeta i rho n) | n > 0 -> leSize' ltle v1 (VMeta i rho (n-1)) + (v1,VMeta i rho n) -> addLe ltle v1 v2 + _ -> leSize'' ltle 0 v1 v2 +{- HANDLED BY leSize'' ltle + (VSucc{}, VGen{}) -> throwErrorMsg err + (VSucc{}, VPlus{}) -> throwErrorMsg err +-} +-- leSize'' ltle bal v v' checks whether Succ^bal v `lt` v' +-- invariant: bal is zero in cases for VMax and VMeta +leSize'' :: LtLe -> Int -> Val -> Val -> TypeCheck () +leSize'' ltle bal v1 v2 = traceSize ("leSize'' " ++ show v1 ++ " + " ++ show bal ++ " " ++ show ltle ++ " " ++ show v2) $ + do let failure = recoverFailDoc (text "leSize'':" <+> prettyTCM v1 <+> text ("+ " ++ show bal) <+> text (show ltle) <+> prettyTCM v2 <+> text "failed") + check mb = ifM mb (return ()) failure + ltlez = case ltle of { Le -> 0 ; Lt -> -1 } + case (v1,v2) of +#ifdef STRICTINFTY +-- Only cancel variables < # + _ | v1 == v2 && ltle == Le && bal <= 0 -> return () + (VGen i, VGen j) | i == j && bal <= -1 -> check $ isBelowInfty i +#else +-- Allow cancelling of all variables + _ | v1 == v2 && bal <= ltlez -> return () -- TODO: better handling of sums! +#endif + (VGen i, VInfty) | ltle == Lt -> check $ isBelowInfty i + (VZero,_) | bal <= ltlez -> return () + (VZero,VInfty) -> return () + (VZero,VGen _) | bal > ltlez -> recoverFailDoc $ text "0 not <" <+> prettyTCM v2 + (VSucc v1, v2) -> leSize'' ltle (bal + 1) v1 v2 + (v1, VSucc v2) -> leSize'' ltle (bal - 1) v1 v2 + (VPlus vs1, VPlus vs2) -> leSizePlus ltle bal vs1 vs2 + (VPlus vs1, VZero) -> leSizePlus ltle bal vs1 [] + (VZero, VPlus vs2) -> leSizePlus ltle bal [] vs2 + (VPlus vs1, _) -> leSizePlus ltle bal vs1 [v2] + (_, VPlus vs2) -> leSizePlus ltle bal [v1] vs2 + (VZero,_) -> leSizePlus ltle bal [] [v2] + (_,VZero) -> leSizePlus ltle bal [v1] [] + _ -> leSizePlus ltle bal [v1] [v2] + +#if (defined STRICTINFTY) +{- 2012-02-06 this modification cancels only variables < # + However, omega-instantiation is valid [i < #] -> F i subseteq F # + because every chain has a limit at #. +-} +leSizePlus :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck () +leSizePlus Lt bal vs1 vs2 = do + vs2' <- filterM varBelowInfty vs2 + vs1' <- filterM varBelowInfty vs1 + leSizePlus' Lt bal (vs1 List.\\ vs2') (vs2 List.\\ vs1') +leSizePlus Le bal vs1 vs2 = + leSizePlus' Le bal (vs1 List.\\ vs2) (vs2 List.\\ vs1) +#else +leSizePlus :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck () +leSizePlus ltle bal vs1 vs2 = + leSizePlus' ltle bal (vs1 List.\\ vs2) (vs2 List.\\ vs1) +#endif + + +varBelowInfty :: Val -> TypeCheck Bool +varBelowInfty (VGen i) = isBelowInfty i +varBelowInfty _ = return False + +leSizePlus' :: LtLe -> Int -> [Val] -> [Val] -> TypeCheck () +leSizePlus' ltle bal vs1 vs2 = do + let v1 = plusSizes vs1 + let v2 = plusSizes vs2 + let exit True = return () + exit False | bal >= 0 = recoverFailDoc (text "leSize:" <+> prettyTCM v1 <+> text ("+ " ++ show bal ++ " " ++ show ltle) <+> prettyTCM v2 <+> text "failed") + | otherwise = recoverFailDoc (text "leSize:" <+> prettyTCM v1 <+> text (show ltle) <+> prettyTCM v2 <+> text ("+ " ++ show (-bal) ++ " failed")) + traceSizeM ("leSizePlus' ltle " ++ show v1 ++ " + " ++ show bal ++ " " ++ show ltle ++ " " ++ show v2) + let ltlez = case ltle of { Le -> 0 ; Lt -> -1 } + case (vs1,vs2) of + ([],_) | bal <= ltlez -> return () + ([],[VGen i]) -> do + n <- getMinSize i + -- traceM ("getMinSize = " ++ show n) + case n of + Nothing -> exit False -- height of VGen i == 0 + Just n -> exit (bal <= n + ltlez) + ([VGen i1],[VGen i2]) -> do + d <- sizeVarBelow i1 i2 + traceSizeM ("sizeVarBelow " ++ show (i1,i2) ++ " returns " ++ show d) + case d of + Nothing -> tryIrregularBound i1 i2 (ltlez - bal) +-- recoverFail $ "leSize: head mismatch: " ++ show v1 ++ " " ++ show ltle ++ " " ++ show v2 + Just k -> exit (bal <= k + ltlez) + _ -> exit False + +-- BAD HACK! +-- check (VGen i1) <= (VGen i2) + k +tryIrregularBound :: Int -> Int -> Int -> TypeCheck () +tryIrregularBound i1 i2 k = do + betas <- asks bounds + let beta = Bound Le (Measure [VGen i1]) (Measure [iterate VSucc (VGen i2) !! k]) + foldl (\ result beta' -> result `orM` entailsGuard Pos beta' beta) + (recoverFail "bound not entailed") + betas + +{- +leqSize' :: Val -> Val -> TypeCheck () +leqSize' v1 v2 = --trace ("leqSize' " ++ show v1 ++ show v2) $ + do case (v1,v2) of + (VMax vs,_) -> mapM_ (\ v -> leqSize' v v2) vs -- all v in vs <= v2 + (_,VMax _) -> addLeq v1 v2 -- this produces a disjunction + (VSucc v1,VSucc v2) -> leqSize' v1 v2 + (VGen v1,VGen v2) -> do + d <- getSizeDiff v1 v2 + case d of + Nothing -> throwErrorMsg $ "leqSize: head mismatch: " ++ show v1 ++ " !<= " ++ show v2 + Just k -> if k >= 0 then return () else throwErrorMsg $ "leqSize: " ++ show v1 ++ " !<= " ++ show v2 ++ " failed" + (_,VInfty) -> return () + (VMeta i n, VSucc v2) | n > 0 -> leqSize' (VMeta i (n-1)) v2 + (VMeta i n, VMeta j m) -> addLeq (VMeta i (n - min n m)) + (VMeta j (m - min n m)) + (VMeta i n, v2) -> addLeq v1 v2 + (VSucc v1, VMeta i n) | n > 0 -> leqSize' v1 (VMeta i (n-1)) + (v1,VMeta i n) -> addLeq v1 v2 + (v1,VSucc v2) -> leqSize' v1 v2 + _ -> throwErrorMsg $ "leqSize: " ++ show v1 ++ " !<= " ++ show v2 +-} + +-- measures and guards ----------------------------------------------- + +{- +-- compare lexicographically +-- precondition: same length +ltMeasure :: Measure Val -> Measure Val -> TypeCheck () +ltMeasure (Measure mu1) (Measure mu2) = + -- enter ("checking " ++ show mu1 ++ " < " ++ show mu2) $ + lexSizes Lt mu1 mu2 +-} + +{- +leqMeasure :: Pol -> Measure Val -> Measure Val -> TypeCheck () +leqMeasure mixed (Measure mu1) (Measure mu2) = do + zipWithM (leqSize mixed) mu1 mu2 + return () +leqMeasure Pos (Measure mu1) (Measure mu2) = lexSizes mu1 mu2 +leqMeasure Neg (Measure mu1) (Measure mu2) = lexSizes mu2 mu1 +-} + +-- lexSizes True mu mu' checkes mu < mu' +-- lexSizes False mu mu' checkes mu <= mu' +lexSizes :: LtLe -> [Val] -> [Val] -> TypeCheck () +lexSizes ltle mu1 mu2 = traceSize ("lexSizes " ++ show (ltle,mu1,mu2)) $ + case (ltle, mu1, mu2) of + (Lt, [], []) -> recoverFail $ "lexSizes: no descent detected" + (Le, [], []) -> return () + (lt, a1:mu1, a2:mu2) -> do + b <- newAssertionHandling Failure $ errorToBool $ leSize ltle Pos a1 a2 + case (lt,b) of + (Le,False) -> recoverFailDoc $ text "lexSizes: expected" <+> prettyTCM a1 <+> text "<=" <+> prettyTCM a2 + -- recoverFail $ "lexSizes: expected " ++ show a1 ++ " <= " ++ show a2 + (Lt,True) -> return () + _ -> lexSizes ltle mu1 mu2 + +{- + r <- compareSize a1 a2 + case r of + LT -> return () + EQ -> lexSizes ltle mu1 mu2 + GT -> recoverFail $ "lexSizes: expected " ++ show a1 ++ " <= " ++ show a2 +-} + +{- +-- TODO: reprogram leqSize in terms of a proper compareSize +compareSize :: Val -> Val -> TypeCheck Ordering +compareSize a1 a2 = do + let ret o = trace ("compareSize: " ++ show a1 ++ " compared to " ++ show a2 ++ " returns " ++ show o) $ return o + le <- newAssertionHandling Failure $ errorToBool $ leqSize Pos a1 a2 + ge <- newAssertionHandling Failure $ errorToBool $ leqSize Pos a2 a1 + case (le,ge) of + (True,False) -> ret LT -- THIS IS COMPLETE BOGUS!!! + (True,True) -> ret EQ + (False,True) -> ret GT + (False,False) -> throwErrorMsg $ "compareSize (" ++ show a1 ++ ", " ++ show a2 ++ "): sizes incomparable" +-} + +{- Bound entailment + +1. (mu1 < mu1') ==> (mu2 < mu2') if mu2 <= mu1 and mu1' <= mu2' +2. (mu1 <= mu1') ==> (mu2 < mu2') one of these <= strict (<) +3. (mu1 < mu1') ==> (mu2 <= mu2') as 1. +4. (mu1 <= mu1') ==> (mu2 <= mu2') as 1. + +-} +entailsGuard :: Pol -> Bound Val -> Bound Val -> TypeCheck () +entailsGuard pol beta1@(Bound ltle1 (Measure mu1) (Measure mu1')) beta2@(Bound ltle2 (Measure mu2) (Measure mu2')) = enterDoc (text ("entailsGuard:") <+> prettyTCM beta1 <+> text (show pol ++ "==>") <+> prettyTCM beta2) $ do + case pol of + _ | pol == mixed -> do + assert (ltle1 == ltle2) $ "unequal bound types" + zipWithM (leqSize mixed) mu1 mu2 + zipWithM (leqSize mixed) mu1' mu2' + return () + Pos | ltle1 == Lt || ltle2 == Le -> do + lexSizes Le mu2 mu1 -- not strictly smaller + lexSizes Le mu1' mu2' + return () + Pos -> do + (lexSizes Lt mu2 mu1 >> lexSizes Le mu1' mu2') + `orM` + (lexSizes Le mu2 mu1 >> lexSizes Lt mu1' mu2') + Neg -> entailsGuard (switch pol) beta2 beta1 + +{- +eqGuard :: Bound Val -> Bound Val -> TypeCheck () +eqGuard (Bound (Measure mu1) (Measure mu1')) (Bound (Measure mu2) (Measure mu2')) = do + zipWithM (leqSize mixed) mu1 mu2 + zipWithM (leqSize mixed) mu1' mu2' + return () +-} + +checkGuard :: Bound Val -> TypeCheck () +checkGuard beta@(Bound ltle mu mu') = + enterDoc (text "checkGuard" <+> prettyTCM beta) $ + lexSizes ltle (measure mu) (measure mu') + +addOrCheckGuard :: Pol -> Bound Val -> TypeCheck a -> TypeCheck a +addOrCheckGuard Neg beta cont = checkGuard beta >> cont +addOrCheckGuard Pos beta cont = addBoundHyp beta cont + +-- comparing polarities ------------------------------------------------- + +leqPolM :: Pol -> PProd -> TypeCheck () +leqPolM p (PProd Pol.Const _) = return () +leqPolM p (PProd q m) | Map.null m && not (isPVar p) = + if leqPol p q then return () + else recoverFail $ "polarity check " ++ show p ++ " <= " ++ show q ++ " failed" +leqPolM p q = do + traceM $ "adding polarity constraint " ++ show p ++ " <= " ++ show q + +leqPolPoly :: Pol -> PPoly -> TypeCheck () +leqPolPoly p (PPoly l) = mapM_ (leqPolM p) l + +-- adding an edge to the positivity graph +addPosEdge :: DefId -> DefId -> PProd -> TypeCheck () +addPosEdge src tgt p = unless (src == tgt && isSPos p) $ do + -- traceM ("adding interesting positivity graph edge " ++ show src ++ " --[ " ++ show p ++ " ]--> " ++ show tgt) + st <- get + put $ st { positivityGraph = Arc (Rigid src) (ppoly p) (Rigid tgt) : positivityGraph st } + +checkPositivityGraph :: TypeCheck () +checkPositivityGraph = enter ("checking positivity") $ do + st <- get + let cs = positivityGraph st + let gr = buildGraph cs + let n = nextNode gr + let m0 = mkMatrix n (graph gr) + let m = warshall m0 + let isDataId i = case Map.lookup i (intMap gr) of + Just (Rigid (DefId DatK _)) -> True + _ -> False + let dataDiag = [ m Array.! (i,i) | i <- [0..n-1], isDataId i ] + mapM_ (\ x -> leqPolPoly oone x) dataDiag +{- + let solvable = all (\ x -> leqPol oone x) + unless solvable $ recoverFail $ "positivity check failed" +-} + -- TODO: solve constraints + put $ st { positivityGraph = [] } + +-- telescopes -------------------------------------------------------- + +telView :: TVal -> TypeCheck ([(Val, TBinding TVal)], TVal) +telView tv = do + case tv of + VQuant Pi x dom fv -> underAbs_ x dom fv $ \ _ xv bv -> do + (vTel, core) <- telView bv + return ((xv, TBind x dom) : vTel, core) + _ -> return ([], tv) + +-- | Turn a fully applied constructor value into a named record value. +mkConVal :: Dotted -> ConK -> QName -> [Val] -> TVal -> TypeCheck Val +mkConVal dotted co n vs vc = do + (vTel, _) <- telView vc + let fieldNames = map (boundName . snd) vTel + return $ VRecord (NamedRec co n False dotted) $ zip fieldNames vs diff --git a/src/Eval.hs-boot b/src/Eval.hs-boot new file mode 100644 --- /dev/null +++ b/src/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/src/Extract.hs b/src/Extract.hs new file mode 100644 --- /dev/null +++ b/src/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.Except +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State + +import Data.Char +import Data.Traversable (Traversable) +import qualified Data.Traversable as Traversable +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe + +import Text.PrettyPrint + +import Polarity as Pol +import Abstract +import Value +import Eval +import TCM +import TraceError +import Util + +traceExtrM s = return () + +runExtract sig k = runExceptT (runReaderT (runStateT k (initWithSig sig)) emptyContext) + +-- extraction + +type FExpr = Expr +type FDeclaration = Declaration +type FClause = Clause +type FPattern = Pattern +type FConstructor = Constructor +type FTypeSig = TypeSig +type FFun = Fun +type FTelescope = Telescope + +type FTVal = TVal + +extractDecls :: [EDeclaration] -> TypeCheck [FDeclaration] +extractDecls ds = concat <$> mapM extractDecl ds + +extractDecl :: EDeclaration -> TypeCheck [FDeclaration] +extractDecl d = + case d of + MutualDecl _ ds -> extractDecls ds -- TODO! + OverrideDecl{} -> throwErrorMsg $ "extractDecls internal error: overrides impossible" + MutualFunDecl _ co funs -> extractFuns co funs + FunDecl co fun -> extractFun co fun + LetDecl evl x tel (Just t) e | null tel -> extractLet evl x t e + PatternDecl{} -> return [] + DataDecl n _ co _ tel ty cs fields -> extractDataDecl n co tel ty cs + +extractFuns :: Co -> [Fun] -> TypeCheck [FDeclaration] +extractFuns co funs = do + funs <- concat <$> mapM extractFunTypeSig funs + concat <$> mapM (extractFun co) funs + +extractFun :: Co -> Fun -> TypeCheck [FDeclaration] +extractFun co (Fun (TypeSig n t) n' ar cls) = do + tv <- whnf' t + cls <- concat <$> mapM (extractClause n tv) cls + return [ FunDecl co $ Fun (TypeSig n t) n' ar cls + -- , LetDecl False (TypeSig n' t) (Var n) -- no longer needed, since n and n' print the same + ] + +{- OLD +extractFun :: Co -> Fun -> TypeCheck [FDeclaration] +extractFun co (TypeSig n t, (ar, cls)) = extractIfTerm n $ do + tv0 <- whnf' t + t <- extractType tv0 + setExtrTyp n t + let n' = mkExtName n + setExtrTyp n' t + tv <- whnf' t + cls <- concat <$> mapM (extractClause n tv) cls + return [ FunDecl co (TypeSig n t, (ar, cls)) + , LetDecl False (TypeSig n' t) (Var n) + ] +-} +{- +extractFunTypeSigs :: [Fun] -> TypeCheck [Fun] +extractFunTypeSigs = mapM extractFunTypeSig +-} + +-- only extract type sigs +extractFunTypeSig :: Fun -> TypeCheck [Fun] +extractFunTypeSig (Fun ts@(TypeSig n t) n' ar cls) = extractIfTerm n $ do + ts@(TypeSig n t) <- extractTypeSig ts + setExtrTyp n' t + return [Fun ts n' ar cls] + +extractLet :: Bool -> Name -> Type -> Expr -> TypeCheck [FDeclaration] +extractLet evl n t e = extractIfTerm n $ do + TypeSig n t <- extractTypeSig (TypeSig n t) + e <- extractCheck e =<< whnf' t + return [LetDecl evl n emptyTel (Just t) e] + +extractTypeSig :: TypeSig -> TypeCheck FTypeSig +extractTypeSig (TypeSig n t) = do + t <- extractType =<< whnf' t + setExtrTyp n t + return $ TypeSig n t + +extractIfTerm :: Name -> TypeCheck [a] -> TypeCheck [a] +extractIfTerm n cont = do + k <- symbolKind <$> lookupSymb n + if k == NoKind || lowerKind k == SortC Tm then cont else return [] + +extractDataDecl :: Name -> Co -> Telescope -> Type -> [Constructor] -> TypeCheck [FDeclaration] +extractDataDecl n co tel ty cs = do + -- k <- extrTyp <$> lookupSymb n + tel' <- extractKindTel tel + Just core <- addBinds tel $ extractKind =<< whnf' ty + -- (_, core) = typeToTele' (length tel') k + cs <- mapM (extractConstructor tel) cs + return [DataDecl n NotSized co [] tel' core cs []] + +extractConstructor :: Telescope -> Constructor -> TypeCheck FConstructor +extractConstructor tel0 (Constructor n pars t) = do +{- fails for HEq + -- 2012-01-22: remove irrelevant parameters + let tel = filter (\ (TBind _ dom) -> not $ erased $ decor dom) tel0 +-} + let tel = tel0 + -- compute full extracted constructor type and add to the signature + t' <- extractType =<< whnf emptyEnv (teleToTypeErase tel t) + setExtrTypQ n t' + let (tel',core) = typeToTele' (size tel) t' + return $ Constructor n pars core + -- compute type minus telescope + -- TypeSig n <$> (extractType =<< whnf' t) + +extractClause :: Name -> FTVal -> Clause -> TypeCheck [FClause] +extractClause f tv (Clause _ pl Nothing) = return [] -- discard absurd clauses +extractClause f tv cl@(Clause vtel pl (Just rhs)) = do + traceM ("extracting clause " ++ render (prettyClause f cl) + ++ "\n at type " ++ show tv) +{- + tel <- introPatterns pl tv0 $ \ _ _ -> do + vtel <- getContextTele + extractTeleVal vtel + addBinds tel $ +-} + introPatVars pl $ + extractPatterns tv pl $ \ pl tv -> do + rhs <- extractCheck rhs tv + return [Clause vtel pl (Just rhs)] -- TODO: return FTelescope (type!) + +-- the pattern variables are already in context +extractPatterns :: FTVal -> [Pattern] -> + ([FPattern] -> FTVal -> TypeCheck a) -> TypeCheck a +extractPatterns tv [] cont = cont [] tv +extractPatterns tv (p:ps) cont = + extractPattern tv p $ \ pl tv -> + extractPatterns tv ps $ \ ps tv -> + cont (pl ++ ps) tv + +extractPattern :: FTVal -> Pattern -> + ([FPattern] -> FTVal -> TypeCheck a) -> TypeCheck a +extractPattern tv p cont = do + traceM ("extracting pattern " ++ render (pretty p) ++ " at type " ++ show tv) + fv <- funView tv + case fv of + EraseArg tv -> cont [] tv -- skip erased patterns + + Forall x dom fv -> do + xv <- whnf' (patternToExpr p) -- pattern variables are already in scope + bv <- app fv xv -- TODO! + case p of + ErasedP (VarP y) -> setTypeOfName y dom $ cont [] bv + _ -> cont [] bv +{- + Forall x ki env t -> new x ki $ \ xv -> + cont [] =<< whnf (update env x xv) t -- TODO! +-} + Arrow av bv -> extractPattern' av p (flip cont bv) + +extractPattern' :: FTVal -> Pattern -> + ([FPattern] -> TypeCheck a) -> TypeCheck a +extractPattern' av p cont = + case p of + VarP y -> setTypeOfName y (defaultDomain av) $ + cont [VarP y] + PairP p1 p2 -> do + view <- prodView av + -- hack to avoid IMPOSSIBLE + let (av1, av2) = case view of + Prod av1 av2 -> (av1, av2) + _ -> (av, av) -- HACK + extractPattern' av1 p1 $ \ ps1 -> do + extractPattern' av2 p2 $ \ ps2 -> + let ps [] ps2 = ps2 + ps ps1 [] = ps1 + ps [p1] [p2] = [PairP p1 p2] + in cont $ ps ps1 ps2 + +{- + case view of + Prod av1 av2 -> + extractPattern' av1 p1 $ \ [p1] -> do + extractPattern' av2 p2 $ \ [p2] -> cont [PairP p1 p2] + _ -> throwErrorMsg $ "extractPattern': IMPOSSIBLE: pattern " ++ + show p ++ " : " ++ show av +-} + ConP pi n ps -> do +-- tv <- whnf' =<< extrTyp <$> lookupSymb n + tv <- extrConType n av + extractPatterns tv ps $ \ ps _ -> + cont [ConP pi n ps] + _ -> cont [] + +extrConType :: QName -> FTVal -> TypeCheck FTVal +extrConType c av = do + ConSig { conPars, extrTyp, dataPars } <- lookupSymbQ c + traceExtrM ("extrConType " ++ show c ++ " has extrTyp = " ++ show extrTyp) + tv <- whnf' extrTyp + numPars <- maybe (return dataPars) (const $ throwErrorMsg $ "NYI: extrConType for pattern parameters") conPars + case numPars of + 0 -> return tv + _ -> do + case av of + VApp (VDef (DefId DatK d)) vs -> do + DataSig { positivity } <- lookupSymbQ d + traceExtrM ("extrConType " ++ show c ++ "; data type has positivity = " ++ show positivity) + let pars 0 pols vs = [] + pars n (pol:pols) vs | erased pol = VIrr : pars (n-1) pols vs + pars n (pol:pols) (v:vs) = v : pars (n-1) pols vs + pars n pols vs = error $ "pars " ++ show n ++ show pols ++ show vs + piApps tv $ pars numPars positivity $ vs ++ repeat VIrr +{- + let (pars, inds) = splitAt numPars vs + piApps tv pars +-} + _ -> piApps tv $ replicate numPars VIrr +-- _ -> throwErrorMsg $ "extrConType " ++ show c ++ ": expected datatype, found " ++ show av + +-- extracting a term from a term ------------------------------------- + +extractInfer :: Expr -> TypeCheck (FExpr, FTVal) +extractInfer e = do + case e of + + Var x -> (Var x,) . typ . domain <$> lookupName1 x + + App f e0 -> do + let (er, e) = isErasedExpr e0 + (f, tv) <- extractInfer f + fv <- funView tv + case fv of + EraseArg bv -> return (f,bv) + Forall x dom fv -> do + e <- extractTypeAt e (typ dom) + bv <- app fv =<< whnf' e + return $ (App f (erasedExpr e), bv) + Arrow av bv -> return (if er then f else App f e, bv) + NotFun -> return (if er then f else castExpr f `App` e, VIrr) + + Def f -> (Def f,) <$> do (whnf' . extrTyp) =<< lookupSymbQ (idName f) + + Pair{} -> throwErrorMsg $ "extractInfer: IMPOSSIBLE: pair " ++ show e + -- other expressions are erased or types + + _ -> return (Irr, VIrr) + +extractCheck :: Expr -> FTVal -> TypeCheck (FExpr) +extractCheck e tv = do + case e of + Lam dec y e -> do + fv <- funView tv + case fv of + EraseArg bv -> extractCheck e bv -- discard lambda + Forall x dom fv -> + Lam (decor dom) y <$> do + newWithGen y dom $ \ i xv -> + extractCheck e =<< app fv (VGen i) -- no eta-expansion + Arrow av bv -> + if erased dec then extractCheck e bv + else Lam dec y <$> do + new' y (defaultDomain av) $ + extractCheck e bv + NotFun -> castExpr <$> + if erased dec then extractCheck e VIrr + else Lam dec y <$> do + new' y (defaultDomain VIrr) $ + extractCheck e VIrr + + LLet (TBind x dom0) tel e1 e2 | null tel -> do + let dom = fmap Maybe.fromJust dom0 + if erased (decor dom) then extractCheck e2 tv else do -- discard let + vdom <- Traversable.mapM whnf' dom -- MiniAgda type val + dom <- Traversable.mapM extractType vdom -- Fomega type + vdom <- Traversable.mapM whnf' dom -- Fomega type val + e1 <- extractCheck e1 (typ vdom) + LLet (TBind x (fmap Just dom)) emptyTel e1 <$> do + new' x vdom $ extractCheck e2 tv + + Pair e1 e2 -> do + view <- prodView tv + let (av1,av2) = case view of + Prod av1 av2 -> (av1, av2) + _ -> (tv,tv) -- HACK!! + Pair <$> extractCheck e1 av1 <*> extractCheck e2 av2 +{- + case view of + Prod av1 av2 -> Pair <$> extractCheck e1 av1 <*> extractCheck e2 av2 + _ -> throwErrorMsg $ "extractCheck: tuple type expected " ++ show e ++ " : " ++ show tv +-} + + -- TODO: case + + _ -> fallback + where + fallback = do + (e,tv') <- extractInfer e + insertCast e tv tv' + +insertCast :: FExpr -> FTVal -> FTVal -> TypeCheck FExpr +insertCast e tv1 tv2 = loop tv1 tv2 where + loop tv1 tv2 = + case (tv1,tv2) of + (VIrr,_) -> return $ castExpr e + (_,VIrr) -> return $ castExpr e + _ -> return e -- TODO! + +funView :: FTVal -> TypeCheck FunView +funView tv = + case tv of + -- erasure mark + VQuant Pi x dom fv | erased (decor dom) && typ dom == VIrr -> + EraseArg <$> app fv VIrr + -- forall + VQuant Pi x dom fv | erased (decor dom) -> + return $ Forall x dom fv + -- function type + VQuant Pi x dom fv -> + Arrow (typ dom) <$> app fv VIrr + -- any other type can be a function type, but this needs casts! + _ -> return NotFun -- $ Arrow VIrr VIrr + +data FunView + = Arrow FTVal FTVal -- A -> B + | Forall Name Domain FTVal -- forall X:K. A + | EraseArg FTVal -- [] -> B + | NotFun -- () + +prodView :: FTVal -> TypeCheck ProdView +prodView tv = + case tv of + VQuant Sigma x dom fv -> Prod (typ dom) <$> app fv VIrr + _ -> return $ NotProd + +data ProdView + = Prod FTVal FTVal -- A * B + | NotProd + +-- extracting a kind from a value ------------------------------------ + +type FKind = Expr -- FKind ::= Set | FKind -> FKind | [Irr] -> FKind + +star :: FKind +star = Sort $ Set Zero + +extractSet :: Sort Val -> Maybe FKind +extractSet s = + case s of + SortC _ -> Nothing + Set _ -> Just $ star + CoSet _ -> Just $ star + +-- keep irrelevant entries +extractKindTel :: Telescope -> TypeCheck FTelescope +extractKindTel (Telescope tel) = Telescope <$> loop tel where + loop [] = return [] + loop (TBind x dom : tel) = do + dom <- Traversable.mapM whnf' dom + dom' <- extractKindDom dom + if erased (decor dom') then + newIrr x $ + (TBind x dom' :) <$> loop tel + else newTyVar x (typ dom') $ \ i -> do + x <- nameOfGen i + (TBind x dom' :) <$> loop tel + +{- +-- keep irrelevant entries +extractKindTel :: Telescope -> TypeCheck FTelescope +extractKindTel tel = do + tv <- whnf' (teleToType tel star) + Just k <- extractKind tv + let (tel, s) = typeToTele k + return tel + -- throw away erasure marks + -- return $ filter (\ tb -> not $ erased $ decor $ boundDom tb) tel +-} + +extractKindDom :: Domain -> TypeCheck (Dom FKind) +extractKindDom dom = + maybe (defaultIrrDom Irr) defaultDomain <$> + if erased (decor dom) then return Nothing + else extractKind (typ dom) + +extractKind :: TVal -> TypeCheck (Maybe FKind) +extractKind tv = + case tv of + VSort s -> return $ extractSet s + VMeasured mu vb -> extractKind vb + VGuard beta vb -> extractKind vb + VQuant Pi x dom fv -> new' x dom $ do + bv <- app fv VIrr + mk' <- extractKind bv + case mk' of + Nothing -> return Nothing + Just k' -> do + dom' <- extractKindDom dom + let x = fresh "" + return $ Just $ pi (TBind x dom') k' + _ -> return Nothing + +-- extracting a type constructor from a value ------------------------ + +type FType = Expr +{- FType ::= Irr -- not expressible in Fomega + | D FTypes -- data type + | X FTypes -- type variable + | FType -> FType -- function type + | [X:FKind] -> FType -- polymorphic type + | [Irr] -> FType -- erasure marker + -} + +-- tyVarName i = fresh $ "a" ++ show i + +newTyVar :: Name -> FKind -> (Int -> TypeCheck a) -> TypeCheck a +newTyVar x k cont = newWithGen x (defaultDomain (VClos emptyEnv k)) $ + \ i _ -> cont i -- store kinds unevaluated + +addFKindTel :: FTelescope -> TypeCheck a -> TypeCheck a +addFKindTel (Telescope tel) = loop tel where + loop [] cont = cont + loop (TBind x dom : tel) cont = newTyVar x (typ dom) $ \ _ -> + loop tel cont + +extractTeleVal :: TeleVal -> TypeCheck FTelescope +extractTeleVal = Telescope <.> loop where + loop [] = return [] + loop (tb : vtel) = do + tb <- Traversable.mapM extractType tb + addBind tb $ do + (tb :) <$> loop vtel + +extractType :: TVal -> TypeCheck FType +extractType = extractTypeAt star + +extractTypeAt :: FKind -> TVal -> TypeCheck FType +extractTypeAt k tv = do + case (tv,k) of + + (VMeasured mu vb, _) -> extractTypeAt k vb + (VGuard beta vb, _) -> extractTypeAt k vb + + -- relevant function space / sigma type --> non-dependent + (VQuant pisig x dom fv, _) | not (erased (decor dom)) -> do + a <- extractType (typ dom) + -- new' x dom $ do + bv <- app fv VIrr + b <- extractType bv + let x = fresh "" + return $ piSig pisig (TBind x (defaultDomain a)) b + + -- irrelevant function space --> forall or erasure marker + (VQuant Pi x dom fv, _) | erased (decor dom) -> do + mk <- extractKind (typ dom) + case mk of + Nothing -> do -- new' x dom $ do + bv <- app fv VIrr + b <- extractType bv + let x = fresh "" + return $ pi (TBind x (defaultIrrDom Irr)) b + Just k' -> do + newTyVar x k' $ \ i -> do + bv <- app fv $ VGen i + b <- extractType bv + x <- nameOfGen i + return $ pi (TBind x (defaultIrrDom k')) b + + (VApp (VDef (DefId DatK n)) vs, _) -> do + k <- extrTyp <$> lookupSymbQ n -- get kind of dname from signature + as <- extractTypes k vs -- turn vs into types as at kind k + return $ foldl App (Def (DefId DatK n)) as + + (VGen i,_) -> do +-- VClos _ k <- (typ . fromOne . domain) <$> lookupGen i -- get kind of var from cxt + Var <$> nameOfGen i + -- return $ Var (tyVarName i) + + (VApp (VGen i) vs,_) -> do + VClos _ k <- (typ . fromOne . domain) <$> lookupGen i -- get kind of var from cxt + as <- extractTypes k vs -- turn vs into types as at kind k + x <- nameOfGen i + return $ foldl App (Var x) as + + (VLam x env e, Quant Pi (TBind _ dom) k) | erased (decor dom) -> do + tv <- whnf (update env x VIrr) e + extractTypeAt k tv + + (VLam x env e, Quant Pi (TBind _ dom) k) -> newTyVar x (typ dom) $ \ i -> do + tv <- whnf (update env x (VGen i)) e + x <- nameOfGen i + Lam defaultDec x <$> extractTypeAt k tv + + (VLam{},_) -> error $ "panic! extractTypeAt " ++ show (tv,k) + + (VSing _ tv,_) -> extractTypeAt k tv + + (VUp v _,_) -> extractTypeAt k v + + _ -> return Irr + +extractTypes :: FKind -> [TVal] -> TypeCheck [FType] +extractTypes k vs = + case (k,vs) of + (_, []) -> return [] + (Quant Pi (TBind _ dom) k, v:vs) | erased (decor dom) -> extractTypes k vs + (Quant Pi (TBind _ dom) k, v:vs) -> do + v <- whnfClos v + a <- extractTypeAt (typ dom) v + as <- extractTypes k vs + return $ a : as + _ -> error $ "panic! extractTypes " ++ show k ++ " " ++ show vs + +-- auxiliary functions ----------------------------------------------- + +{- this is setExtrTyp +addFTypeSig :: Name -> FType -> TypeCheck () +addFTypeSig n t = modifySig n (\ item -> item { extrTyp = t }) +-} diff --git a/src/HsSyntax.hs b/src/HsSyntax.hs new file mode 100644 --- /dev/null +++ b/src/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) Nothing + +mkCast :: Exp -> Exp +mkCast e = Var (mkQual "Coerce" "unsafeCoerce") `App` e + +mkCon :: Name -> Exp +mkCon = Con . UnQual + +mkVar :: Name -> Exp +mkVar = Var . UnQual + +mkLam :: Name -> Exp -> Exp +mkLam x (Lambda _ ps e) = Lambda noLoc (PVar x : ps) e +mkLam x e = Lambda noLoc [PVar x] e + +mkParen :: Exp -> Exp +mkParen e@(Var{}) = e +mkParen e@(Con{}) = e +mkParen e = Paren e + +mkApp :: Exp -> Exp -> Exp +mkApp f e = App f e -- (mkParen e) + +mkLLet :: Name -> Maybe Type -> Exp -> Exp -> Exp +mkLLet x t e e' = Let (BDecls [mkLet x e]) e' + +mkPair :: Exp -> Exp -> Exp +mkPair e1 e2 = Tuple Boxed [e1,e2] + +{- this is already predefined as unit_con +hsDummyExp :: HsExp +hsDummyExp = HsCon $ Special $ HsUnitCon -- Haskell's '()' +-} diff --git a/src/Lexer.hs b/src/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Lexer.hs @@ -0,0 +1,635 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} +{-# LANGUAGE CPP #-} +{-# LINE 2 "Lexer.x" #-} + + +module Lexer where + + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Array.Base (unsafeAt) +#else +import Array +#endif +{-# LINE 1 "templates/wrappers.hs" #-} +{-# LINE 1 "templates/wrappers.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 8 "" #-} +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{-# LINE 8 "" #-} +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + + + + + + +import Data.Word (Word8) +{-# LINE 28 "templates/wrappers.hs" #-} + +import Data.Char (ord) +import qualified Data.Bits + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +utf8Encode :: Char -> [Word8] +utf8Encode = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) + , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + + +type Byte = Word8 + +-- ----------------------------------------------------------------------------- +-- The input type + + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + [Byte], -- pending bytes on current char + String) -- current input string + +ignorePendingBytes :: AlexInput -> AlexInput +ignorePendingBytes (p,c,ps,s) = (p,c,[],s) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p,c,bs,s) = c + +alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) +alexGetByte (p,c,(b:bs),s) = Just (b,(p,c,bs,s)) +alexGetByte (p,c,[],[]) = Nothing +alexGetByte (p,_,[],(c:s)) = let p' = alexMove p c + (b:bs) = utf8Encode c + in p' `seq` Just (b, (p', c, bs, s)) + + +{-# LINE 101 "templates/wrappers.hs" #-} + +{-# LINE 119 "templates/wrappers.hs" #-} + +{-# LINE 137 "templates/wrappers.hs" #-} + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+alex_tab_size-1) `div` alex_tab_size)*alex_tab_size+1) +alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + + +-- ----------------------------------------------------------------------------- +-- Default monad + +{-# LINE 271 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + +{-# LINE 374 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + +{-# LINE 401 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + +{-# LINE 421 "templates/wrappers.hs" #-} + +{-# LINE 437 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + + +--alexScanTokens :: String -> [token] +alexScanTokens str = go (alexStartPos,'\n',[],str) + where go inp@(pos,_,_,str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError ((AlexPn _ line column),_,_,_) -> error $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column) + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : go inp' + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + +{-# LINE 470 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + +alex_tab_size :: Int +alex_tab_size = 8 +alex_base :: Array Int Int +alex_base = listArray (0,160) [-8,10,221,202,349,560,688,415,0,801,0,929,1057,1313,1249,0,0,1362,0,1427,1683,1619,0,-3,1865,2076,0,1837,2293,2377,2461,2545,2629,2713,2797,2881,2965,3049,3133,3217,3301,3385,3469,3553,3637,3721,3805,3889,0,0,3973,0,0,4057,-34,0,0,0,0,0,-50,0,0,0,0,0,-30,-31,0,0,0,0,0,0,0,0,0,-36,0,70,4141,4225,4309,4393,4477,4561,4645,4729,4813,4897,4981,5065,5149,5233,5317,5401,5485,5569,5653,5737,5821,5905,5989,6073,6157,6241,6325,6409,6493,6577,6661,6745,6829,6913,6997,7081,7165,7249,7333,7417,7501,7585,7669,7753,7837,7921,8005,8089,8173,8257,8341,8425,8509,8593,8677,8761,8845,8929,9013,9097,9181,9265,9349,9433,9517,9601,9685,9769,9853,9937,10021,10105,10189,10273,10357,10441,10525,10609,10693,10777,10861] + +alex_table :: Array Int Int +alex_table = listArray (0,11116) [0,23,23,23,23,23,23,23,23,23,23,5,49,65,24,0,0,0,0,0,0,0,0,0,23,73,0,51,52,23,71,72,58,59,69,66,63,67,64,68,79,79,79,79,79,79,79,79,79,79,62,61,77,74,78,2,0,124,124,116,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,100,110,124,124,124,124,124,124,56,75,57,70,76,48,124,124,106,93,134,90,124,124,152,124,124,94,102,124,124,120,124,117,112,128,124,124,124,124,124,124,54,60,55,79,79,79,79,79,79,79,79,79,79,0,0,0,0,0,0,0,26,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,13,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,14,12,8,8,8,8,8,8,8,8,8,8,8,8,8,8,7,11,10,10,10,9,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,1,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,0,0,0,0,0,0,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,25,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,13,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,14,12,8,8,8,8,8,8,8,8,8,8,8,8,8,8,7,11,10,10,10,9,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,20,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,1,14,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,13,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,14,12,8,8,8,8,8,8,8,8,8,8,8,8,8,8,7,11,10,10,10,9,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,4,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,7,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,12,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,13,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,19,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,21,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,20,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,21,4,18,18,18,18,18,18,18,18,18,18,18,18,18,18,19,6,16,16,16,17,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,13,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,15,14,12,8,8,8,8,8,8,8,8,8,8,8,8,8,8,7,11,10,10,10,9,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,28,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,29,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,31,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,35,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,41,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,42,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,43,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,45,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,50,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,159,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,96,124,124,124,124,124,124,124,114,124,124,124,124,124,124,124,124,124,124,124,157,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,156,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,83,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,145,124,124,124,154,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,153,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,151,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,150,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,84,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,85,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,149,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,148,124,124,124,138,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,147,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,146,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,130,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,144,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,143,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,141,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,92,124,124,124,124,124,124,107,124,124,124,124,124,124,135,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,97,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,140,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,99,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,139,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,101,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,137,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,104,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,136,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,133,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,111,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,113,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,115,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,131,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,129,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,119,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,121,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,127,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,126,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,123,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,122,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,118,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,132,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,109,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,108,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,105,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,98,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,95,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,103,124,91,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,142,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,89,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,88,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,87,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,86,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,155,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,82,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,158,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,81,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,80,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,53,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,47,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,46,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,44,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,40,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,39,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,125,38,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,37,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,36,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,34,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,33,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,124,124,124,124,124,124,124,124,124,124,32,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,30,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,3,0,124,124,124,124,124,124,124,124,124,124,0,0,0,0,0,0,0,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,0,0,0,0,124,0,124,124,124,27,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,124,160,0,0,0,0,0,0,0,0,160,160,160,160,160,160,160,160,160,160,0,0,0,0,0,0,0,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,0,0,0,0,160,0,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,160,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0] + +alex_check :: Array Int Int +alex_check = listArray (0,11116) [-1,9,10,11,12,13,9,10,11,12,13,45,62,43,45,-1,-1,-1,-1,-1,-1,-1,-1,-1,32,61,-1,35,36,32,38,62,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,45,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,124,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,125,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,45,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,-1,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,125,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,45,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,10,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,45,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,46,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,39,-1,-1,-1,-1,-1,-1,-1,-1,48,49,50,51,52,53,54,55,56,57,-1,-1,-1,-1,-1,-1,-1,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,-1,-1,-1,-1,95,-1,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1] + +alex_deflt :: Array Int Int +alex_deflt = listArray (0,160) [-1,5,5,-1,-1,5,-1,15,15,8,8,-1,-1,5,5,5,18,18,22,22,24,24,24,-1,24,5,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1] + +alex_accept = listArray (0::Int,160) [AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAcc (alex_action_3),AlexAcc (alex_action_4),AlexAcc (alex_action_5),AlexAcc (alex_action_6),AlexAcc (alex_action_7),AlexAcc (alex_action_8),AlexAcc (alex_action_9),AlexAcc (alex_action_10),AlexAcc (alex_action_11),AlexAcc (alex_action_12),AlexAcc (alex_action_13),AlexAcc (alex_action_14),AlexAcc (alex_action_15),AlexAcc (alex_action_16),AlexAcc (alex_action_17),AlexAcc (alex_action_18),AlexAcc (alex_action_19),AlexAcc (alex_action_20),AlexAcc (alex_action_21),AlexAcc (alex_action_22),AlexAcc (alex_action_23),AlexAcc (alex_action_24),AlexAcc (alex_action_25),AlexAcc (alex_action_26),AlexAcc (alex_action_27),AlexAcc (alex_action_28),AlexAcc (alex_action_29),AlexAcc (alex_action_30),AlexAcc (alex_action_31),AlexAcc (alex_action_32),AlexAcc (alex_action_33),AlexAcc (alex_action_34),AlexAcc (alex_action_35),AlexAcc (alex_action_36),AlexAcc (alex_action_37),AlexAcc (alex_action_38),AlexAcc (alex_action_39),AlexAcc (alex_action_40),AlexAcc (alex_action_41),AlexAcc (alex_action_42),AlexAcc (alex_action_43),AlexAcc (alex_action_44),AlexAcc (alex_action_45),AlexAcc (alex_action_46),AlexAcc (alex_action_47),AlexAcc (alex_action_48),AlexAcc (alex_action_49),AlexAcc (alex_action_50),AlexAcc (alex_action_51),AlexAcc (alex_action_52),AlexAcc (alex_action_53),AlexAcc (alex_action_54),AlexAcc (alex_action_55),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_56),AlexAcc (alex_action_57)] +{-# LINE 80 "Lexer.x" #-} + +data Token = Id String AlexPosn + | QualId (String, String) AlexPosn + | Number String AlexPosn + | Sized AlexPosn + | Data AlexPosn + | CoData AlexPosn + | Record AlexPosn + | Fields AlexPosn + | Mutual AlexPosn + | Fun AlexPosn + | CoFun AlexPosn + | Pattern AlexPosn + | Case AlexPosn + | Def AlexPosn + | Let AlexPosn + | In AlexPosn + | Type AlexPosn + | Set AlexPosn + | CoSet AlexPosn + | Eval AlexPosn + | Fail AlexPosn + | Check AlexPosn + | TrustMe AlexPosn + | Impredicative AlexPosn + -- size type + | Size AlexPosn + | Infty AlexPosn + | Succ AlexPosn + | Max AlexPosn + -- + | LTri AlexPosn + | RTri AlexPosn + | AngleOpen AlexPosn + | AngleClose AlexPosn + | BrOpen AlexPosn + | BrClose AlexPosn + | BracketOpen AlexPosn + | BracketClose AlexPosn + | PrOpen AlexPosn + | PrClose AlexPosn + | Bar AlexPosn + | Sem AlexPosn + | Col AlexPosn + | Comma AlexPosn + | Dot AlexPosn + | Arrow AlexPosn + | Leq AlexPosn + | Eq AlexPosn + | PlusPlus AlexPosn + | Plus AlexPosn + | Minus AlexPosn + | Slash AlexPosn + | Times AlexPosn + | Hat AlexPosn + | Amp AlexPosn + | Lam AlexPosn + | Underscore AlexPosn + | NotUsed AlexPosn -- so happy doesn't generate overlap case pattern warning + deriving (Eq) + +qualId s p = let (m, '.':n) = break (== '.') s in QualId (m,n) p + +prettyTok :: Token -> String +prettyTok c = "\"" ++ tk ++ "\" at " ++ (prettyAlexPosn pos) where + (tk,pos) = case c of + (Id s p) -> (show s,p) + (QualId (m, n) p) -> (show m ++ "." ++ show n, p) + (Number i p) -> (i,p) + Sized p -> ("sized",p) + Data p -> ("data",p) + CoData p -> ("codata",p) + Record p -> ("record",p) + Fields p -> ("fields",p) + Mutual p -> ("mutual",p) + Fun p -> ("fun",p) + CoFun p -> ("cofun",p) + Pattern p -> ("pattern",p) + Case p -> ("case",p) + Def p -> ("def",p) + Let p -> ("let",p) + In p -> ("in",p) + Eval p -> ("eval",p) + Fail p -> ("fail",p) + Check p -> ("check",p) + TrustMe p -> ("trustme",p) + Impredicative p -> ("impredicative",p) + Type p -> ("Type",p) + Set p -> ("Set",p) + CoSet p -> ("CoSet",p) + Size p -> ("Size",p) + Infty p -> ("#",p) + Succ p -> ("$",p) + Max p -> ("max",p) + LTri p -> ("<|",p) + RTri p -> ("|>",p) + AngleOpen p -> ("<",p) + AngleClose p -> (">",p) + BrOpen p -> ("{",p) + BrClose p -> ("}",p) + BracketOpen p -> ("[",p) + BracketClose p -> ("]",p) + PrOpen p -> ("(",p) + PrClose p -> (")",p) + Bar p -> ("|",p) + Sem p -> (";",p) + Col p -> (":",p) + Comma p -> (",",p) + Dot p -> (".",p) + Arrow p -> ("->",p) + Leq p -> ("<=",p) + Eq p -> ("=",p) + PlusPlus p -> ("++",p) + Plus p -> ("+",p) + Minus p -> ("-",p) + Slash p -> ("/",p) + Times p -> ("*",p) + Hat p -> ("^",p) + Amp p -> ("&",p) + Lam p -> ("\\",p) + Underscore p -> ("_",p) + _ -> error "not used" + + +prettyAlexPosn (AlexPn _ line row) = "line " ++ show line ++ ", row " ++ show row + +tok f p s = f p s + + +alex_action_3 = tok (\p s -> Sized p) +alex_action_4 = tok (\p s -> Data p) +alex_action_5 = tok (\p s -> CoData p) +alex_action_6 = tok (\p s -> Record p) +alex_action_7 = tok (\p s -> Fields p) +alex_action_8 = tok (\p s -> Fun p) +alex_action_9 = tok (\p s -> CoFun p) +alex_action_10 = tok (\p s -> Pattern p) +alex_action_11 = tok (\p s -> Case p) +alex_action_12 = tok (\p s -> Def p) +alex_action_13 = tok (\p s -> Let p) +alex_action_14 = tok (\p s -> In p) +alex_action_15 = tok (\p s -> Eval p) +alex_action_16 = tok (\p s -> Fail p) +alex_action_17 = tok (\p s -> Check p) +alex_action_18 = tok (\p s -> TrustMe p) +alex_action_19 = tok (\p s -> Impredicative p) +alex_action_20 = tok (\p s -> Mutual p) +alex_action_21 = tok (\p s -> Type p) +alex_action_22 = tok (\p s -> Set p) +alex_action_23 = tok (\p s -> CoSet p) +alex_action_24 = tok (\p s -> LTri p) +alex_action_25 = tok (\p s -> RTri p) +alex_action_26 = tok (\p s -> Size p) +alex_action_27 = tok (\p s -> Infty p) +alex_action_28 = tok (\p s -> Succ p) +alex_action_29 = tok (\p s -> Max p) +alex_action_30 = tok (\p s -> BrOpen p) +alex_action_31 = tok (\p s -> BrClose p) +alex_action_32 = tok (\p s -> BracketOpen p) +alex_action_33 = tok (\p s -> BracketClose p) +alex_action_34 = tok (\p s -> PrOpen p) +alex_action_35 = tok (\p s -> PrClose p) +alex_action_36 = tok (\p s -> Bar p) +alex_action_37 = tok (\p s -> Sem p) +alex_action_38 = tok (\p s -> Col p) +alex_action_39 = tok (\p s -> Comma p) +alex_action_40 = tok (\p s -> Dot p) +alex_action_41 = tok (\p s -> PlusPlus p) +alex_action_42 = tok (\p s -> Plus p) +alex_action_43 = tok (\p s -> Minus p) +alex_action_44 = tok (\p s -> Slash p) +alex_action_45 = tok (\p s -> Times p) +alex_action_46 = tok (\p s -> Hat p) +alex_action_47 = tok (\p s -> Amp p) +alex_action_48 = tok (\p s -> Arrow p) +alex_action_49 = tok (\p s -> Leq p) +alex_action_50 = tok (\p s -> Eq p) +alex_action_51 = tok (\p s -> Lam p) +alex_action_52 = tok (\p s -> Underscore p) +alex_action_53 = tok (\p s -> AngleOpen p) +alex_action_54 = tok (\p s -> AngleClose p) +alex_action_55 = tok (\p s -> (Number s p )) +alex_action_56 = tok (\p s -> (Id s p )) +alex_action_57 = tok (\p s -> (qualId s p)) +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} + + + + + + + +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{-# LINE 7 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +{-# LINE 21 "templates/GenericTemplate.hs" #-} + +{-# LINE 51 "templates/GenericTemplate.hs" #-} + +{-# LINE 72 "templates/GenericTemplate.hs" #-} +alexIndexInt16OffAddr arr off = arr ! off + + +{-# LINE 93 "templates/GenericTemplate.hs" #-} +alexIndexInt32OffAddr arr off = arr ! off + + +{-# LINE 105 "templates/GenericTemplate.hs" #-} +quickIndex arr i = arr ! i + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input (sc) + = alexScanUser undefined input (sc) + +alexScanUser user input (sc) + = case alex_scan_tkn user input (0) input sc AlexNone of + (AlexNone, input') -> + case alexGetByte input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input' + + (AlexLastSkip input'' len, _) -> + + + + AlexSkip input'' len + + (AlexLastAcc k input''' len, _) -> + + + + AlexToken input''' len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` (s))) + in + new_acc `seq` + case alexGetByte input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + case fromIntegral c of { (ord_c) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = (base + ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if (offset >= (0)) && (check == ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + (-1) -> (new_acc, input) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len + (1)) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input (len) + check_accs (AlexAccSkip) = AlexLastSkip input (len) + + check_accs (AlexAccPred a predx rest) + | predx user orig_input (len) input + = AlexLastAcc a input (len) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user orig_input (len) input + = AlexLastSkip input (len) + | otherwise + = check_accs rest + + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +instance Functor AlexLastAcc where + fmap _ AlexNone = AlexNone + fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z + fmap _ (AlexLastSkip x y) = AlexLastSkip x y + +data AlexAcc a user + = AlexAccNone + | AlexAcc a + | AlexAccSkip + + | AlexAccPred a (AlexAccPred user) (AlexAcc a user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc a user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user in1 len in2 + = p1 user in1 len in2 && p2 user in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input + +alexPrevCharMatches f _ input _ _ = f (alexInputPrevChar input) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (sc) user _ _ input = + case alex_scan_tkn user input (0) input sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. diff --git a/src/Lexer.x b/src/Lexer.x new file mode 100644 --- /dev/null +++ b/src/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/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,6844 @@ +{-# OPTIONS_GHC -w #-} +{-# LANGUAGE BangPatterns #-} +module Parser where + +import qualified Lexer as T +import qualified Concrete as C + +import Abstract (Decoration(..),Dec,defaultDec,Override(..)) +import Polarity (Pol(..)) +import qualified Abstract as A +import qualified Polarity as A +import Concrete (Name,patApp) +import Control.Applicative(Applicative(..)) +import Control.Monad (ap) + +-- parser produced by Happy Version 1.19.5 + +data HappyAbsSyn + = HappyTerminal (T.Token) + | HappyErrorToken Int + | HappyAbsSyn4 ([C.Declaration]) + | HappyAbsSyn6 (C.Declaration) + | HappyAbsSyn12 ((C.Name, C.Telescope, C.Type, [C.Constructor], [C.Name])) + | HappyAbsSyn13 ((C.Name, C.Telescope, C.Type, C.Constructor, [C.Name])) + | HappyAbsSyn18 (C.LetDef) + | HappyAbsSyn19 (Bool) + | HappyAbsSyn20 (Maybe C.Type) + | HappyAbsSyn22 ([Name]) + | HappyAbsSyn23 (Name) + | HappyAbsSyn26 (Pol) + | HappyAbsSyn27 (A.Measure C.Expr) + | HappyAbsSyn28 ([C.Expr]) + | HappyAbsSyn29 (A.Bound C.Expr) + | HappyAbsSyn31 (C.Telescope) + | HappyAbsSyn32 (C.TBind) + | HappyAbsSyn35 (C.LBind) + | HappyAbsSyn36 ((Dec, C.Name)) + | HappyAbsSyn40 (C.Expr) + | HappyAbsSyn48 (C.QName) + | HappyAbsSyn49 ([([Name],C.Expr)]) + | HappyAbsSyn50 (([Name],C.Expr)) + | HappyAbsSyn51 (C.TypeSig) + | HappyAbsSyn52 (C.Constructor) + | HappyAbsSyn53 ([C.Constructor ]) + | HappyAbsSyn54 ([C.Clause]) + | HappyAbsSyn55 (C.Clause) + | HappyAbsSyn56 ([C.Pattern]) + | HappyAbsSyn58 (C.Pattern) + | HappyAbsSyn64 ([C.Clause ]) + +{- to allow type-synonyms as our monads (likely + - with explicitly-specified bind and return) + - in Haskell98, it seems that with + - /type M a = .../, then /(HappyReduction M)/ + - is not allowed. But Happy is a + - code-generator that can just substitute it. +type HappyReduction m = + Int + -> (T.Token) + -> HappyState (T.Token) (HappyStk HappyAbsSyn -> [(T.Token)] -> m HappyAbsSyn) + -> [HappyState (T.Token) (HappyStk HappyAbsSyn -> [(T.Token)] -> m HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(T.Token)] -> m HappyAbsSyn +-} + +action_0, + action_1, + action_2, + action_3, + action_4, + action_5, + action_6, + action_7, + action_8, + action_9, + action_10, + action_11, + action_12, + action_13, + action_14, + action_15, + action_16, + action_17, + action_18, + action_19, + action_20, + action_21, + action_22, + action_23, + action_24, + action_25, + action_26, + action_27, + action_28, + action_29, + action_30, + action_31, + action_32, + action_33, + action_34, + action_35, + action_36, + action_37, + action_38, + action_39, + action_40, + action_41, + action_42, + action_43, + action_44, + action_45, + action_46, + action_47, + action_48, + action_49, + action_50, + action_51, + action_52, + action_53, + action_54, + action_55, + action_56, + action_57, + action_58, + action_59, + action_60, + action_61, + action_62, + action_63, + action_64, + action_65, + action_66, + action_67, + action_68, + action_69, + action_70, + action_71, + action_72, + action_73, + action_74, + action_75, + action_76, + action_77, + action_78, + action_79, + action_80, + action_81, + action_82, + action_83, + action_84, + action_85, + action_86, + action_87, + action_88, + action_89, + action_90, + action_91, + action_92, + action_93, + action_94, + action_95, + action_96, + action_97, + action_98, + action_99, + action_100, + action_101, + action_102, + action_103, + action_104, + action_105, + action_106, + action_107, + action_108, + action_109, + action_110, + action_111, + action_112, + action_113, + action_114, + action_115, + action_116, + action_117, + action_118, + action_119, + action_120, + action_121, + action_122, + action_123, + action_124, + action_125, + action_126, + action_127, + action_128, + action_129, + action_130, + action_131, + action_132, + action_133, + action_134, + action_135, + action_136, + action_137, + action_138, + action_139, + action_140, + action_141, + action_142, + action_143, + action_144, + action_145, + action_146, + action_147, + action_148, + action_149, + action_150, + action_151, + action_152, + action_153, + action_154, + action_155, + action_156, + action_157, + action_158, + action_159, + action_160, + action_161, + action_162, + action_163, + action_164, + action_165, + action_166, + action_167, + action_168, + action_169, + action_170, + action_171, + action_172, + action_173, + action_174, + action_175, + action_176, + action_177, + action_178, + action_179, + action_180, + action_181, + action_182, + action_183, + action_184, + action_185, + action_186, + action_187, + action_188, + action_189, + action_190, + action_191, + action_192, + action_193, + action_194, + action_195, + action_196, + action_197, + action_198, + action_199, + action_200, + action_201, + action_202, + action_203, + action_204, + action_205, + action_206, + action_207, + action_208, + action_209, + action_210, + action_211, + action_212, + action_213, + action_214, + action_215, + action_216, + action_217, + action_218, + action_219, + action_220, + action_221, + action_222, + action_223, + action_224, + action_225, + action_226, + action_227, + action_228, + action_229, + action_230, + action_231, + action_232, + action_233, + action_234, + action_235, + action_236, + action_237, + action_238, + action_239, + action_240, + action_241, + action_242, + action_243, + action_244, + action_245, + action_246, + action_247, + action_248, + action_249, + action_250, + action_251, + action_252, + action_253, + action_254, + action_255, + action_256, + action_257, + action_258, + action_259, + action_260, + action_261, + action_262, + action_263, + action_264, + action_265, + action_266, + action_267, + action_268, + action_269, + action_270, + action_271, + action_272, + action_273, + action_274, + action_275, + action_276, + action_277, + action_278, + action_279, + action_280, + action_281, + action_282, + action_283, + action_284, + action_285, + action_286, + action_287, + action_288, + action_289, + action_290, + action_291, + action_292, + action_293, + action_294, + action_295, + action_296, + action_297, + action_298, + action_299, + action_300, + action_301, + action_302, + action_303, + action_304, + action_305, + action_306, + action_307, + action_308, + action_309, + action_310, + action_311, + action_312, + action_313, + action_314, + action_315, + action_316, + action_317, + action_318, + action_319, + action_320, + action_321, + action_322, + action_323, + action_324, + action_325, + action_326, + action_327, + action_328, + action_329, + action_330, + action_331, + action_332, + action_333, + action_334, + action_335, + action_336, + action_337, + action_338, + action_339, + action_340, + action_341, + action_342, + action_343, + action_344, + action_345, + action_346, + action_347, + action_348, + action_349, + action_350, + action_351, + action_352, + action_353, + action_354, + action_355, + action_356, + action_357, + action_358, + action_359, + action_360, + action_361, + action_362, + action_363, + action_364, + action_365, + action_366, + action_367, + action_368, + action_369, + action_370, + action_371, + action_372, + action_373, + action_374, + action_375, + action_376, + action_377, + action_378, + action_379, + action_380, + action_381, + action_382, + action_383, + action_384, + action_385, + action_386, + action_387, + action_388, + action_389, + action_390, + action_391, + action_392, + action_393, + action_394, + action_395, + action_396, + action_397 :: () => Int -> ({-HappyReduction (HappyIdentity) = -} + Int + -> (T.Token) + -> HappyState (T.Token) (HappyStk HappyAbsSyn -> [(T.Token)] -> (HappyIdentity) HappyAbsSyn) + -> [HappyState (T.Token) (HappyStk HappyAbsSyn -> [(T.Token)] -> (HappyIdentity) HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(T.Token)] -> (HappyIdentity) HappyAbsSyn) + +happyReduce_1, + happyReduce_2, + happyReduce_3, + happyReduce_4, + happyReduce_5, + happyReduce_6, + happyReduce_7, + happyReduce_8, + happyReduce_9, + happyReduce_10, + happyReduce_11, + happyReduce_12, + happyReduce_13, + happyReduce_14, + happyReduce_15, + happyReduce_16, + happyReduce_17, + happyReduce_18, + happyReduce_19, + happyReduce_20, + happyReduce_21, + happyReduce_22, + happyReduce_23, + happyReduce_24, + happyReduce_25, + happyReduce_26, + happyReduce_27, + happyReduce_28, + happyReduce_29, + happyReduce_30, + happyReduce_31, + happyReduce_32, + happyReduce_33, + happyReduce_34, + happyReduce_35, + happyReduce_36, + happyReduce_37, + happyReduce_38, + happyReduce_39, + happyReduce_40, + happyReduce_41, + happyReduce_42, + happyReduce_43, + happyReduce_44, + happyReduce_45, + happyReduce_46, + happyReduce_47, + happyReduce_48, + happyReduce_49, + happyReduce_50, + happyReduce_51, + happyReduce_52, + happyReduce_53, + happyReduce_54, + happyReduce_55, + happyReduce_56, + happyReduce_57, + happyReduce_58, + happyReduce_59, + happyReduce_60, + happyReduce_61, + happyReduce_62, + happyReduce_63, + happyReduce_64, + happyReduce_65, + happyReduce_66, + happyReduce_67, + happyReduce_68, + happyReduce_69, + happyReduce_70, + happyReduce_71, + happyReduce_72, + happyReduce_73, + happyReduce_74, + happyReduce_75, + happyReduce_76, + happyReduce_77, + happyReduce_78, + happyReduce_79, + happyReduce_80, + happyReduce_81, + happyReduce_82, + happyReduce_83, + happyReduce_84, + happyReduce_85, + happyReduce_86, + happyReduce_87, + happyReduce_88, + happyReduce_89, + happyReduce_90, + happyReduce_91, + happyReduce_92, + happyReduce_93, + happyReduce_94, + happyReduce_95, + happyReduce_96, + happyReduce_97, + happyReduce_98, + happyReduce_99, + happyReduce_100, + happyReduce_101, + happyReduce_102, + happyReduce_103, + happyReduce_104, + happyReduce_105, + happyReduce_106, + happyReduce_107, + happyReduce_108, + happyReduce_109, + happyReduce_110, + happyReduce_111, + happyReduce_112, + happyReduce_113, + happyReduce_114, + happyReduce_115, + happyReduce_116, + happyReduce_117, + happyReduce_118, + happyReduce_119, + happyReduce_120, + happyReduce_121, + happyReduce_122, + happyReduce_123, + happyReduce_124, + happyReduce_125, + happyReduce_126, + happyReduce_127, + happyReduce_128, + happyReduce_129, + happyReduce_130, + happyReduce_131, + happyReduce_132, + happyReduce_133, + happyReduce_134, + happyReduce_135, + happyReduce_136, + happyReduce_137, + happyReduce_138, + happyReduce_139, + happyReduce_140, + happyReduce_141, + happyReduce_142, + happyReduce_143, + happyReduce_144, + happyReduce_145, + happyReduce_146, + happyReduce_147, + happyReduce_148, + happyReduce_149, + happyReduce_150, + happyReduce_151, + happyReduce_152, + happyReduce_153, + happyReduce_154, + happyReduce_155, + happyReduce_156, + happyReduce_157, + happyReduce_158, + happyReduce_159, + happyReduce_160, + happyReduce_161, + happyReduce_162, + happyReduce_163, + happyReduce_164, + happyReduce_165, + happyReduce_166, + happyReduce_167, + happyReduce_168, + happyReduce_169, + happyReduce_170, + happyReduce_171, + happyReduce_172, + happyReduce_173, + happyReduce_174, + happyReduce_175, + happyReduce_176, + happyReduce_177, + happyReduce_178, + happyReduce_179, + happyReduce_180, + happyReduce_181, + happyReduce_182, + happyReduce_183, + happyReduce_184, + happyReduce_185, + happyReduce_186, + happyReduce_187, + happyReduce_188 :: () => ({-HappyReduction (HappyIdentity) = -} + Int + -> (T.Token) + -> HappyState (T.Token) (HappyStk HappyAbsSyn -> [(T.Token)] -> (HappyIdentity) HappyAbsSyn) + -> [HappyState (T.Token) (HappyStk HappyAbsSyn -> [(T.Token)] -> (HappyIdentity) HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(T.Token)] -> (HappyIdentity) HappyAbsSyn) + +action_0 (4) = happyGoto action_3 +action_0 (5) = happyGoto action_2 +action_0 _ = happyReduce_2 + +action_1 (5) = happyGoto action_2 +action_1 _ = happyFail + +action_2 (70) = happyShift action_16 +action_2 (71) = happyShift action_17 +action_2 (72) = happyShift action_18 +action_2 (73) = happyShift action_19 +action_2 (75) = happyShift action_20 +action_2 (76) = happyShift action_21 +action_2 (77) = happyShift action_22 +action_2 (78) = happyShift action_23 +action_2 (83) = happyShift action_24 +action_2 (84) = happyShift action_25 +action_2 (85) = happyShift action_26 +action_2 (86) = happyShift action_27 +action_2 (87) = happyShift action_28 +action_2 (122) = happyReduce_1 +action_2 (6) = happyGoto action_4 +action_2 (7) = happyGoto action_5 +action_2 (8) = happyGoto action_6 +action_2 (9) = happyGoto action_7 +action_2 (10) = happyGoto action_8 +action_2 (11) = happyGoto action_9 +action_2 (14) = happyGoto action_10 +action_2 (15) = happyGoto action_11 +action_2 (16) = happyGoto action_12 +action_2 (17) = happyGoto action_13 +action_2 (19) = happyGoto action_14 +action_2 (21) = happyGoto action_15 +action_2 _ = happyReduce_36 + +action_3 (122) = happyAccept +action_3 _ = happyFail + +action_4 _ = happyReduce_3 + +action_5 _ = happyReduce_4 + +action_6 _ = happyReduce_6 + +action_7 _ = happyReduce_5 + +action_8 _ = happyReduce_7 + +action_9 _ = happyReduce_8 + +action_10 _ = happyReduce_9 + +action_11 _ = happyReduce_10 + +action_12 _ = happyReduce_11 + +action_13 _ = happyReduce_12 + +action_14 (81) = happyShift action_51 +action_14 _ = happyFail + +action_15 _ = happyReduce_13 + +action_16 (67) = happyShift action_39 +action_16 (12) = happyGoto action_50 +action_16 (23) = happyGoto action_49 +action_16 _ = happyFail + +action_17 (67) = happyShift action_39 +action_17 (12) = happyGoto action_48 +action_17 (23) = happyGoto action_49 +action_17 _ = happyFail + +action_18 (67) = happyShift action_39 +action_18 (13) = happyGoto action_46 +action_18 (23) = happyGoto action_47 +action_18 _ = happyFail + +action_19 (70) = happyShift action_44 +action_19 (71) = happyShift action_45 +action_19 _ = happyFail + +action_20 (99) = happyShift action_43 +action_20 _ = happyFail + +action_21 (67) = happyShift action_39 +action_21 (23) = happyGoto action_40 +action_21 (51) = happyGoto action_42 +action_21 _ = happyFail + +action_22 (67) = happyShift action_39 +action_22 (23) = happyGoto action_40 +action_22 (51) = happyGoto action_41 +action_22 _ = happyFail + +action_23 (67) = happyShift action_39 +action_23 (23) = happyGoto action_37 +action_23 (24) = happyGoto action_38 +action_23 _ = happyFail + +action_24 _ = happyReduce_37 + +action_25 (70) = happyShift action_16 +action_25 (71) = happyShift action_17 +action_25 (72) = happyShift action_18 +action_25 (73) = happyShift action_19 +action_25 (75) = happyShift action_20 +action_25 (76) = happyShift action_21 +action_25 (77) = happyShift action_22 +action_25 (78) = happyShift action_23 +action_25 (83) = happyShift action_24 +action_25 (84) = happyShift action_25 +action_25 (85) = happyShift action_26 +action_25 (86) = happyShift action_27 +action_25 (87) = happyShift action_28 +action_25 (99) = happyShift action_36 +action_25 (6) = happyGoto action_35 +action_25 (7) = happyGoto action_5 +action_25 (8) = happyGoto action_6 +action_25 (9) = happyGoto action_7 +action_25 (10) = happyGoto action_8 +action_25 (11) = happyGoto action_9 +action_25 (14) = happyGoto action_10 +action_25 (15) = happyGoto action_11 +action_25 (16) = happyGoto action_12 +action_25 (17) = happyGoto action_13 +action_25 (19) = happyGoto action_14 +action_25 (21) = happyGoto action_15 +action_25 _ = happyReduce_36 + +action_26 (70) = happyShift action_16 +action_26 (71) = happyShift action_17 +action_26 (72) = happyShift action_18 +action_26 (73) = happyShift action_19 +action_26 (75) = happyShift action_20 +action_26 (76) = happyShift action_21 +action_26 (77) = happyShift action_22 +action_26 (78) = happyShift action_23 +action_26 (83) = happyShift action_24 +action_26 (84) = happyShift action_25 +action_26 (85) = happyShift action_26 +action_26 (86) = happyShift action_27 +action_26 (87) = happyShift action_28 +action_26 (99) = happyShift action_34 +action_26 (6) = happyGoto action_33 +action_26 (7) = happyGoto action_5 +action_26 (8) = happyGoto action_6 +action_26 (9) = happyGoto action_7 +action_26 (10) = happyGoto action_8 +action_26 (11) = happyGoto action_9 +action_26 (14) = happyGoto action_10 +action_26 (15) = happyGoto action_11 +action_26 (16) = happyGoto action_12 +action_26 (17) = happyGoto action_13 +action_26 (19) = happyGoto action_14 +action_26 (21) = happyGoto action_15 +action_26 _ = happyReduce_36 + +action_27 (70) = happyShift action_16 +action_27 (71) = happyShift action_17 +action_27 (72) = happyShift action_18 +action_27 (73) = happyShift action_19 +action_27 (75) = happyShift action_20 +action_27 (76) = happyShift action_21 +action_27 (77) = happyShift action_22 +action_27 (78) = happyShift action_23 +action_27 (83) = happyShift action_24 +action_27 (84) = happyShift action_25 +action_27 (85) = happyShift action_26 +action_27 (86) = happyShift action_27 +action_27 (87) = happyShift action_28 +action_27 (99) = happyShift action_32 +action_27 (6) = happyGoto action_31 +action_27 (7) = happyGoto action_5 +action_27 (8) = happyGoto action_6 +action_27 (9) = happyGoto action_7 +action_27 (10) = happyGoto action_8 +action_27 (11) = happyGoto action_9 +action_27 (14) = happyGoto action_10 +action_27 (15) = happyGoto action_11 +action_27 (16) = happyGoto action_12 +action_27 (17) = happyGoto action_13 +action_27 (19) = happyGoto action_14 +action_27 (21) = happyGoto action_15 +action_27 _ = happyReduce_36 + +action_28 (70) = happyShift action_16 +action_28 (71) = happyShift action_17 +action_28 (72) = happyShift action_18 +action_28 (73) = happyShift action_19 +action_28 (75) = happyShift action_20 +action_28 (76) = happyShift action_21 +action_28 (77) = happyShift action_22 +action_28 (78) = happyShift action_23 +action_28 (83) = happyShift action_24 +action_28 (84) = happyShift action_25 +action_28 (85) = happyShift action_26 +action_28 (86) = happyShift action_27 +action_28 (87) = happyShift action_28 +action_28 (99) = happyShift action_30 +action_28 (6) = happyGoto action_29 +action_28 (7) = happyGoto action_5 +action_28 (8) = happyGoto action_6 +action_28 (9) = happyGoto action_7 +action_28 (10) = happyGoto action_8 +action_28 (11) = happyGoto action_9 +action_28 (14) = happyGoto action_10 +action_28 (15) = happyGoto action_11 +action_28 (16) = happyGoto action_12 +action_28 (17) = happyGoto action_13 +action_28 (19) = happyGoto action_14 +action_28 (21) = happyGoto action_15 +action_28 _ = happyReduce_36 + +action_29 _ = happyReduce_14 + +action_30 (5) = happyGoto action_80 +action_30 _ = happyReduce_2 + +action_31 _ = happyReduce_20 + +action_32 (5) = happyGoto action_79 +action_32 _ = happyReduce_2 + +action_33 _ = happyReduce_18 + +action_34 (5) = happyGoto action_78 +action_34 _ = happyReduce_2 + +action_35 _ = happyReduce_16 + +action_36 (5) = happyGoto action_77 +action_36 _ = happyReduce_2 + +action_37 (67) = happyShift action_39 +action_37 (23) = happyGoto action_37 +action_37 (24) = happyGoto action_76 +action_37 _ = happyReduce_44 + +action_38 (112) = happyShift action_75 +action_38 _ = happyFail + +action_39 _ = happyReduce_43 + +action_40 (108) = happyShift action_74 +action_40 _ = happyFail + +action_41 (99) = happyShift action_73 +action_41 _ = happyFail + +action_42 (99) = happyShift action_72 +action_42 _ = happyFail + +action_43 (5) = happyGoto action_71 +action_43 _ = happyReduce_2 + +action_44 (67) = happyShift action_39 +action_44 (12) = happyGoto action_70 +action_44 (23) = happyGoto action_49 +action_44 _ = happyFail + +action_45 (67) = happyShift action_39 +action_45 (12) = happyGoto action_69 +action_45 (23) = happyGoto action_49 +action_45 _ = happyFail + +action_46 _ = happyReduce_26 + +action_47 (101) = happyShift action_66 +action_47 (103) = happyShift action_67 +action_47 (109) = happyShift action_57 +action_47 (113) = happyShift action_58 +action_47 (114) = happyShift action_59 +action_47 (115) = happyShift action_60 +action_47 (117) = happyShift action_61 +action_47 (118) = happyShift action_62 +action_47 (26) = happyGoto action_63 +action_47 (65) = happyGoto action_64 +action_47 (66) = happyGoto action_68 +action_47 _ = happyReduce_187 + +action_48 _ = happyReduce_24 + +action_49 (101) = happyShift action_66 +action_49 (103) = happyShift action_67 +action_49 (109) = happyShift action_57 +action_49 (113) = happyShift action_58 +action_49 (114) = happyShift action_59 +action_49 (115) = happyShift action_60 +action_49 (117) = happyShift action_61 +action_49 (118) = happyShift action_62 +action_49 (26) = happyGoto action_63 +action_49 (65) = happyGoto action_64 +action_49 (66) = happyGoto action_65 +action_49 _ = happyReduce_187 + +action_50 _ = happyReduce_22 + +action_51 (67) = happyShift action_39 +action_51 (101) = happyShift action_56 +action_51 (109) = happyShift action_57 +action_51 (113) = happyShift action_58 +action_51 (114) = happyShift action_59 +action_51 (115) = happyShift action_60 +action_51 (117) = happyShift action_61 +action_51 (118) = happyShift action_62 +action_51 (18) = happyGoto action_52 +action_51 (23) = happyGoto action_53 +action_51 (26) = happyGoto action_54 +action_51 (36) = happyGoto action_55 +action_51 _ = happyFail + +action_52 _ = happyReduce_34 + +action_53 _ = happyReduce_81 + +action_54 (67) = happyShift action_39 +action_54 (23) = happyGoto action_153 +action_54 _ = happyFail + +action_55 (99) = happyShift action_125 +action_55 (101) = happyShift action_151 +action_55 (103) = happyShift action_152 +action_55 (105) = happyShift action_128 +action_55 (109) = happyShift action_57 +action_55 (113) = happyShift action_58 +action_55 (114) = happyShift action_59 +action_55 (115) = happyShift action_60 +action_55 (117) = happyShift action_61 +action_55 (118) = happyShift action_62 +action_55 (26) = happyGoto action_147 +action_55 (27) = happyGoto action_148 +action_55 (31) = happyGoto action_149 +action_55 (32) = happyGoto action_150 +action_55 (33) = happyGoto action_110 +action_55 (34) = happyGoto action_111 +action_55 _ = happyReduce_60 + +action_56 (67) = happyShift action_39 +action_56 (23) = happyGoto action_146 +action_56 _ = happyFail + +action_57 _ = happyReduce_51 + +action_58 _ = happyReduce_48 + +action_59 _ = happyReduce_49 + +action_60 _ = happyReduce_50 + +action_61 _ = happyReduce_53 + +action_62 _ = happyReduce_52 + +action_63 (103) = happyShift action_145 +action_63 _ = happyFail + +action_64 (101) = happyShift action_66 +action_64 (103) = happyShift action_67 +action_64 (109) = happyShift action_57 +action_64 (113) = happyShift action_58 +action_64 (114) = happyShift action_59 +action_64 (115) = happyShift action_60 +action_64 (117) = happyShift action_61 +action_64 (118) = happyShift action_62 +action_64 (26) = happyGoto action_63 +action_64 (65) = happyGoto action_64 +action_64 (66) = happyGoto action_144 +action_64 _ = happyReduce_187 + +action_65 (99) = happyShift action_142 +action_65 (108) = happyShift action_143 +action_65 _ = happyFail + +action_66 (67) = happyShift action_39 +action_66 (23) = happyGoto action_138 +action_66 (25) = happyGoto action_141 +action_66 _ = happyFail + +action_67 (67) = happyShift action_39 +action_67 (114) = happyShift action_140 +action_67 (23) = happyGoto action_138 +action_67 (25) = happyGoto action_139 +action_67 _ = happyFail + +action_68 (99) = happyShift action_136 +action_68 (108) = happyShift action_137 +action_68 _ = happyFail + +action_69 _ = happyReduce_25 + +action_70 _ = happyReduce_23 + +action_71 (70) = happyShift action_16 +action_71 (71) = happyShift action_17 +action_71 (72) = happyShift action_18 +action_71 (73) = happyShift action_19 +action_71 (75) = happyShift action_20 +action_71 (76) = happyShift action_21 +action_71 (77) = happyShift action_22 +action_71 (78) = happyShift action_23 +action_71 (83) = happyShift action_24 +action_71 (84) = happyShift action_25 +action_71 (85) = happyShift action_26 +action_71 (86) = happyShift action_27 +action_71 (87) = happyShift action_28 +action_71 (100) = happyShift action_135 +action_71 (6) = happyGoto action_4 +action_71 (7) = happyGoto action_5 +action_71 (8) = happyGoto action_6 +action_71 (9) = happyGoto action_7 +action_71 (10) = happyGoto action_8 +action_71 (11) = happyGoto action_9 +action_71 (14) = happyGoto action_10 +action_71 (15) = happyGoto action_11 +action_71 (16) = happyGoto action_12 +action_71 (17) = happyGoto action_13 +action_71 (19) = happyGoto action_14 +action_71 (21) = happyGoto action_15 +action_71 _ = happyReduce_36 + +action_72 (67) = happyShift action_39 +action_72 (23) = happyGoto action_130 +action_72 (55) = happyGoto action_131 +action_72 (63) = happyGoto action_134 +action_72 (64) = happyGoto action_133 +action_72 _ = happyReduce_182 + +action_73 (67) = happyShift action_39 +action_73 (23) = happyGoto action_130 +action_73 (55) = happyGoto action_131 +action_73 (63) = happyGoto action_132 +action_73 (64) = happyGoto action_133 +action_73 _ = happyReduce_182 + +action_74 (67) = happyShift action_39 +action_74 (68) = happyShift action_93 +action_74 (69) = happyShift action_119 +action_74 (72) = happyShift action_95 +action_74 (79) = happyShift action_120 +action_74 (81) = happyShift action_121 +action_74 (89) = happyShift action_122 +action_74 (90) = happyShift action_123 +action_74 (91) = happyShift action_96 +action_74 (92) = happyShift action_97 +action_74 (93) = happyShift action_124 +action_74 (94) = happyShift action_99 +action_74 (97) = happyShift action_100 +action_74 (99) = happyShift action_125 +action_74 (101) = happyShift action_126 +action_74 (103) = happyShift action_127 +action_74 (105) = happyShift action_128 +action_74 (109) = happyShift action_57 +action_74 (113) = happyShift action_58 +action_74 (114) = happyShift action_59 +action_74 (115) = happyShift action_60 +action_74 (117) = happyShift action_61 +action_74 (118) = happyShift action_62 +action_74 (120) = happyShift action_129 +action_74 (121) = happyShift action_103 +action_74 (23) = happyGoto action_104 +action_74 (26) = happyGoto action_105 +action_74 (27) = happyGoto action_106 +action_74 (29) = happyGoto action_107 +action_74 (31) = happyGoto action_108 +action_74 (32) = happyGoto action_109 +action_74 (33) = happyGoto action_110 +action_74 (34) = happyGoto action_111 +action_74 (39) = happyGoto action_112 +action_74 (42) = happyGoto action_113 +action_74 (43) = happyGoto action_114 +action_74 (44) = happyGoto action_115 +action_74 (45) = happyGoto action_116 +action_74 (46) = happyGoto action_117 +action_74 (47) = happyGoto action_118 +action_74 (48) = happyGoto action_87 +action_74 _ = happyReduce_60 + +action_75 (67) = happyShift action_39 +action_75 (68) = happyShift action_93 +action_75 (69) = happyShift action_94 +action_75 (72) = happyShift action_95 +action_75 (91) = happyShift action_96 +action_75 (92) = happyShift action_97 +action_75 (93) = happyShift action_98 +action_75 (94) = happyShift action_99 +action_75 (97) = happyShift action_100 +action_75 (103) = happyShift action_101 +action_75 (109) = happyShift action_102 +action_75 (121) = happyShift action_103 +action_75 (23) = happyGoto action_85 +action_75 (47) = happyGoto action_86 +action_75 (48) = happyGoto action_87 +action_75 (58) = happyGoto action_88 +action_75 (59) = happyGoto action_89 +action_75 (60) = happyGoto action_90 +action_75 (61) = happyGoto action_91 +action_75 (62) = happyGoto action_92 +action_75 _ = happyFail + +action_76 _ = happyReduce_45 + +action_77 (70) = happyShift action_16 +action_77 (71) = happyShift action_17 +action_77 (72) = happyShift action_18 +action_77 (73) = happyShift action_19 +action_77 (75) = happyShift action_20 +action_77 (76) = happyShift action_21 +action_77 (77) = happyShift action_22 +action_77 (78) = happyShift action_23 +action_77 (83) = happyShift action_24 +action_77 (84) = happyShift action_25 +action_77 (85) = happyShift action_26 +action_77 (86) = happyShift action_27 +action_77 (87) = happyShift action_28 +action_77 (100) = happyShift action_84 +action_77 (6) = happyGoto action_4 +action_77 (7) = happyGoto action_5 +action_77 (8) = happyGoto action_6 +action_77 (9) = happyGoto action_7 +action_77 (10) = happyGoto action_8 +action_77 (11) = happyGoto action_9 +action_77 (14) = happyGoto action_10 +action_77 (15) = happyGoto action_11 +action_77 (16) = happyGoto action_12 +action_77 (17) = happyGoto action_13 +action_77 (19) = happyGoto action_14 +action_77 (21) = happyGoto action_15 +action_77 _ = happyReduce_36 + +action_78 (70) = happyShift action_16 +action_78 (71) = happyShift action_17 +action_78 (72) = happyShift action_18 +action_78 (73) = happyShift action_19 +action_78 (75) = happyShift action_20 +action_78 (76) = happyShift action_21 +action_78 (77) = happyShift action_22 +action_78 (78) = happyShift action_23 +action_78 (83) = happyShift action_24 +action_78 (84) = happyShift action_25 +action_78 (85) = happyShift action_26 +action_78 (86) = happyShift action_27 +action_78 (87) = happyShift action_28 +action_78 (100) = happyShift action_83 +action_78 (6) = happyGoto action_4 +action_78 (7) = happyGoto action_5 +action_78 (8) = happyGoto action_6 +action_78 (9) = happyGoto action_7 +action_78 (10) = happyGoto action_8 +action_78 (11) = happyGoto action_9 +action_78 (14) = happyGoto action_10 +action_78 (15) = happyGoto action_11 +action_78 (16) = happyGoto action_12 +action_78 (17) = happyGoto action_13 +action_78 (19) = happyGoto action_14 +action_78 (21) = happyGoto action_15 +action_78 _ = happyReduce_36 + +action_79 (70) = happyShift action_16 +action_79 (71) = happyShift action_17 +action_79 (72) = happyShift action_18 +action_79 (73) = happyShift action_19 +action_79 (75) = happyShift action_20 +action_79 (76) = happyShift action_21 +action_79 (77) = happyShift action_22 +action_79 (78) = happyShift action_23 +action_79 (83) = happyShift action_24 +action_79 (84) = happyShift action_25 +action_79 (85) = happyShift action_26 +action_79 (86) = happyShift action_27 +action_79 (87) = happyShift action_28 +action_79 (100) = happyShift action_82 +action_79 (6) = happyGoto action_4 +action_79 (7) = happyGoto action_5 +action_79 (8) = happyGoto action_6 +action_79 (9) = happyGoto action_7 +action_79 (10) = happyGoto action_8 +action_79 (11) = happyGoto action_9 +action_79 (14) = happyGoto action_10 +action_79 (15) = happyGoto action_11 +action_79 (16) = happyGoto action_12 +action_79 (17) = happyGoto action_13 +action_79 (19) = happyGoto action_14 +action_79 (21) = happyGoto action_15 +action_79 _ = happyReduce_36 + +action_80 (70) = happyShift action_16 +action_80 (71) = happyShift action_17 +action_80 (72) = happyShift action_18 +action_80 (73) = happyShift action_19 +action_80 (75) = happyShift action_20 +action_80 (76) = happyShift action_21 +action_80 (77) = happyShift action_22 +action_80 (78) = happyShift action_23 +action_80 (83) = happyShift action_24 +action_80 (84) = happyShift action_25 +action_80 (85) = happyShift action_26 +action_80 (86) = happyShift action_27 +action_80 (87) = happyShift action_28 +action_80 (100) = happyShift action_81 +action_80 (6) = happyGoto action_4 +action_80 (7) = happyGoto action_5 +action_80 (8) = happyGoto action_6 +action_80 (9) = happyGoto action_7 +action_80 (10) = happyGoto action_8 +action_80 (11) = happyGoto action_9 +action_80 (14) = happyGoto action_10 +action_80 (15) = happyGoto action_11 +action_80 (16) = happyGoto action_12 +action_80 (17) = happyGoto action_13 +action_80 (19) = happyGoto action_14 +action_80 (21) = happyGoto action_15 +action_80 _ = happyReduce_36 + +action_81 _ = happyReduce_15 + +action_82 _ = happyReduce_21 + +action_83 _ = happyReduce_19 + +action_84 _ = happyReduce_17 + +action_85 (67) = happyReduce_176 +action_85 (70) = happyReduce_176 +action_85 (71) = happyReduce_176 +action_85 (72) = happyReduce_176 +action_85 (73) = happyReduce_176 +action_85 (75) = happyReduce_176 +action_85 (76) = happyReduce_176 +action_85 (77) = happyReduce_176 +action_85 (78) = happyReduce_176 +action_85 (81) = happyReduce_176 +action_85 (83) = happyReduce_176 +action_85 (84) = happyReduce_176 +action_85 (85) = happyReduce_176 +action_85 (86) = happyReduce_176 +action_85 (87) = happyReduce_176 +action_85 (93) = happyReduce_176 +action_85 (95) = happyReduce_176 +action_85 (97) = happyShift action_241 +action_85 (100) = happyReduce_176 +action_85 (103) = happyReduce_176 +action_85 (104) = happyReduce_176 +action_85 (106) = happyReduce_176 +action_85 (107) = happyReduce_176 +action_85 (109) = happyReduce_176 +action_85 (112) = happyReduce_176 +action_85 (122) = happyReduce_176 +action_85 _ = happyReduce_138 + +action_86 (98) = happyShift action_240 +action_86 _ = happyFail + +action_87 _ = happyReduce_130 + +action_88 _ = happyReduce_172 + +action_89 _ = happyReduce_40 + +action_90 (106) = happyShift action_239 +action_90 _ = happyReduce_168 + +action_91 (67) = happyShift action_39 +action_91 (93) = happyShift action_235 +action_91 (95) = happyShift action_238 +action_91 (103) = happyShift action_236 +action_91 (109) = happyShift action_102 +action_91 (23) = happyGoto action_233 +action_91 (58) = happyGoto action_237 +action_91 (62) = happyGoto action_231 +action_91 _ = happyReduce_169 + +action_92 (67) = happyShift action_39 +action_92 (93) = happyShift action_235 +action_92 (103) = happyShift action_236 +action_92 (109) = happyShift action_102 +action_92 (23) = happyGoto action_233 +action_92 (58) = happyGoto action_234 +action_92 (62) = happyGoto action_231 +action_92 _ = happyReduce_163 + +action_93 _ = happyReduce_137 + +action_94 _ = happyReduce_135 + +action_95 (99) = happyShift action_232 +action_95 _ = happyFail + +action_96 _ = happyReduce_127 + +action_97 _ = happyReduce_129 + +action_98 (67) = happyShift action_39 +action_98 (68) = happyShift action_93 +action_98 (69) = happyShift action_94 +action_98 (72) = happyShift action_95 +action_98 (91) = happyShift action_96 +action_98 (92) = happyShift action_97 +action_98 (93) = happyShift action_98 +action_98 (94) = happyShift action_99 +action_98 (97) = happyShift action_100 +action_98 (103) = happyShift action_101 +action_98 (109) = happyShift action_102 +action_98 (121) = happyShift action_103 +action_98 (23) = happyGoto action_229 +action_98 (47) = happyGoto action_191 +action_98 (48) = happyGoto action_87 +action_98 (58) = happyGoto action_230 +action_98 (62) = happyGoto action_231 +action_98 _ = happyFail + +action_99 _ = happyReduce_128 + +action_100 (67) = happyShift action_39 +action_100 (68) = happyShift action_93 +action_100 (69) = happyShift action_119 +action_100 (72) = happyShift action_95 +action_100 (79) = happyShift action_120 +action_100 (81) = happyShift action_121 +action_100 (89) = happyShift action_122 +action_100 (90) = happyShift action_123 +action_100 (91) = happyShift action_96 +action_100 (92) = happyShift action_97 +action_100 (93) = happyShift action_124 +action_100 (94) = happyShift action_99 +action_100 (97) = happyShift action_100 +action_100 (99) = happyShift action_125 +action_100 (101) = happyShift action_126 +action_100 (103) = happyShift action_127 +action_100 (105) = happyShift action_128 +action_100 (109) = happyShift action_57 +action_100 (113) = happyShift action_58 +action_100 (114) = happyShift action_59 +action_100 (115) = happyShift action_60 +action_100 (117) = happyShift action_61 +action_100 (118) = happyShift action_62 +action_100 (120) = happyShift action_129 +action_100 (121) = happyShift action_103 +action_100 (23) = happyGoto action_104 +action_100 (26) = happyGoto action_105 +action_100 (27) = happyGoto action_106 +action_100 (29) = happyGoto action_107 +action_100 (31) = happyGoto action_108 +action_100 (32) = happyGoto action_109 +action_100 (33) = happyGoto action_110 +action_100 (34) = happyGoto action_111 +action_100 (39) = happyGoto action_112 +action_100 (40) = happyGoto action_228 +action_100 (41) = happyGoto action_200 +action_100 (42) = happyGoto action_157 +action_100 (43) = happyGoto action_114 +action_100 (44) = happyGoto action_115 +action_100 (45) = happyGoto action_116 +action_100 (46) = happyGoto action_117 +action_100 (47) = happyGoto action_118 +action_100 (48) = happyGoto action_87 +action_100 _ = happyReduce_60 + +action_101 (67) = happyShift action_39 +action_101 (68) = happyShift action_93 +action_101 (69) = happyShift action_119 +action_101 (72) = happyShift action_95 +action_101 (79) = happyShift action_120 +action_101 (81) = happyShift action_121 +action_101 (89) = happyShift action_122 +action_101 (90) = happyShift action_123 +action_101 (91) = happyShift action_96 +action_101 (92) = happyShift action_97 +action_101 (93) = happyShift action_98 +action_101 (94) = happyShift action_99 +action_101 (97) = happyShift action_100 +action_101 (99) = happyShift action_125 +action_101 (101) = happyShift action_126 +action_101 (103) = happyShift action_225 +action_101 (104) = happyShift action_226 +action_101 (105) = happyShift action_128 +action_101 (109) = happyShift action_227 +action_101 (113) = happyShift action_58 +action_101 (114) = happyShift action_59 +action_101 (115) = happyShift action_60 +action_101 (117) = happyShift action_61 +action_101 (118) = happyShift action_62 +action_101 (120) = happyShift action_129 +action_101 (121) = happyShift action_103 +action_101 (23) = happyGoto action_85 +action_101 (26) = happyGoto action_105 +action_101 (27) = happyGoto action_106 +action_101 (29) = happyGoto action_107 +action_101 (31) = happyGoto action_108 +action_101 (32) = happyGoto action_109 +action_101 (33) = happyGoto action_110 +action_101 (34) = happyGoto action_111 +action_101 (39) = happyGoto action_112 +action_101 (40) = happyGoto action_185 +action_101 (41) = happyGoto action_200 +action_101 (42) = happyGoto action_157 +action_101 (43) = happyGoto action_114 +action_101 (44) = happyGoto action_115 +action_101 (45) = happyGoto action_116 +action_101 (46) = happyGoto action_117 +action_101 (47) = happyGoto action_223 +action_101 (48) = happyGoto action_87 +action_101 (58) = happyGoto action_88 +action_101 (59) = happyGoto action_224 +action_101 (60) = happyGoto action_90 +action_101 (61) = happyGoto action_91 +action_101 (62) = happyGoto action_92 +action_101 _ = happyReduce_60 + +action_102 (67) = happyShift action_39 +action_102 (68) = happyShift action_93 +action_102 (69) = happyShift action_94 +action_102 (72) = happyShift action_95 +action_102 (89) = happyShift action_222 +action_102 (91) = happyShift action_96 +action_102 (92) = happyShift action_97 +action_102 (93) = happyShift action_124 +action_102 (94) = happyShift action_99 +action_102 (97) = happyShift action_100 +action_102 (103) = happyShift action_192 +action_102 (121) = happyShift action_103 +action_102 (23) = happyGoto action_220 +action_102 (47) = happyGoto action_221 +action_102 (48) = happyGoto action_87 +action_102 _ = happyFail + +action_103 _ = happyReduce_133 + +action_104 _ = happyReduce_138 + +action_105 (67) = happyShift action_39 +action_105 (68) = happyShift action_93 +action_105 (69) = happyShift action_119 +action_105 (72) = happyShift action_95 +action_105 (89) = happyShift action_122 +action_105 (90) = happyShift action_123 +action_105 (91) = happyShift action_96 +action_105 (92) = happyShift action_97 +action_105 (93) = happyShift action_124 +action_105 (94) = happyShift action_99 +action_105 (97) = happyShift action_100 +action_105 (99) = happyShift action_125 +action_105 (101) = happyShift action_218 +action_105 (103) = happyShift action_219 +action_105 (105) = happyShift action_128 +action_105 (109) = happyShift action_57 +action_105 (113) = happyShift action_58 +action_105 (114) = happyShift action_59 +action_105 (115) = happyShift action_60 +action_105 (117) = happyShift action_61 +action_105 (118) = happyShift action_62 +action_105 (121) = happyShift action_103 +action_105 (23) = happyGoto action_104 +action_105 (26) = happyGoto action_212 +action_105 (27) = happyGoto action_213 +action_105 (29) = happyGoto action_214 +action_105 (32) = happyGoto action_215 +action_105 (33) = happyGoto action_110 +action_105 (34) = happyGoto action_111 +action_105 (43) = happyGoto action_216 +action_105 (44) = happyGoto action_115 +action_105 (45) = happyGoto action_217 +action_105 (46) = happyGoto action_117 +action_105 (47) = happyGoto action_118 +action_105 (48) = happyGoto action_87 +action_105 _ = happyFail + +action_106 (97) = happyShift action_210 +action_106 (99) = happyShift action_125 +action_106 (101) = happyShift action_151 +action_106 (103) = happyShift action_152 +action_106 (105) = happyShift action_128 +action_106 (109) = happyShift action_57 +action_106 (110) = happyReduce_96 +action_106 (111) = happyShift action_211 +action_106 (113) = happyShift action_58 +action_106 (114) = happyShift action_59 +action_106 (115) = happyShift action_60 +action_106 (117) = happyShift action_61 +action_106 (118) = happyShift action_62 +action_106 (26) = happyGoto action_147 +action_106 (27) = happyGoto action_148 +action_106 (31) = happyGoto action_163 +action_106 (32) = happyGoto action_150 +action_106 (33) = happyGoto action_110 +action_106 (34) = happyGoto action_111 +action_106 _ = happyReduce_116 + +action_107 (119) = happyReduce_117 +action_107 _ = happyReduce_97 + +action_108 _ = happyReduce_98 + +action_109 (99) = happyShift action_125 +action_109 (101) = happyShift action_151 +action_109 (103) = happyShift action_152 +action_109 (105) = happyShift action_128 +action_109 (109) = happyShift action_57 +action_109 (110) = happyReduce_95 +action_109 (113) = happyShift action_58 +action_109 (114) = happyShift action_59 +action_109 (115) = happyShift action_60 +action_109 (117) = happyShift action_61 +action_109 (118) = happyShift action_62 +action_109 (26) = happyGoto action_147 +action_109 (27) = happyGoto action_148 +action_109 (31) = happyGoto action_160 +action_109 (32) = happyGoto action_150 +action_109 (33) = happyGoto action_110 +action_109 (34) = happyGoto action_111 +action_109 _ = happyReduce_115 + +action_110 _ = happyReduce_69 + +action_111 _ = happyReduce_70 + +action_112 (110) = happyShift action_209 +action_112 _ = happyFail + +action_113 _ = happyReduce_143 + +action_114 (110) = happyReduce_92 +action_114 _ = happyReduce_106 + +action_115 (119) = happyShift action_208 +action_115 _ = happyFail + +action_116 (95) = happyShift action_205 +action_116 (96) = happyShift action_206 +action_116 (114) = happyShift action_207 +action_116 (119) = happyReduce_112 +action_116 _ = happyReduce_110 + +action_117 (67) = happyShift action_39 +action_117 (68) = happyShift action_93 +action_117 (69) = happyShift action_94 +action_117 (72) = happyShift action_95 +action_117 (89) = happyShift action_203 +action_117 (91) = happyShift action_96 +action_117 (92) = happyShift action_97 +action_117 (93) = happyShift action_124 +action_117 (94) = happyShift action_99 +action_117 (97) = happyShift action_100 +action_117 (103) = happyShift action_192 +action_117 (109) = happyShift action_204 +action_117 (121) = happyShift action_103 +action_117 (23) = happyGoto action_104 +action_117 (47) = happyGoto action_202 +action_117 (48) = happyGoto action_87 +action_117 _ = happyReduce_118 + +action_118 _ = happyReduce_123 + +action_119 (117) = happyShift action_201 +action_119 _ = happyReduce_135 + +action_120 (67) = happyShift action_39 +action_120 (68) = happyShift action_93 +action_120 (69) = happyShift action_119 +action_120 (72) = happyShift action_95 +action_120 (79) = happyShift action_120 +action_120 (81) = happyShift action_121 +action_120 (89) = happyShift action_122 +action_120 (90) = happyShift action_123 +action_120 (91) = happyShift action_96 +action_120 (92) = happyShift action_97 +action_120 (93) = happyShift action_124 +action_120 (94) = happyShift action_99 +action_120 (97) = happyShift action_100 +action_120 (99) = happyShift action_125 +action_120 (101) = happyShift action_126 +action_120 (103) = happyShift action_127 +action_120 (105) = happyShift action_128 +action_120 (109) = happyShift action_57 +action_120 (113) = happyShift action_58 +action_120 (114) = happyShift action_59 +action_120 (115) = happyShift action_60 +action_120 (117) = happyShift action_61 +action_120 (118) = happyShift action_62 +action_120 (120) = happyShift action_129 +action_120 (121) = happyShift action_103 +action_120 (23) = happyGoto action_104 +action_120 (26) = happyGoto action_105 +action_120 (27) = happyGoto action_106 +action_120 (29) = happyGoto action_107 +action_120 (31) = happyGoto action_108 +action_120 (32) = happyGoto action_109 +action_120 (33) = happyGoto action_110 +action_120 (34) = happyGoto action_111 +action_120 (39) = happyGoto action_112 +action_120 (40) = happyGoto action_199 +action_120 (41) = happyGoto action_200 +action_120 (42) = happyGoto action_157 +action_120 (43) = happyGoto action_114 +action_120 (44) = happyGoto action_115 +action_120 (45) = happyGoto action_116 +action_120 (46) = happyGoto action_117 +action_120 (47) = happyGoto action_118 +action_120 (48) = happyGoto action_87 +action_120 _ = happyReduce_60 + +action_121 (67) = happyShift action_39 +action_121 (101) = happyShift action_198 +action_121 (109) = happyShift action_57 +action_121 (113) = happyShift action_58 +action_121 (114) = happyShift action_59 +action_121 (115) = happyShift action_60 +action_121 (117) = happyShift action_61 +action_121 (118) = happyShift action_62 +action_121 (18) = happyGoto action_195 +action_121 (23) = happyGoto action_53 +action_121 (26) = happyGoto action_196 +action_121 (36) = happyGoto action_55 +action_121 (37) = happyGoto action_197 +action_121 _ = happyFail + +action_122 (67) = happyShift action_39 +action_122 (68) = happyShift action_93 +action_122 (69) = happyShift action_94 +action_122 (72) = happyShift action_95 +action_122 (91) = happyShift action_96 +action_122 (92) = happyShift action_97 +action_122 (93) = happyShift action_124 +action_122 (94) = happyShift action_99 +action_122 (97) = happyShift action_100 +action_122 (103) = happyShift action_192 +action_122 (121) = happyShift action_103 +action_122 (23) = happyGoto action_104 +action_122 (47) = happyGoto action_194 +action_122 (48) = happyGoto action_87 +action_122 _ = happyReduce_120 + +action_123 (67) = happyShift action_39 +action_123 (68) = happyShift action_93 +action_123 (69) = happyShift action_94 +action_123 (72) = happyShift action_95 +action_123 (91) = happyShift action_96 +action_123 (92) = happyShift action_97 +action_123 (93) = happyShift action_124 +action_123 (94) = happyShift action_99 +action_123 (97) = happyShift action_100 +action_123 (103) = happyShift action_192 +action_123 (121) = happyShift action_103 +action_123 (23) = happyGoto action_104 +action_123 (47) = happyGoto action_193 +action_123 (48) = happyGoto action_87 +action_123 _ = happyFail + +action_124 (67) = happyShift action_39 +action_124 (68) = happyShift action_93 +action_124 (69) = happyShift action_94 +action_124 (72) = happyShift action_95 +action_124 (91) = happyShift action_96 +action_124 (92) = happyShift action_97 +action_124 (93) = happyShift action_124 +action_124 (94) = happyShift action_99 +action_124 (97) = happyShift action_100 +action_124 (103) = happyShift action_192 +action_124 (121) = happyShift action_103 +action_124 (23) = happyGoto action_104 +action_124 (47) = happyGoto action_191 +action_124 (48) = happyGoto action_87 +action_124 _ = happyFail + +action_125 (67) = happyShift action_39 +action_125 (23) = happyGoto action_189 +action_125 (25) = happyGoto action_190 +action_125 _ = happyFail + +action_126 (67) = happyShift action_39 +action_126 (68) = happyShift action_93 +action_126 (69) = happyShift action_119 +action_126 (72) = happyShift action_95 +action_126 (79) = happyShift action_120 +action_126 (81) = happyShift action_121 +action_126 (89) = happyShift action_122 +action_126 (90) = happyShift action_123 +action_126 (91) = happyShift action_96 +action_126 (92) = happyShift action_97 +action_126 (93) = happyShift action_124 +action_126 (94) = happyShift action_99 +action_126 (97) = happyShift action_100 +action_126 (99) = happyShift action_125 +action_126 (101) = happyShift action_126 +action_126 (103) = happyShift action_127 +action_126 (105) = happyShift action_128 +action_126 (109) = happyShift action_57 +action_126 (113) = happyShift action_58 +action_126 (114) = happyShift action_59 +action_126 (115) = happyShift action_60 +action_126 (117) = happyShift action_61 +action_126 (118) = happyShift action_62 +action_126 (120) = happyShift action_129 +action_126 (121) = happyShift action_103 +action_126 (23) = happyGoto action_187 +action_126 (25) = happyGoto action_159 +action_126 (26) = happyGoto action_105 +action_126 (27) = happyGoto action_106 +action_126 (29) = happyGoto action_107 +action_126 (31) = happyGoto action_108 +action_126 (32) = happyGoto action_109 +action_126 (33) = happyGoto action_110 +action_126 (34) = happyGoto action_111 +action_126 (39) = happyGoto action_112 +action_126 (42) = happyGoto action_188 +action_126 (43) = happyGoto action_114 +action_126 (44) = happyGoto action_115 +action_126 (45) = happyGoto action_116 +action_126 (46) = happyGoto action_117 +action_126 (47) = happyGoto action_118 +action_126 (48) = happyGoto action_87 +action_126 _ = happyReduce_60 + +action_127 (67) = happyShift action_39 +action_127 (68) = happyShift action_93 +action_127 (69) = happyShift action_119 +action_127 (72) = happyShift action_95 +action_127 (79) = happyShift action_120 +action_127 (81) = happyShift action_121 +action_127 (89) = happyShift action_122 +action_127 (90) = happyShift action_123 +action_127 (91) = happyShift action_96 +action_127 (92) = happyShift action_97 +action_127 (93) = happyShift action_124 +action_127 (94) = happyShift action_99 +action_127 (97) = happyShift action_100 +action_127 (99) = happyShift action_125 +action_127 (101) = happyShift action_126 +action_127 (103) = happyShift action_127 +action_127 (105) = happyShift action_128 +action_127 (109) = happyShift action_57 +action_127 (113) = happyShift action_58 +action_127 (114) = happyShift action_59 +action_127 (115) = happyShift action_60 +action_127 (117) = happyShift action_61 +action_127 (118) = happyShift action_62 +action_127 (120) = happyShift action_129 +action_127 (121) = happyShift action_103 +action_127 (23) = happyGoto action_154 +action_127 (26) = happyGoto action_105 +action_127 (27) = happyGoto action_106 +action_127 (29) = happyGoto action_107 +action_127 (30) = happyGoto action_155 +action_127 (31) = happyGoto action_108 +action_127 (32) = happyGoto action_109 +action_127 (33) = happyGoto action_110 +action_127 (34) = happyGoto action_111 +action_127 (39) = happyGoto action_112 +action_127 (40) = happyGoto action_185 +action_127 (41) = happyGoto action_186 +action_127 (42) = happyGoto action_157 +action_127 (43) = happyGoto action_114 +action_127 (44) = happyGoto action_115 +action_127 (45) = happyGoto action_116 +action_127 (46) = happyGoto action_117 +action_127 (47) = happyGoto action_118 +action_127 (48) = happyGoto action_87 +action_127 _ = happyReduce_60 + +action_128 (67) = happyShift action_39 +action_128 (68) = happyShift action_93 +action_128 (69) = happyShift action_119 +action_128 (72) = happyShift action_95 +action_128 (79) = happyShift action_120 +action_128 (81) = happyShift action_121 +action_128 (89) = happyShift action_122 +action_128 (90) = happyShift action_123 +action_128 (91) = happyShift action_96 +action_128 (92) = happyShift action_97 +action_128 (93) = happyShift action_124 +action_128 (94) = happyShift action_99 +action_128 (97) = happyShift action_100 +action_128 (99) = happyShift action_125 +action_128 (101) = happyShift action_126 +action_128 (103) = happyShift action_127 +action_128 (105) = happyShift action_128 +action_128 (109) = happyShift action_57 +action_128 (113) = happyShift action_58 +action_128 (114) = happyShift action_59 +action_128 (115) = happyShift action_60 +action_128 (117) = happyShift action_61 +action_128 (118) = happyShift action_62 +action_128 (120) = happyShift action_129 +action_128 (121) = happyShift action_103 +action_128 (23) = happyGoto action_104 +action_128 (26) = happyGoto action_105 +action_128 (27) = happyGoto action_106 +action_128 (28) = happyGoto action_183 +action_128 (29) = happyGoto action_107 +action_128 (31) = happyGoto action_108 +action_128 (32) = happyGoto action_109 +action_128 (33) = happyGoto action_110 +action_128 (34) = happyGoto action_111 +action_128 (39) = happyGoto action_112 +action_128 (42) = happyGoto action_184 +action_128 (43) = happyGoto action_114 +action_128 (44) = happyGoto action_115 +action_128 (45) = happyGoto action_116 +action_128 (46) = happyGoto action_117 +action_128 (47) = happyGoto action_118 +action_128 (48) = happyGoto action_87 +action_128 _ = happyReduce_60 + +action_129 (67) = happyShift action_39 +action_129 (23) = happyGoto action_37 +action_129 (24) = happyGoto action_182 +action_129 _ = happyFail + +action_130 (56) = happyGoto action_180 +action_130 (57) = happyGoto action_181 +action_130 _ = happyReduce_158 + +action_131 _ = happyReduce_181 + +action_132 (100) = happyShift action_179 +action_132 _ = happyFail + +action_133 (107) = happyShift action_178 +action_133 _ = happyReduce_178 + +action_134 (100) = happyShift action_177 +action_134 _ = happyFail + +action_135 _ = happyReduce_33 + +action_136 (67) = happyShift action_39 +action_136 (23) = happyGoto action_168 +action_136 (52) = happyGoto action_176 +action_136 _ = happyFail + +action_137 (67) = happyShift action_39 +action_137 (68) = happyShift action_93 +action_137 (69) = happyShift action_119 +action_137 (72) = happyShift action_95 +action_137 (79) = happyShift action_120 +action_137 (81) = happyShift action_121 +action_137 (89) = happyShift action_122 +action_137 (90) = happyShift action_123 +action_137 (91) = happyShift action_96 +action_137 (92) = happyShift action_97 +action_137 (93) = happyShift action_124 +action_137 (94) = happyShift action_99 +action_137 (97) = happyShift action_100 +action_137 (99) = happyShift action_125 +action_137 (101) = happyShift action_126 +action_137 (103) = happyShift action_127 +action_137 (105) = happyShift action_128 +action_137 (109) = happyShift action_57 +action_137 (113) = happyShift action_58 +action_137 (114) = happyShift action_59 +action_137 (115) = happyShift action_60 +action_137 (117) = happyShift action_61 +action_137 (118) = happyShift action_62 +action_137 (120) = happyShift action_129 +action_137 (121) = happyShift action_103 +action_137 (23) = happyGoto action_104 +action_137 (26) = happyGoto action_105 +action_137 (27) = happyGoto action_106 +action_137 (29) = happyGoto action_107 +action_137 (31) = happyGoto action_108 +action_137 (32) = happyGoto action_109 +action_137 (33) = happyGoto action_110 +action_137 (34) = happyGoto action_111 +action_137 (39) = happyGoto action_112 +action_137 (42) = happyGoto action_175 +action_137 (43) = happyGoto action_114 +action_137 (44) = happyGoto action_115 +action_137 (45) = happyGoto action_116 +action_137 (46) = happyGoto action_117 +action_137 (47) = happyGoto action_118 +action_137 (48) = happyGoto action_87 +action_137 _ = happyReduce_60 + +action_138 (106) = happyShift action_174 +action_138 _ = happyReduce_46 + +action_139 (108) = happyShift action_173 +action_139 _ = happyFail + +action_140 (67) = happyShift action_39 +action_140 (23) = happyGoto action_138 +action_140 (25) = happyGoto action_172 +action_140 _ = happyFail + +action_141 (108) = happyShift action_171 +action_141 _ = happyFail + +action_142 (67) = happyShift action_39 +action_142 (23) = happyGoto action_168 +action_142 (52) = happyGoto action_169 +action_142 (53) = happyGoto action_170 +action_142 _ = happyReduce_149 + +action_143 (67) = happyShift action_39 +action_143 (68) = happyShift action_93 +action_143 (69) = happyShift action_119 +action_143 (72) = happyShift action_95 +action_143 (79) = happyShift action_120 +action_143 (81) = happyShift action_121 +action_143 (89) = happyShift action_122 +action_143 (90) = happyShift action_123 +action_143 (91) = happyShift action_96 +action_143 (92) = happyShift action_97 +action_143 (93) = happyShift action_124 +action_143 (94) = happyShift action_99 +action_143 (97) = happyShift action_100 +action_143 (99) = happyShift action_125 +action_143 (101) = happyShift action_126 +action_143 (103) = happyShift action_127 +action_143 (105) = happyShift action_128 +action_143 (109) = happyShift action_57 +action_143 (113) = happyShift action_58 +action_143 (114) = happyShift action_59 +action_143 (115) = happyShift action_60 +action_143 (117) = happyShift action_61 +action_143 (118) = happyShift action_62 +action_143 (120) = happyShift action_129 +action_143 (121) = happyShift action_103 +action_143 (23) = happyGoto action_104 +action_143 (26) = happyGoto action_105 +action_143 (27) = happyGoto action_106 +action_143 (29) = happyGoto action_107 +action_143 (31) = happyGoto action_108 +action_143 (32) = happyGoto action_109 +action_143 (33) = happyGoto action_110 +action_143 (34) = happyGoto action_111 +action_143 (39) = happyGoto action_112 +action_143 (42) = happyGoto action_167 +action_143 (43) = happyGoto action_114 +action_143 (44) = happyGoto action_115 +action_143 (45) = happyGoto action_116 +action_143 (46) = happyGoto action_117 +action_143 (47) = happyGoto action_118 +action_143 (48) = happyGoto action_87 +action_143 _ = happyReduce_60 + +action_144 _ = happyReduce_188 + +action_145 (67) = happyShift action_39 +action_145 (23) = happyGoto action_138 +action_145 (25) = happyGoto action_166 +action_145 _ = happyFail + +action_146 (102) = happyShift action_165 +action_146 _ = happyFail + +action_147 (103) = happyShift action_164 +action_147 _ = happyFail + +action_148 (99) = happyShift action_125 +action_148 (101) = happyShift action_151 +action_148 (103) = happyShift action_152 +action_148 (105) = happyShift action_128 +action_148 (109) = happyShift action_57 +action_148 (113) = happyShift action_58 +action_148 (114) = happyShift action_59 +action_148 (115) = happyShift action_60 +action_148 (117) = happyShift action_61 +action_148 (118) = happyShift action_62 +action_148 (26) = happyGoto action_147 +action_148 (27) = happyGoto action_148 +action_148 (31) = happyGoto action_163 +action_148 (32) = happyGoto action_150 +action_148 (33) = happyGoto action_110 +action_148 (34) = happyGoto action_111 +action_148 _ = happyReduce_60 + +action_149 (108) = happyShift action_162 +action_149 (20) = happyGoto action_161 +action_149 _ = happyReduce_38 + +action_150 (99) = happyShift action_125 +action_150 (101) = happyShift action_151 +action_150 (103) = happyShift action_152 +action_150 (105) = happyShift action_128 +action_150 (109) = happyShift action_57 +action_150 (113) = happyShift action_58 +action_150 (114) = happyShift action_59 +action_150 (115) = happyShift action_60 +action_150 (117) = happyShift action_61 +action_150 (118) = happyShift action_62 +action_150 (26) = happyGoto action_147 +action_150 (27) = happyGoto action_148 +action_150 (31) = happyGoto action_160 +action_150 (32) = happyGoto action_150 +action_150 (33) = happyGoto action_110 +action_150 (34) = happyGoto action_111 +action_150 _ = happyReduce_60 + +action_151 (67) = happyShift action_39 +action_151 (23) = happyGoto action_158 +action_151 (25) = happyGoto action_159 +action_151 _ = happyFail + +action_152 (67) = happyShift action_39 +action_152 (68) = happyShift action_93 +action_152 (69) = happyShift action_119 +action_152 (72) = happyShift action_95 +action_152 (79) = happyShift action_120 +action_152 (81) = happyShift action_121 +action_152 (89) = happyShift action_122 +action_152 (90) = happyShift action_123 +action_152 (91) = happyShift action_96 +action_152 (92) = happyShift action_97 +action_152 (93) = happyShift action_124 +action_152 (94) = happyShift action_99 +action_152 (97) = happyShift action_100 +action_152 (99) = happyShift action_125 +action_152 (101) = happyShift action_126 +action_152 (103) = happyShift action_127 +action_152 (105) = happyShift action_128 +action_152 (109) = happyShift action_57 +action_152 (113) = happyShift action_58 +action_152 (114) = happyShift action_59 +action_152 (115) = happyShift action_60 +action_152 (117) = happyShift action_61 +action_152 (118) = happyShift action_62 +action_152 (120) = happyShift action_129 +action_152 (121) = happyShift action_103 +action_152 (23) = happyGoto action_154 +action_152 (26) = happyGoto action_105 +action_152 (27) = happyGoto action_106 +action_152 (29) = happyGoto action_107 +action_152 (30) = happyGoto action_155 +action_152 (31) = happyGoto action_108 +action_152 (32) = happyGoto action_109 +action_152 (33) = happyGoto action_110 +action_152 (34) = happyGoto action_111 +action_152 (39) = happyGoto action_112 +action_152 (41) = happyGoto action_156 +action_152 (42) = happyGoto action_157 +action_152 (43) = happyGoto action_114 +action_152 (44) = happyGoto action_115 +action_152 (45) = happyGoto action_116 +action_152 (46) = happyGoto action_117 +action_152 (47) = happyGoto action_118 +action_152 (48) = happyGoto action_87 +action_152 _ = happyReduce_60 + +action_153 _ = happyReduce_83 + +action_154 (97) = happyShift action_303 +action_154 (111) = happyShift action_304 +action_154 _ = happyReduce_138 + +action_155 (108) = happyShift action_302 +action_155 _ = happyFail + +action_156 _ = happyReduce_59 + +action_157 (106) = happyShift action_301 +action_157 _ = happyReduce_100 + +action_158 (97) = happyShift action_275 +action_158 (106) = happyShift action_174 +action_158 (111) = happyShift action_276 +action_158 _ = happyReduce_46 + +action_159 (108) = happyShift action_300 +action_159 _ = happyFail + +action_160 _ = happyReduce_61 + +action_161 (112) = happyShift action_299 +action_161 _ = happyFail + +action_162 (67) = happyShift action_39 +action_162 (68) = happyShift action_93 +action_162 (69) = happyShift action_119 +action_162 (72) = happyShift action_95 +action_162 (79) = happyShift action_120 +action_162 (81) = happyShift action_121 +action_162 (89) = happyShift action_122 +action_162 (90) = happyShift action_123 +action_162 (91) = happyShift action_96 +action_162 (92) = happyShift action_97 +action_162 (93) = happyShift action_124 +action_162 (94) = happyShift action_99 +action_162 (97) = happyShift action_100 +action_162 (99) = happyShift action_125 +action_162 (101) = happyShift action_126 +action_162 (103) = happyShift action_127 +action_162 (105) = happyShift action_128 +action_162 (109) = happyShift action_57 +action_162 (113) = happyShift action_58 +action_162 (114) = happyShift action_59 +action_162 (115) = happyShift action_60 +action_162 (117) = happyShift action_61 +action_162 (118) = happyShift action_62 +action_162 (120) = happyShift action_129 +action_162 (121) = happyShift action_103 +action_162 (23) = happyGoto action_104 +action_162 (26) = happyGoto action_105 +action_162 (27) = happyGoto action_106 +action_162 (29) = happyGoto action_107 +action_162 (31) = happyGoto action_108 +action_162 (32) = happyGoto action_109 +action_162 (33) = happyGoto action_110 +action_162 (34) = happyGoto action_111 +action_162 (39) = happyGoto action_112 +action_162 (42) = happyGoto action_298 +action_162 (43) = happyGoto action_114 +action_162 (44) = happyGoto action_115 +action_162 (45) = happyGoto action_116 +action_162 (46) = happyGoto action_117 +action_162 (47) = happyGoto action_118 +action_162 (48) = happyGoto action_87 +action_162 _ = happyReduce_60 + +action_163 _ = happyReduce_62 + +action_164 (67) = happyShift action_39 +action_164 (68) = happyShift action_93 +action_164 (69) = happyShift action_119 +action_164 (72) = happyShift action_95 +action_164 (79) = happyShift action_120 +action_164 (81) = happyShift action_121 +action_164 (89) = happyShift action_122 +action_164 (90) = happyShift action_123 +action_164 (91) = happyShift action_96 +action_164 (92) = happyShift action_97 +action_164 (93) = happyShift action_124 +action_164 (94) = happyShift action_99 +action_164 (97) = happyShift action_100 +action_164 (99) = happyShift action_125 +action_164 (101) = happyShift action_126 +action_164 (103) = happyShift action_127 +action_164 (105) = happyShift action_128 +action_164 (109) = happyShift action_57 +action_164 (113) = happyShift action_58 +action_164 (114) = happyShift action_59 +action_164 (115) = happyShift action_60 +action_164 (117) = happyShift action_61 +action_164 (118) = happyShift action_62 +action_164 (120) = happyShift action_129 +action_164 (121) = happyShift action_103 +action_164 (23) = happyGoto action_296 +action_164 (26) = happyGoto action_105 +action_164 (27) = happyGoto action_106 +action_164 (29) = happyGoto action_107 +action_164 (30) = happyGoto action_297 +action_164 (31) = happyGoto action_108 +action_164 (32) = happyGoto action_109 +action_164 (33) = happyGoto action_110 +action_164 (34) = happyGoto action_111 +action_164 (39) = happyGoto action_112 +action_164 (41) = happyGoto action_156 +action_164 (42) = happyGoto action_157 +action_164 (43) = happyGoto action_114 +action_164 (44) = happyGoto action_115 +action_164 (45) = happyGoto action_116 +action_164 (46) = happyGoto action_117 +action_164 (47) = happyGoto action_118 +action_164 (48) = happyGoto action_87 +action_164 _ = happyReduce_60 + +action_165 _ = happyReduce_82 + +action_166 (108) = happyShift action_295 +action_166 _ = happyFail + +action_167 (99) = happyShift action_294 +action_167 _ = happyFail + +action_168 (99) = happyShift action_125 +action_168 (101) = happyShift action_151 +action_168 (103) = happyShift action_152 +action_168 (105) = happyShift action_128 +action_168 (109) = happyShift action_57 +action_168 (113) = happyShift action_58 +action_168 (114) = happyShift action_59 +action_168 (115) = happyShift action_60 +action_168 (117) = happyShift action_61 +action_168 (118) = happyShift action_62 +action_168 (26) = happyGoto action_147 +action_168 (27) = happyGoto action_148 +action_168 (31) = happyGoto action_293 +action_168 (32) = happyGoto action_150 +action_168 (33) = happyGoto action_110 +action_168 (34) = happyGoto action_111 +action_168 _ = happyReduce_60 + +action_169 _ = happyReduce_148 + +action_170 (100) = happyShift action_291 +action_170 (107) = happyShift action_292 +action_170 _ = happyFail + +action_171 (67) = happyShift action_39 +action_171 (68) = happyShift action_93 +action_171 (69) = happyShift action_119 +action_171 (72) = happyShift action_95 +action_171 (79) = happyShift action_120 +action_171 (81) = happyShift action_121 +action_171 (89) = happyShift action_122 +action_171 (90) = happyShift action_123 +action_171 (91) = happyShift action_96 +action_171 (92) = happyShift action_97 +action_171 (93) = happyShift action_124 +action_171 (94) = happyShift action_99 +action_171 (97) = happyShift action_100 +action_171 (99) = happyShift action_125 +action_171 (101) = happyShift action_126 +action_171 (103) = happyShift action_127 +action_171 (105) = happyShift action_128 +action_171 (109) = happyShift action_57 +action_171 (113) = happyShift action_58 +action_171 (114) = happyShift action_59 +action_171 (115) = happyShift action_60 +action_171 (117) = happyShift action_61 +action_171 (118) = happyShift action_62 +action_171 (120) = happyShift action_129 +action_171 (121) = happyShift action_103 +action_171 (23) = happyGoto action_104 +action_171 (26) = happyGoto action_105 +action_171 (27) = happyGoto action_106 +action_171 (29) = happyGoto action_107 +action_171 (31) = happyGoto action_108 +action_171 (32) = happyGoto action_109 +action_171 (33) = happyGoto action_110 +action_171 (34) = happyGoto action_111 +action_171 (39) = happyGoto action_112 +action_171 (42) = happyGoto action_290 +action_171 (43) = happyGoto action_114 +action_171 (44) = happyGoto action_115 +action_171 (45) = happyGoto action_116 +action_171 (46) = happyGoto action_117 +action_171 (47) = happyGoto action_118 +action_171 (48) = happyGoto action_87 +action_171 _ = happyReduce_60 + +action_172 (108) = happyShift action_289 +action_172 _ = happyFail + +action_173 (67) = happyShift action_39 +action_173 (68) = happyShift action_93 +action_173 (69) = happyShift action_119 +action_173 (72) = happyShift action_95 +action_173 (79) = happyShift action_120 +action_173 (81) = happyShift action_121 +action_173 (89) = happyShift action_122 +action_173 (90) = happyShift action_123 +action_173 (91) = happyShift action_96 +action_173 (92) = happyShift action_97 +action_173 (93) = happyShift action_124 +action_173 (94) = happyShift action_99 +action_173 (97) = happyShift action_100 +action_173 (99) = happyShift action_125 +action_173 (101) = happyShift action_126 +action_173 (103) = happyShift action_127 +action_173 (105) = happyShift action_128 +action_173 (109) = happyShift action_57 +action_173 (113) = happyShift action_58 +action_173 (114) = happyShift action_59 +action_173 (115) = happyShift action_60 +action_173 (117) = happyShift action_61 +action_173 (118) = happyShift action_62 +action_173 (120) = happyShift action_129 +action_173 (121) = happyShift action_103 +action_173 (23) = happyGoto action_104 +action_173 (26) = happyGoto action_105 +action_173 (27) = happyGoto action_106 +action_173 (29) = happyGoto action_107 +action_173 (31) = happyGoto action_108 +action_173 (32) = happyGoto action_109 +action_173 (33) = happyGoto action_110 +action_173 (34) = happyGoto action_111 +action_173 (39) = happyGoto action_112 +action_173 (42) = happyGoto action_288 +action_173 (43) = happyGoto action_114 +action_173 (44) = happyGoto action_115 +action_173 (45) = happyGoto action_116 +action_173 (46) = happyGoto action_117 +action_173 (47) = happyGoto action_118 +action_173 (48) = happyGoto action_87 +action_173 _ = happyReduce_60 + +action_174 (67) = happyShift action_39 +action_174 (23) = happyGoto action_138 +action_174 (25) = happyGoto action_287 +action_174 _ = happyFail + +action_175 (99) = happyShift action_286 +action_175 _ = happyFail + +action_176 (100) = happyShift action_285 +action_176 _ = happyFail + +action_177 _ = happyReduce_31 + +action_178 (67) = happyShift action_39 +action_178 (23) = happyGoto action_130 +action_178 (55) = happyGoto action_284 +action_178 _ = happyReduce_180 + +action_179 _ = happyReduce_32 + +action_180 (112) = happyShift action_283 +action_180 _ = happyReduce_156 + +action_181 (67) = happyShift action_39 +action_181 (93) = happyShift action_235 +action_181 (95) = happyShift action_282 +action_181 (103) = happyShift action_236 +action_181 (109) = happyShift action_102 +action_181 (23) = happyGoto action_233 +action_181 (58) = happyGoto action_281 +action_181 (62) = happyGoto action_231 +action_181 _ = happyReduce_157 + +action_182 (110) = happyShift action_280 +action_182 _ = happyFail + +action_183 _ = happyReduce_54 + +action_184 (105) = happyShift action_278 +action_184 (106) = happyShift action_279 +action_184 _ = happyFail + +action_185 (104) = happyShift action_277 +action_185 _ = happyFail + +action_186 (108) = happyReduce_59 +action_186 _ = happyReduce_99 + +action_187 (97) = happyShift action_275 +action_187 (106) = happyShift action_174 +action_187 (108) = happyReduce_46 +action_187 (111) = happyShift action_276 +action_187 _ = happyReduce_138 + +action_188 (102) = happyShift action_274 +action_188 _ = happyFail + +action_189 (97) = happyShift action_272 +action_189 (106) = happyShift action_174 +action_189 (111) = happyShift action_273 +action_189 _ = happyReduce_46 + +action_190 (108) = happyShift action_271 +action_190 _ = happyFail + +action_191 _ = happyReduce_134 + +action_192 (67) = happyShift action_39 +action_192 (68) = happyShift action_93 +action_192 (69) = happyShift action_119 +action_192 (72) = happyShift action_95 +action_192 (79) = happyShift action_120 +action_192 (81) = happyShift action_121 +action_192 (89) = happyShift action_122 +action_192 (90) = happyShift action_123 +action_192 (91) = happyShift action_96 +action_192 (92) = happyShift action_97 +action_192 (93) = happyShift action_124 +action_192 (94) = happyShift action_99 +action_192 (97) = happyShift action_100 +action_192 (99) = happyShift action_125 +action_192 (101) = happyShift action_126 +action_192 (103) = happyShift action_127 +action_192 (105) = happyShift action_128 +action_192 (109) = happyShift action_57 +action_192 (113) = happyShift action_58 +action_192 (114) = happyShift action_59 +action_192 (115) = happyShift action_60 +action_192 (117) = happyShift action_61 +action_192 (118) = happyShift action_62 +action_192 (120) = happyShift action_129 +action_192 (121) = happyShift action_103 +action_192 (23) = happyGoto action_104 +action_192 (26) = happyGoto action_105 +action_192 (27) = happyGoto action_106 +action_192 (29) = happyGoto action_107 +action_192 (31) = happyGoto action_108 +action_192 (32) = happyGoto action_109 +action_192 (33) = happyGoto action_110 +action_192 (34) = happyGoto action_111 +action_192 (39) = happyGoto action_112 +action_192 (40) = happyGoto action_185 +action_192 (41) = happyGoto action_200 +action_192 (42) = happyGoto action_157 +action_192 (43) = happyGoto action_114 +action_192 (44) = happyGoto action_115 +action_192 (45) = happyGoto action_116 +action_192 (46) = happyGoto action_117 +action_192 (47) = happyGoto action_118 +action_192 (48) = happyGoto action_87 +action_192 _ = happyReduce_60 + +action_193 _ = happyReduce_119 + +action_194 _ = happyReduce_121 + +action_195 _ = happyReduce_84 + +action_196 (67) = happyShift action_39 +action_196 (103) = happyShift action_270 +action_196 (23) = happyGoto action_153 +action_196 _ = happyFail + +action_197 (82) = happyShift action_269 +action_197 _ = happyFail + +action_198 (67) = happyShift action_39 +action_198 (23) = happyGoto action_268 +action_198 _ = happyFail + +action_199 (108) = happyShift action_162 +action_199 (20) = happyGoto action_267 +action_199 _ = happyReduce_38 + +action_200 _ = happyReduce_99 + +action_201 (67) = happyShift action_39 +action_201 (68) = happyShift action_93 +action_201 (69) = happyShift action_119 +action_201 (72) = happyShift action_95 +action_201 (89) = happyShift action_122 +action_201 (90) = happyShift action_123 +action_201 (91) = happyShift action_96 +action_201 (92) = happyShift action_97 +action_201 (93) = happyShift action_124 +action_201 (94) = happyShift action_99 +action_201 (97) = happyShift action_100 +action_201 (103) = happyShift action_192 +action_201 (121) = happyShift action_103 +action_201 (23) = happyGoto action_104 +action_201 (45) = happyGoto action_266 +action_201 (46) = happyGoto action_117 +action_201 (47) = happyGoto action_118 +action_201 (48) = happyGoto action_87 +action_201 _ = happyFail + +action_202 _ = happyReduce_124 + +action_203 _ = happyReduce_126 + +action_204 (67) = happyShift action_39 +action_204 (23) = happyGoto action_265 +action_204 _ = happyFail + +action_205 (67) = happyShift action_39 +action_205 (68) = happyShift action_93 +action_205 (69) = happyShift action_119 +action_205 (72) = happyShift action_95 +action_205 (79) = happyShift action_120 +action_205 (81) = happyShift action_121 +action_205 (89) = happyShift action_122 +action_205 (90) = happyShift action_123 +action_205 (91) = happyShift action_96 +action_205 (92) = happyShift action_97 +action_205 (93) = happyShift action_124 +action_205 (94) = happyShift action_99 +action_205 (97) = happyShift action_100 +action_205 (99) = happyShift action_125 +action_205 (101) = happyShift action_126 +action_205 (103) = happyShift action_127 +action_205 (105) = happyShift action_128 +action_205 (109) = happyShift action_57 +action_205 (113) = happyShift action_58 +action_205 (114) = happyShift action_59 +action_205 (115) = happyShift action_60 +action_205 (117) = happyShift action_61 +action_205 (118) = happyShift action_62 +action_205 (120) = happyShift action_129 +action_205 (121) = happyShift action_103 +action_205 (23) = happyGoto action_104 +action_205 (26) = happyGoto action_105 +action_205 (27) = happyGoto action_106 +action_205 (29) = happyGoto action_107 +action_205 (31) = happyGoto action_108 +action_205 (32) = happyGoto action_109 +action_205 (33) = happyGoto action_110 +action_205 (34) = happyGoto action_111 +action_205 (39) = happyGoto action_112 +action_205 (42) = happyGoto action_264 +action_205 (43) = happyGoto action_114 +action_205 (44) = happyGoto action_115 +action_205 (45) = happyGoto action_116 +action_205 (46) = happyGoto action_117 +action_205 (47) = happyGoto action_118 +action_205 (48) = happyGoto action_87 +action_205 _ = happyReduce_60 + +action_206 (67) = happyShift action_39 +action_206 (68) = happyShift action_93 +action_206 (69) = happyShift action_119 +action_206 (72) = happyShift action_95 +action_206 (79) = happyShift action_120 +action_206 (81) = happyShift action_121 +action_206 (89) = happyShift action_122 +action_206 (90) = happyShift action_123 +action_206 (91) = happyShift action_96 +action_206 (92) = happyShift action_97 +action_206 (93) = happyShift action_124 +action_206 (94) = happyShift action_99 +action_206 (97) = happyShift action_100 +action_206 (99) = happyShift action_125 +action_206 (101) = happyShift action_126 +action_206 (103) = happyShift action_127 +action_206 (105) = happyShift action_128 +action_206 (109) = happyShift action_57 +action_206 (113) = happyShift action_58 +action_206 (114) = happyShift action_59 +action_206 (115) = happyShift action_60 +action_206 (117) = happyShift action_61 +action_206 (118) = happyShift action_62 +action_206 (120) = happyShift action_129 +action_206 (121) = happyShift action_103 +action_206 (23) = happyGoto action_104 +action_206 (26) = happyGoto action_105 +action_206 (27) = happyGoto action_106 +action_206 (29) = happyGoto action_107 +action_206 (31) = happyGoto action_108 +action_206 (32) = happyGoto action_109 +action_206 (33) = happyGoto action_110 +action_206 (34) = happyGoto action_111 +action_206 (39) = happyGoto action_112 +action_206 (42) = happyGoto action_263 +action_206 (43) = happyGoto action_114 +action_206 (44) = happyGoto action_115 +action_206 (45) = happyGoto action_116 +action_206 (46) = happyGoto action_117 +action_206 (47) = happyGoto action_118 +action_206 (48) = happyGoto action_87 +action_206 _ = happyReduce_60 + +action_207 (67) = happyShift action_39 +action_207 (68) = happyShift action_93 +action_207 (69) = happyShift action_119 +action_207 (72) = happyShift action_95 +action_207 (79) = happyShift action_120 +action_207 (81) = happyShift action_121 +action_207 (89) = happyShift action_122 +action_207 (90) = happyShift action_123 +action_207 (91) = happyShift action_96 +action_207 (92) = happyShift action_97 +action_207 (93) = happyShift action_124 +action_207 (94) = happyShift action_99 +action_207 (97) = happyShift action_100 +action_207 (99) = happyShift action_125 +action_207 (101) = happyShift action_126 +action_207 (103) = happyShift action_127 +action_207 (105) = happyShift action_128 +action_207 (109) = happyShift action_57 +action_207 (113) = happyShift action_58 +action_207 (114) = happyShift action_59 +action_207 (115) = happyShift action_60 +action_207 (117) = happyShift action_61 +action_207 (118) = happyShift action_62 +action_207 (120) = happyShift action_129 +action_207 (121) = happyShift action_103 +action_207 (23) = happyGoto action_104 +action_207 (26) = happyGoto action_105 +action_207 (27) = happyGoto action_106 +action_207 (29) = happyGoto action_107 +action_207 (31) = happyGoto action_108 +action_207 (32) = happyGoto action_109 +action_207 (33) = happyGoto action_110 +action_207 (34) = happyGoto action_111 +action_207 (39) = happyGoto action_112 +action_207 (42) = happyGoto action_262 +action_207 (43) = happyGoto action_114 +action_207 (44) = happyGoto action_115 +action_207 (45) = happyGoto action_116 +action_207 (46) = happyGoto action_117 +action_207 (47) = happyGoto action_118 +action_207 (48) = happyGoto action_87 +action_207 _ = happyReduce_60 + +action_208 (67) = happyShift action_39 +action_208 (68) = happyShift action_93 +action_208 (69) = happyShift action_119 +action_208 (72) = happyShift action_95 +action_208 (89) = happyShift action_122 +action_208 (90) = happyShift action_123 +action_208 (91) = happyShift action_96 +action_208 (92) = happyShift action_97 +action_208 (93) = happyShift action_124 +action_208 (94) = happyShift action_99 +action_208 (97) = happyShift action_100 +action_208 (99) = happyShift action_125 +action_208 (101) = happyShift action_218 +action_208 (103) = happyShift action_127 +action_208 (105) = happyShift action_128 +action_208 (109) = happyShift action_57 +action_208 (113) = happyShift action_58 +action_208 (114) = happyShift action_59 +action_208 (115) = happyShift action_60 +action_208 (117) = happyShift action_61 +action_208 (118) = happyShift action_62 +action_208 (121) = happyShift action_103 +action_208 (23) = happyGoto action_104 +action_208 (26) = happyGoto action_212 +action_208 (27) = happyGoto action_213 +action_208 (29) = happyGoto action_214 +action_208 (32) = happyGoto action_215 +action_208 (33) = happyGoto action_110 +action_208 (34) = happyGoto action_111 +action_208 (43) = happyGoto action_260 +action_208 (44) = happyGoto action_115 +action_208 (45) = happyGoto action_261 +action_208 (46) = happyGoto action_117 +action_208 (47) = happyGoto action_118 +action_208 (48) = happyGoto action_87 +action_208 _ = happyFail + +action_209 (67) = happyShift action_39 +action_209 (68) = happyShift action_93 +action_209 (69) = happyShift action_119 +action_209 (72) = happyShift action_95 +action_209 (79) = happyShift action_120 +action_209 (81) = happyShift action_121 +action_209 (89) = happyShift action_122 +action_209 (90) = happyShift action_123 +action_209 (91) = happyShift action_96 +action_209 (92) = happyShift action_97 +action_209 (93) = happyShift action_124 +action_209 (94) = happyShift action_99 +action_209 (97) = happyShift action_100 +action_209 (99) = happyShift action_125 +action_209 (101) = happyShift action_126 +action_209 (103) = happyShift action_127 +action_209 (105) = happyShift action_128 +action_209 (109) = happyShift action_57 +action_209 (113) = happyShift action_58 +action_209 (114) = happyShift action_59 +action_209 (115) = happyShift action_60 +action_209 (117) = happyShift action_61 +action_209 (118) = happyShift action_62 +action_209 (120) = happyShift action_129 +action_209 (121) = happyShift action_103 +action_209 (23) = happyGoto action_104 +action_209 (26) = happyGoto action_105 +action_209 (27) = happyGoto action_106 +action_209 (29) = happyGoto action_107 +action_209 (31) = happyGoto action_108 +action_209 (32) = happyGoto action_109 +action_209 (33) = happyGoto action_110 +action_209 (34) = happyGoto action_111 +action_209 (39) = happyGoto action_112 +action_209 (42) = happyGoto action_259 +action_209 (43) = happyGoto action_114 +action_209 (44) = happyGoto action_115 +action_209 (45) = happyGoto action_116 +action_209 (46) = happyGoto action_117 +action_209 (47) = happyGoto action_118 +action_209 (48) = happyGoto action_87 +action_209 _ = happyReduce_60 + +action_210 (105) = happyShift action_128 +action_210 (27) = happyGoto action_258 +action_210 _ = happyFail + +action_211 (105) = happyShift action_128 +action_211 (27) = happyGoto action_257 +action_211 _ = happyFail + +action_212 (67) = happyShift action_39 +action_212 (68) = happyShift action_93 +action_212 (69) = happyShift action_119 +action_212 (72) = happyShift action_95 +action_212 (89) = happyShift action_122 +action_212 (90) = happyShift action_123 +action_212 (91) = happyShift action_96 +action_212 (92) = happyShift action_97 +action_212 (93) = happyShift action_124 +action_212 (94) = happyShift action_99 +action_212 (97) = happyShift action_100 +action_212 (103) = happyShift action_256 +action_212 (121) = happyShift action_103 +action_212 (23) = happyGoto action_104 +action_212 (45) = happyGoto action_255 +action_212 (46) = happyGoto action_117 +action_212 (47) = happyGoto action_118 +action_212 (48) = happyGoto action_87 +action_212 _ = happyFail + +action_213 (97) = happyShift action_210 +action_213 (111) = happyShift action_211 +action_213 _ = happyReduce_116 + +action_214 _ = happyReduce_117 + +action_215 _ = happyReduce_115 + +action_216 _ = happyReduce_94 + +action_217 (119) = happyReduce_114 +action_217 _ = happyReduce_110 + +action_218 (67) = happyShift action_39 +action_218 (68) = happyShift action_93 +action_218 (69) = happyShift action_119 +action_218 (72) = happyShift action_95 +action_218 (79) = happyShift action_120 +action_218 (81) = happyShift action_121 +action_218 (89) = happyShift action_122 +action_218 (90) = happyShift action_123 +action_218 (91) = happyShift action_96 +action_218 (92) = happyShift action_97 +action_218 (93) = happyShift action_124 +action_218 (94) = happyShift action_99 +action_218 (97) = happyShift action_100 +action_218 (99) = happyShift action_125 +action_218 (101) = happyShift action_126 +action_218 (103) = happyShift action_127 +action_218 (105) = happyShift action_128 +action_218 (109) = happyShift action_57 +action_218 (113) = happyShift action_58 +action_218 (114) = happyShift action_59 +action_218 (115) = happyShift action_60 +action_218 (117) = happyShift action_61 +action_218 (118) = happyShift action_62 +action_218 (120) = happyShift action_129 +action_218 (121) = happyShift action_103 +action_218 (23) = happyGoto action_187 +action_218 (25) = happyGoto action_159 +action_218 (26) = happyGoto action_105 +action_218 (27) = happyGoto action_106 +action_218 (29) = happyGoto action_107 +action_218 (31) = happyGoto action_108 +action_218 (32) = happyGoto action_109 +action_218 (33) = happyGoto action_110 +action_218 (34) = happyGoto action_111 +action_218 (39) = happyGoto action_112 +action_218 (42) = happyGoto action_254 +action_218 (43) = happyGoto action_114 +action_218 (44) = happyGoto action_115 +action_218 (45) = happyGoto action_116 +action_218 (46) = happyGoto action_117 +action_218 (47) = happyGoto action_118 +action_218 (48) = happyGoto action_87 +action_218 _ = happyReduce_60 + +action_219 (67) = happyShift action_39 +action_219 (68) = happyShift action_93 +action_219 (69) = happyShift action_119 +action_219 (72) = happyShift action_95 +action_219 (79) = happyShift action_120 +action_219 (81) = happyShift action_121 +action_219 (89) = happyShift action_122 +action_219 (90) = happyShift action_123 +action_219 (91) = happyShift action_96 +action_219 (92) = happyShift action_97 +action_219 (93) = happyShift action_124 +action_219 (94) = happyShift action_99 +action_219 (97) = happyShift action_100 +action_219 (99) = happyShift action_125 +action_219 (101) = happyShift action_126 +action_219 (103) = happyShift action_127 +action_219 (105) = happyShift action_128 +action_219 (109) = happyShift action_57 +action_219 (113) = happyShift action_58 +action_219 (114) = happyShift action_59 +action_219 (115) = happyShift action_60 +action_219 (117) = happyShift action_61 +action_219 (118) = happyShift action_62 +action_219 (120) = happyShift action_129 +action_219 (121) = happyShift action_103 +action_219 (23) = happyGoto action_252 +action_219 (26) = happyGoto action_105 +action_219 (27) = happyGoto action_106 +action_219 (29) = happyGoto action_107 +action_219 (30) = happyGoto action_253 +action_219 (31) = happyGoto action_108 +action_219 (32) = happyGoto action_109 +action_219 (33) = happyGoto action_110 +action_219 (34) = happyGoto action_111 +action_219 (39) = happyGoto action_112 +action_219 (40) = happyGoto action_185 +action_219 (41) = happyGoto action_186 +action_219 (42) = happyGoto action_157 +action_219 (43) = happyGoto action_114 +action_219 (44) = happyGoto action_115 +action_219 (45) = happyGoto action_116 +action_219 (46) = happyGoto action_117 +action_219 (47) = happyGoto action_118 +action_219 (48) = happyGoto action_87 +action_219 _ = happyReduce_60 + +action_220 (67) = happyReduce_177 +action_220 (70) = happyReduce_177 +action_220 (71) = happyReduce_177 +action_220 (72) = happyReduce_177 +action_220 (73) = happyReduce_177 +action_220 (75) = happyReduce_177 +action_220 (76) = happyReduce_177 +action_220 (77) = happyReduce_177 +action_220 (78) = happyReduce_177 +action_220 (81) = happyReduce_177 +action_220 (83) = happyReduce_177 +action_220 (84) = happyReduce_177 +action_220 (85) = happyReduce_177 +action_220 (86) = happyReduce_177 +action_220 (87) = happyReduce_177 +action_220 (93) = happyReduce_177 +action_220 (95) = happyReduce_177 +action_220 (100) = happyReduce_177 +action_220 (103) = happyReduce_177 +action_220 (104) = happyReduce_177 +action_220 (106) = happyReduce_177 +action_220 (107) = happyReduce_177 +action_220 (109) = happyReduce_177 +action_220 (110) = happyReduce_177 +action_220 (112) = happyReduce_177 +action_220 (122) = happyReduce_177 +action_220 _ = happyReduce_177 + +action_221 _ = happyReduce_166 + +action_222 _ = happyReduce_165 + +action_223 (98) = happyShift action_240 +action_223 _ = happyReduce_123 + +action_224 (104) = happyShift action_251 +action_224 _ = happyFail + +action_225 (67) = happyShift action_39 +action_225 (68) = happyShift action_93 +action_225 (69) = happyShift action_119 +action_225 (72) = happyShift action_95 +action_225 (79) = happyShift action_120 +action_225 (81) = happyShift action_121 +action_225 (89) = happyShift action_122 +action_225 (90) = happyShift action_123 +action_225 (91) = happyShift action_96 +action_225 (92) = happyShift action_97 +action_225 (93) = happyShift action_98 +action_225 (94) = happyShift action_99 +action_225 (97) = happyShift action_100 +action_225 (99) = happyShift action_125 +action_225 (101) = happyShift action_126 +action_225 (103) = happyShift action_225 +action_225 (104) = happyShift action_226 +action_225 (105) = happyShift action_128 +action_225 (109) = happyShift action_227 +action_225 (113) = happyShift action_58 +action_225 (114) = happyShift action_59 +action_225 (115) = happyShift action_60 +action_225 (117) = happyShift action_61 +action_225 (118) = happyShift action_62 +action_225 (120) = happyShift action_129 +action_225 (121) = happyShift action_103 +action_225 (23) = happyGoto action_250 +action_225 (26) = happyGoto action_105 +action_225 (27) = happyGoto action_106 +action_225 (29) = happyGoto action_107 +action_225 (30) = happyGoto action_155 +action_225 (31) = happyGoto action_108 +action_225 (32) = happyGoto action_109 +action_225 (33) = happyGoto action_110 +action_225 (34) = happyGoto action_111 +action_225 (39) = happyGoto action_112 +action_225 (40) = happyGoto action_185 +action_225 (41) = happyGoto action_186 +action_225 (42) = happyGoto action_157 +action_225 (43) = happyGoto action_114 +action_225 (44) = happyGoto action_115 +action_225 (45) = happyGoto action_116 +action_225 (46) = happyGoto action_117 +action_225 (47) = happyGoto action_223 +action_225 (48) = happyGoto action_87 +action_225 (58) = happyGoto action_88 +action_225 (59) = happyGoto action_224 +action_225 (60) = happyGoto action_90 +action_225 (61) = happyGoto action_91 +action_225 (62) = happyGoto action_92 +action_225 _ = happyReduce_60 + +action_226 _ = happyReduce_161 + +action_227 (67) = happyShift action_39 +action_227 (68) = happyShift action_93 +action_227 (69) = happyShift action_94 +action_227 (72) = happyShift action_95 +action_227 (89) = happyShift action_222 +action_227 (91) = happyShift action_96 +action_227 (92) = happyShift action_97 +action_227 (93) = happyShift action_124 +action_227 (94) = happyShift action_99 +action_227 (97) = happyShift action_100 +action_227 (103) = happyShift action_192 +action_227 (121) = happyShift action_103 +action_227 (23) = happyGoto action_220 +action_227 (47) = happyGoto action_221 +action_227 (48) = happyGoto action_87 +action_227 _ = happyReduce_51 + +action_228 (108) = happyShift action_249 +action_228 _ = happyFail + +action_229 (67) = happyReduce_176 +action_229 (70) = happyReduce_176 +action_229 (71) = happyReduce_176 +action_229 (72) = happyReduce_176 +action_229 (73) = happyReduce_176 +action_229 (75) = happyReduce_176 +action_229 (76) = happyReduce_176 +action_229 (77) = happyReduce_176 +action_229 (78) = happyReduce_176 +action_229 (81) = happyReduce_176 +action_229 (83) = happyReduce_176 +action_229 (84) = happyReduce_176 +action_229 (85) = happyReduce_176 +action_229 (86) = happyReduce_176 +action_229 (87) = happyReduce_176 +action_229 (93) = happyReduce_176 +action_229 (95) = happyReduce_176 +action_229 (100) = happyReduce_176 +action_229 (103) = happyReduce_176 +action_229 (104) = happyReduce_176 +action_229 (106) = happyReduce_176 +action_229 (107) = happyReduce_176 +action_229 (109) = happyReduce_176 +action_229 (112) = happyReduce_176 +action_229 (122) = happyReduce_176 +action_229 _ = happyReduce_138 + +action_230 _ = happyReduce_164 + +action_231 _ = happyReduce_163 + +action_232 (67) = happyShift action_39 +action_232 (23) = happyGoto action_37 +action_232 (24) = happyGoto action_246 +action_232 (49) = happyGoto action_247 +action_232 (50) = happyGoto action_248 +action_232 _ = happyReduce_141 + +action_233 _ = happyReduce_176 + +action_234 _ = happyReduce_174 + +action_235 (67) = happyShift action_39 +action_235 (93) = happyShift action_235 +action_235 (103) = happyShift action_236 +action_235 (109) = happyShift action_102 +action_235 (23) = happyGoto action_233 +action_235 (58) = happyGoto action_230 +action_235 (62) = happyGoto action_231 +action_235 _ = happyFail + +action_236 (67) = happyShift action_39 +action_236 (68) = happyShift action_93 +action_236 (69) = happyShift action_94 +action_236 (72) = happyShift action_95 +action_236 (91) = happyShift action_96 +action_236 (92) = happyShift action_97 +action_236 (93) = happyShift action_98 +action_236 (94) = happyShift action_99 +action_236 (97) = happyShift action_100 +action_236 (103) = happyShift action_101 +action_236 (104) = happyShift action_226 +action_236 (109) = happyShift action_102 +action_236 (121) = happyShift action_103 +action_236 (23) = happyGoto action_85 +action_236 (47) = happyGoto action_86 +action_236 (48) = happyGoto action_87 +action_236 (58) = happyGoto action_88 +action_236 (59) = happyGoto action_224 +action_236 (60) = happyGoto action_90 +action_236 (61) = happyGoto action_91 +action_236 (62) = happyGoto action_92 +action_236 _ = happyFail + +action_237 _ = happyReduce_175 + +action_238 (67) = happyShift action_39 +action_238 (68) = happyShift action_93 +action_238 (69) = happyShift action_94 +action_238 (72) = happyShift action_95 +action_238 (91) = happyShift action_96 +action_238 (92) = happyShift action_97 +action_238 (93) = happyShift action_98 +action_238 (94) = happyShift action_99 +action_238 (97) = happyShift action_100 +action_238 (103) = happyShift action_101 +action_238 (109) = happyShift action_102 +action_238 (121) = happyShift action_103 +action_238 (23) = happyGoto action_85 +action_238 (47) = happyGoto action_86 +action_238 (48) = happyGoto action_87 +action_238 (58) = happyGoto action_88 +action_238 (60) = happyGoto action_245 +action_238 (61) = happyGoto action_91 +action_238 (62) = happyGoto action_92 +action_238 _ = happyFail + +action_239 (67) = happyShift action_39 +action_239 (68) = happyShift action_93 +action_239 (69) = happyShift action_94 +action_239 (72) = happyShift action_95 +action_239 (91) = happyShift action_96 +action_239 (92) = happyShift action_97 +action_239 (93) = happyShift action_98 +action_239 (94) = happyShift action_99 +action_239 (97) = happyShift action_100 +action_239 (103) = happyShift action_101 +action_239 (109) = happyShift action_102 +action_239 (121) = happyShift action_103 +action_239 (23) = happyGoto action_85 +action_239 (47) = happyGoto action_86 +action_239 (48) = happyGoto action_87 +action_239 (58) = happyGoto action_88 +action_239 (59) = happyGoto action_244 +action_239 (60) = happyGoto action_90 +action_239 (61) = happyGoto action_91 +action_239 (62) = happyGoto action_92 +action_239 _ = happyFail + +action_240 (67) = happyShift action_39 +action_240 (23) = happyGoto action_243 +action_240 _ = happyFail + +action_241 (67) = happyShift action_39 +action_241 (68) = happyShift action_93 +action_241 (69) = happyShift action_94 +action_241 (72) = happyShift action_95 +action_241 (91) = happyShift action_96 +action_241 (92) = happyShift action_97 +action_241 (93) = happyShift action_124 +action_241 (94) = happyShift action_99 +action_241 (97) = happyShift action_100 +action_241 (103) = happyShift action_192 +action_241 (121) = happyShift action_103 +action_241 (23) = happyGoto action_104 +action_241 (47) = happyGoto action_242 +action_241 (48) = happyGoto action_87 +action_241 _ = happyFail + +action_242 _ = happyReduce_171 + +action_243 _ = happyReduce_170 + +action_244 _ = happyReduce_167 + +action_245 _ = happyReduce_173 + +action_246 (112) = happyShift action_346 +action_246 _ = happyFail + +action_247 (100) = happyShift action_345 +action_247 _ = happyFail + +action_248 (107) = happyShift action_344 +action_248 _ = happyReduce_140 + +action_249 (67) = happyShift action_39 +action_249 (68) = happyShift action_93 +action_249 (69) = happyShift action_119 +action_249 (72) = happyShift action_95 +action_249 (79) = happyShift action_120 +action_249 (81) = happyShift action_121 +action_249 (89) = happyShift action_122 +action_249 (90) = happyShift action_123 +action_249 (91) = happyShift action_96 +action_249 (92) = happyShift action_97 +action_249 (93) = happyShift action_124 +action_249 (94) = happyShift action_99 +action_249 (97) = happyShift action_100 +action_249 (99) = happyShift action_125 +action_249 (101) = happyShift action_126 +action_249 (103) = happyShift action_127 +action_249 (105) = happyShift action_128 +action_249 (109) = happyShift action_57 +action_249 (113) = happyShift action_58 +action_249 (114) = happyShift action_59 +action_249 (115) = happyShift action_60 +action_249 (117) = happyShift action_61 +action_249 (118) = happyShift action_62 +action_249 (120) = happyShift action_129 +action_249 (121) = happyShift action_103 +action_249 (23) = happyGoto action_104 +action_249 (26) = happyGoto action_105 +action_249 (27) = happyGoto action_106 +action_249 (29) = happyGoto action_107 +action_249 (31) = happyGoto action_108 +action_249 (32) = happyGoto action_109 +action_249 (33) = happyGoto action_110 +action_249 (34) = happyGoto action_111 +action_249 (39) = happyGoto action_112 +action_249 (42) = happyGoto action_343 +action_249 (43) = happyGoto action_114 +action_249 (44) = happyGoto action_115 +action_249 (45) = happyGoto action_116 +action_249 (46) = happyGoto action_117 +action_249 (47) = happyGoto action_118 +action_249 (48) = happyGoto action_87 +action_249 _ = happyReduce_60 + +action_250 (67) = happyReduce_176 +action_250 (93) = happyReduce_176 +action_250 (97) = happyShift action_342 +action_250 (103) = happyReduce_176 +action_250 (104) = happyReduce_176 +action_250 (106) = happyReduce_176 +action_250 (109) = happyReduce_176 +action_250 (111) = happyShift action_304 +action_250 _ = happyReduce_138 + +action_251 _ = happyReduce_162 + +action_252 (97) = happyShift action_340 +action_252 (111) = happyShift action_341 +action_252 _ = happyReduce_138 + +action_253 (108) = happyShift action_339 +action_253 _ = happyFail + +action_254 (102) = happyShift action_338 +action_254 _ = happyFail + +action_255 _ = happyReduce_114 + +action_256 (67) = happyShift action_39 +action_256 (68) = happyShift action_93 +action_256 (69) = happyShift action_119 +action_256 (72) = happyShift action_95 +action_256 (79) = happyShift action_120 +action_256 (81) = happyShift action_121 +action_256 (89) = happyShift action_122 +action_256 (90) = happyShift action_123 +action_256 (91) = happyShift action_96 +action_256 (92) = happyShift action_97 +action_256 (93) = happyShift action_124 +action_256 (94) = happyShift action_99 +action_256 (97) = happyShift action_100 +action_256 (99) = happyShift action_125 +action_256 (101) = happyShift action_126 +action_256 (103) = happyShift action_127 +action_256 (105) = happyShift action_128 +action_256 (109) = happyShift action_57 +action_256 (113) = happyShift action_58 +action_256 (114) = happyShift action_59 +action_256 (115) = happyShift action_60 +action_256 (117) = happyShift action_61 +action_256 (118) = happyShift action_62 +action_256 (120) = happyShift action_129 +action_256 (121) = happyShift action_103 +action_256 (23) = happyGoto action_296 +action_256 (26) = happyGoto action_105 +action_256 (27) = happyGoto action_106 +action_256 (29) = happyGoto action_107 +action_256 (30) = happyGoto action_297 +action_256 (31) = happyGoto action_108 +action_256 (32) = happyGoto action_109 +action_256 (33) = happyGoto action_110 +action_256 (34) = happyGoto action_111 +action_256 (39) = happyGoto action_112 +action_256 (40) = happyGoto action_185 +action_256 (41) = happyGoto action_186 +action_256 (42) = happyGoto action_157 +action_256 (43) = happyGoto action_114 +action_256 (44) = happyGoto action_115 +action_256 (45) = happyGoto action_116 +action_256 (46) = happyGoto action_117 +action_256 (47) = happyGoto action_118 +action_256 (48) = happyGoto action_87 +action_256 _ = happyReduce_60 + +action_257 _ = happyReduce_58 + +action_258 _ = happyReduce_57 + +action_259 _ = happyReduce_102 + +action_260 _ = happyReduce_111 + +action_261 (119) = happyReduce_112 +action_261 _ = happyReduce_110 + +action_262 _ = happyReduce_107 + +action_263 _ = happyReduce_109 + +action_264 _ = happyReduce_108 + +action_265 _ = happyReduce_125 + +action_266 _ = happyReduce_122 + +action_267 (99) = happyShift action_337 +action_267 _ = happyFail + +action_268 (102) = happyShift action_165 +action_268 (108) = happyShift action_336 +action_268 _ = happyFail + +action_269 (67) = happyShift action_39 +action_269 (68) = happyShift action_93 +action_269 (69) = happyShift action_119 +action_269 (72) = happyShift action_95 +action_269 (79) = happyShift action_120 +action_269 (81) = happyShift action_121 +action_269 (89) = happyShift action_122 +action_269 (90) = happyShift action_123 +action_269 (91) = happyShift action_96 +action_269 (92) = happyShift action_97 +action_269 (93) = happyShift action_124 +action_269 (94) = happyShift action_99 +action_269 (97) = happyShift action_100 +action_269 (99) = happyShift action_125 +action_269 (101) = happyShift action_126 +action_269 (103) = happyShift action_127 +action_269 (105) = happyShift action_128 +action_269 (109) = happyShift action_57 +action_269 (113) = happyShift action_58 +action_269 (114) = happyShift action_59 +action_269 (115) = happyShift action_60 +action_269 (117) = happyShift action_61 +action_269 (118) = happyShift action_62 +action_269 (120) = happyShift action_129 +action_269 (121) = happyShift action_103 +action_269 (23) = happyGoto action_104 +action_269 (26) = happyGoto action_105 +action_269 (27) = happyGoto action_106 +action_269 (29) = happyGoto action_107 +action_269 (31) = happyGoto action_108 +action_269 (32) = happyGoto action_109 +action_269 (33) = happyGoto action_110 +action_269 (34) = happyGoto action_111 +action_269 (39) = happyGoto action_112 +action_269 (40) = happyGoto action_335 +action_269 (41) = happyGoto action_200 +action_269 (42) = happyGoto action_157 +action_269 (43) = happyGoto action_114 +action_269 (44) = happyGoto action_115 +action_269 (45) = happyGoto action_116 +action_269 (46) = happyGoto action_117 +action_269 (47) = happyGoto action_118 +action_269 (48) = happyGoto action_87 +action_269 _ = happyReduce_60 + +action_270 (67) = happyShift action_39 +action_270 (23) = happyGoto action_334 +action_270 _ = happyFail + +action_271 (67) = happyShift action_39 +action_271 (68) = happyShift action_93 +action_271 (69) = happyShift action_119 +action_271 (72) = happyShift action_95 +action_271 (79) = happyShift action_120 +action_271 (81) = happyShift action_121 +action_271 (89) = happyShift action_122 +action_271 (90) = happyShift action_123 +action_271 (91) = happyShift action_96 +action_271 (92) = happyShift action_97 +action_271 (93) = happyShift action_124 +action_271 (94) = happyShift action_99 +action_271 (97) = happyShift action_100 +action_271 (99) = happyShift action_125 +action_271 (101) = happyShift action_126 +action_271 (103) = happyShift action_127 +action_271 (105) = happyShift action_128 +action_271 (109) = happyShift action_57 +action_271 (113) = happyShift action_58 +action_271 (114) = happyShift action_59 +action_271 (115) = happyShift action_60 +action_271 (117) = happyShift action_61 +action_271 (118) = happyShift action_62 +action_271 (120) = happyShift action_129 +action_271 (121) = happyShift action_103 +action_271 (23) = happyGoto action_104 +action_271 (26) = happyGoto action_105 +action_271 (27) = happyGoto action_106 +action_271 (29) = happyGoto action_107 +action_271 (31) = happyGoto action_108 +action_271 (32) = happyGoto action_109 +action_271 (33) = happyGoto action_110 +action_271 (34) = happyGoto action_111 +action_271 (39) = happyGoto action_112 +action_271 (42) = happyGoto action_333 +action_271 (43) = happyGoto action_114 +action_271 (44) = happyGoto action_115 +action_271 (45) = happyGoto action_116 +action_271 (46) = happyGoto action_117 +action_271 (47) = happyGoto action_118 +action_271 (48) = happyGoto action_87 +action_271 _ = happyReduce_60 + +action_272 (67) = happyShift action_39 +action_272 (68) = happyShift action_93 +action_272 (69) = happyShift action_119 +action_272 (72) = happyShift action_95 +action_272 (79) = happyShift action_120 +action_272 (81) = happyShift action_121 +action_272 (89) = happyShift action_122 +action_272 (90) = happyShift action_123 +action_272 (91) = happyShift action_96 +action_272 (92) = happyShift action_97 +action_272 (93) = happyShift action_124 +action_272 (94) = happyShift action_99 +action_272 (97) = happyShift action_100 +action_272 (99) = happyShift action_125 +action_272 (101) = happyShift action_126 +action_272 (103) = happyShift action_127 +action_272 (105) = happyShift action_128 +action_272 (109) = happyShift action_57 +action_272 (113) = happyShift action_58 +action_272 (114) = happyShift action_59 +action_272 (115) = happyShift action_60 +action_272 (117) = happyShift action_61 +action_272 (118) = happyShift action_62 +action_272 (120) = happyShift action_129 +action_272 (121) = happyShift action_103 +action_272 (23) = happyGoto action_104 +action_272 (26) = happyGoto action_105 +action_272 (27) = happyGoto action_106 +action_272 (29) = happyGoto action_107 +action_272 (31) = happyGoto action_108 +action_272 (32) = happyGoto action_109 +action_272 (33) = happyGoto action_110 +action_272 (34) = happyGoto action_111 +action_272 (39) = happyGoto action_112 +action_272 (42) = happyGoto action_332 +action_272 (43) = happyGoto action_114 +action_272 (44) = happyGoto action_115 +action_272 (45) = happyGoto action_116 +action_272 (46) = happyGoto action_117 +action_272 (47) = happyGoto action_118 +action_272 (48) = happyGoto action_87 +action_272 _ = happyReduce_60 + +action_273 (67) = happyShift action_39 +action_273 (68) = happyShift action_93 +action_273 (69) = happyShift action_119 +action_273 (72) = happyShift action_95 +action_273 (79) = happyShift action_120 +action_273 (81) = happyShift action_121 +action_273 (89) = happyShift action_122 +action_273 (90) = happyShift action_123 +action_273 (91) = happyShift action_96 +action_273 (92) = happyShift action_97 +action_273 (93) = happyShift action_124 +action_273 (94) = happyShift action_99 +action_273 (97) = happyShift action_100 +action_273 (99) = happyShift action_125 +action_273 (101) = happyShift action_126 +action_273 (103) = happyShift action_127 +action_273 (105) = happyShift action_128 +action_273 (109) = happyShift action_57 +action_273 (113) = happyShift action_58 +action_273 (114) = happyShift action_59 +action_273 (115) = happyShift action_60 +action_273 (117) = happyShift action_61 +action_273 (118) = happyShift action_62 +action_273 (120) = happyShift action_129 +action_273 (121) = happyShift action_103 +action_273 (23) = happyGoto action_104 +action_273 (26) = happyGoto action_105 +action_273 (27) = happyGoto action_106 +action_273 (29) = happyGoto action_107 +action_273 (31) = happyGoto action_108 +action_273 (32) = happyGoto action_109 +action_273 (33) = happyGoto action_110 +action_273 (34) = happyGoto action_111 +action_273 (39) = happyGoto action_112 +action_273 (42) = happyGoto action_331 +action_273 (43) = happyGoto action_114 +action_273 (44) = happyGoto action_115 +action_273 (45) = happyGoto action_116 +action_273 (46) = happyGoto action_117 +action_273 (47) = happyGoto action_118 +action_273 (48) = happyGoto action_87 +action_273 _ = happyReduce_60 + +action_274 (119) = happyReduce_113 +action_274 _ = happyReduce_93 + +action_275 (67) = happyShift action_39 +action_275 (68) = happyShift action_93 +action_275 (69) = happyShift action_119 +action_275 (72) = happyShift action_95 +action_275 (79) = happyShift action_120 +action_275 (81) = happyShift action_121 +action_275 (89) = happyShift action_122 +action_275 (90) = happyShift action_123 +action_275 (91) = happyShift action_96 +action_275 (92) = happyShift action_97 +action_275 (93) = happyShift action_124 +action_275 (94) = happyShift action_99 +action_275 (97) = happyShift action_100 +action_275 (99) = happyShift action_125 +action_275 (101) = happyShift action_126 +action_275 (103) = happyShift action_127 +action_275 (105) = happyShift action_128 +action_275 (109) = happyShift action_57 +action_275 (113) = happyShift action_58 +action_275 (114) = happyShift action_59 +action_275 (115) = happyShift action_60 +action_275 (117) = happyShift action_61 +action_275 (118) = happyShift action_62 +action_275 (120) = happyShift action_129 +action_275 (121) = happyShift action_103 +action_275 (23) = happyGoto action_104 +action_275 (26) = happyGoto action_105 +action_275 (27) = happyGoto action_106 +action_275 (29) = happyGoto action_107 +action_275 (31) = happyGoto action_108 +action_275 (32) = happyGoto action_109 +action_275 (33) = happyGoto action_110 +action_275 (34) = happyGoto action_111 +action_275 (39) = happyGoto action_112 +action_275 (42) = happyGoto action_330 +action_275 (43) = happyGoto action_114 +action_275 (44) = happyGoto action_115 +action_275 (45) = happyGoto action_116 +action_275 (46) = happyGoto action_117 +action_275 (47) = happyGoto action_118 +action_275 (48) = happyGoto action_87 +action_275 _ = happyReduce_60 + +action_276 (67) = happyShift action_39 +action_276 (68) = happyShift action_93 +action_276 (69) = happyShift action_119 +action_276 (72) = happyShift action_95 +action_276 (79) = happyShift action_120 +action_276 (81) = happyShift action_121 +action_276 (89) = happyShift action_122 +action_276 (90) = happyShift action_123 +action_276 (91) = happyShift action_96 +action_276 (92) = happyShift action_97 +action_276 (93) = happyShift action_124 +action_276 (94) = happyShift action_99 +action_276 (97) = happyShift action_100 +action_276 (99) = happyShift action_125 +action_276 (101) = happyShift action_126 +action_276 (103) = happyShift action_127 +action_276 (105) = happyShift action_128 +action_276 (109) = happyShift action_57 +action_276 (113) = happyShift action_58 +action_276 (114) = happyShift action_59 +action_276 (115) = happyShift action_60 +action_276 (117) = happyShift action_61 +action_276 (118) = happyShift action_62 +action_276 (120) = happyShift action_129 +action_276 (121) = happyShift action_103 +action_276 (23) = happyGoto action_104 +action_276 (26) = happyGoto action_105 +action_276 (27) = happyGoto action_106 +action_276 (29) = happyGoto action_107 +action_276 (31) = happyGoto action_108 +action_276 (32) = happyGoto action_109 +action_276 (33) = happyGoto action_110 +action_276 (34) = happyGoto action_111 +action_276 (39) = happyGoto action_112 +action_276 (42) = happyGoto action_329 +action_276 (43) = happyGoto action_114 +action_276 (44) = happyGoto action_115 +action_276 (45) = happyGoto action_116 +action_276 (46) = happyGoto action_117 +action_276 (47) = happyGoto action_118 +action_276 (48) = happyGoto action_87 +action_276 _ = happyReduce_60 + +action_277 _ = happyReduce_132 + +action_278 _ = happyReduce_55 + +action_279 (67) = happyShift action_39 +action_279 (68) = happyShift action_93 +action_279 (69) = happyShift action_119 +action_279 (72) = happyShift action_95 +action_279 (79) = happyShift action_120 +action_279 (81) = happyShift action_121 +action_279 (89) = happyShift action_122 +action_279 (90) = happyShift action_123 +action_279 (91) = happyShift action_96 +action_279 (92) = happyShift action_97 +action_279 (93) = happyShift action_124 +action_279 (94) = happyShift action_99 +action_279 (97) = happyShift action_100 +action_279 (99) = happyShift action_125 +action_279 (101) = happyShift action_126 +action_279 (103) = happyShift action_127 +action_279 (105) = happyShift action_128 +action_279 (109) = happyShift action_57 +action_279 (113) = happyShift action_58 +action_279 (114) = happyShift action_59 +action_279 (115) = happyShift action_60 +action_279 (117) = happyShift action_61 +action_279 (118) = happyShift action_62 +action_279 (120) = happyShift action_129 +action_279 (121) = happyShift action_103 +action_279 (23) = happyGoto action_104 +action_279 (26) = happyGoto action_105 +action_279 (27) = happyGoto action_106 +action_279 (28) = happyGoto action_328 +action_279 (29) = happyGoto action_107 +action_279 (31) = happyGoto action_108 +action_279 (32) = happyGoto action_109 +action_279 (33) = happyGoto action_110 +action_279 (34) = happyGoto action_111 +action_279 (39) = happyGoto action_112 +action_279 (42) = happyGoto action_184 +action_279 (43) = happyGoto action_114 +action_279 (44) = happyGoto action_115 +action_279 (45) = happyGoto action_116 +action_279 (46) = happyGoto action_117 +action_279 (47) = happyGoto action_118 +action_279 (48) = happyGoto action_87 +action_279 _ = happyReduce_60 + +action_280 (67) = happyShift action_39 +action_280 (68) = happyShift action_93 +action_280 (69) = happyShift action_119 +action_280 (72) = happyShift action_95 +action_280 (79) = happyShift action_120 +action_280 (81) = happyShift action_121 +action_280 (89) = happyShift action_122 +action_280 (90) = happyShift action_123 +action_280 (91) = happyShift action_96 +action_280 (92) = happyShift action_97 +action_280 (93) = happyShift action_124 +action_280 (94) = happyShift action_99 +action_280 (97) = happyShift action_100 +action_280 (99) = happyShift action_125 +action_280 (101) = happyShift action_126 +action_280 (103) = happyShift action_127 +action_280 (105) = happyShift action_128 +action_280 (109) = happyShift action_57 +action_280 (113) = happyShift action_58 +action_280 (114) = happyShift action_59 +action_280 (115) = happyShift action_60 +action_280 (117) = happyShift action_61 +action_280 (118) = happyShift action_62 +action_280 (120) = happyShift action_129 +action_280 (121) = happyShift action_103 +action_280 (23) = happyGoto action_104 +action_280 (26) = happyGoto action_105 +action_280 (27) = happyGoto action_106 +action_280 (29) = happyGoto action_107 +action_280 (31) = happyGoto action_108 +action_280 (32) = happyGoto action_109 +action_280 (33) = happyGoto action_110 +action_280 (34) = happyGoto action_111 +action_280 (39) = happyGoto action_112 +action_280 (40) = happyGoto action_327 +action_280 (41) = happyGoto action_200 +action_280 (42) = happyGoto action_157 +action_280 (43) = happyGoto action_114 +action_280 (44) = happyGoto action_115 +action_280 (45) = happyGoto action_116 +action_280 (46) = happyGoto action_117 +action_280 (47) = happyGoto action_118 +action_280 (48) = happyGoto action_87 +action_280 _ = happyReduce_60 + +action_281 _ = happyReduce_159 + +action_282 (67) = happyShift action_39 +action_282 (68) = happyShift action_93 +action_282 (69) = happyShift action_94 +action_282 (72) = happyShift action_95 +action_282 (91) = happyShift action_96 +action_282 (92) = happyShift action_97 +action_282 (93) = happyShift action_98 +action_282 (94) = happyShift action_99 +action_282 (97) = happyShift action_100 +action_282 (103) = happyShift action_101 +action_282 (109) = happyShift action_102 +action_282 (121) = happyShift action_103 +action_282 (23) = happyGoto action_85 +action_282 (47) = happyGoto action_86 +action_282 (48) = happyGoto action_87 +action_282 (58) = happyGoto action_88 +action_282 (60) = happyGoto action_326 +action_282 (61) = happyGoto action_91 +action_282 (62) = happyGoto action_92 +action_282 _ = happyFail + +action_283 (67) = happyShift action_39 +action_283 (68) = happyShift action_93 +action_283 (69) = happyShift action_119 +action_283 (72) = happyShift action_95 +action_283 (79) = happyShift action_120 +action_283 (81) = happyShift action_121 +action_283 (89) = happyShift action_122 +action_283 (90) = happyShift action_123 +action_283 (91) = happyShift action_96 +action_283 (92) = happyShift action_97 +action_283 (93) = happyShift action_124 +action_283 (94) = happyShift action_99 +action_283 (97) = happyShift action_100 +action_283 (99) = happyShift action_125 +action_283 (101) = happyShift action_126 +action_283 (103) = happyShift action_127 +action_283 (105) = happyShift action_128 +action_283 (109) = happyShift action_57 +action_283 (113) = happyShift action_58 +action_283 (114) = happyShift action_59 +action_283 (115) = happyShift action_60 +action_283 (117) = happyShift action_61 +action_283 (118) = happyShift action_62 +action_283 (120) = happyShift action_129 +action_283 (121) = happyShift action_103 +action_283 (23) = happyGoto action_104 +action_283 (26) = happyGoto action_105 +action_283 (27) = happyGoto action_106 +action_283 (29) = happyGoto action_107 +action_283 (31) = happyGoto action_108 +action_283 (32) = happyGoto action_109 +action_283 (33) = happyGoto action_110 +action_283 (34) = happyGoto action_111 +action_283 (39) = happyGoto action_112 +action_283 (40) = happyGoto action_325 +action_283 (41) = happyGoto action_200 +action_283 (42) = happyGoto action_157 +action_283 (43) = happyGoto action_114 +action_283 (44) = happyGoto action_115 +action_283 (45) = happyGoto action_116 +action_283 (46) = happyGoto action_117 +action_283 (47) = happyGoto action_118 +action_283 (48) = happyGoto action_87 +action_283 _ = happyReduce_60 + +action_284 _ = happyReduce_179 + +action_285 (74) = happyShift action_319 +action_285 (22) = happyGoto action_324 +action_285 _ = happyReduce_41 + +action_286 (67) = happyShift action_39 +action_286 (23) = happyGoto action_168 +action_286 (52) = happyGoto action_323 +action_286 _ = happyFail + +action_287 _ = happyReduce_47 + +action_288 (104) = happyShift action_322 +action_288 _ = happyFail + +action_289 (67) = happyShift action_39 +action_289 (68) = happyShift action_93 +action_289 (69) = happyShift action_119 +action_289 (72) = happyShift action_95 +action_289 (79) = happyShift action_120 +action_289 (81) = happyShift action_121 +action_289 (89) = happyShift action_122 +action_289 (90) = happyShift action_123 +action_289 (91) = happyShift action_96 +action_289 (92) = happyShift action_97 +action_289 (93) = happyShift action_124 +action_289 (94) = happyShift action_99 +action_289 (97) = happyShift action_100 +action_289 (99) = happyShift action_125 +action_289 (101) = happyShift action_126 +action_289 (103) = happyShift action_127 +action_289 (105) = happyShift action_128 +action_289 (109) = happyShift action_57 +action_289 (113) = happyShift action_58 +action_289 (114) = happyShift action_59 +action_289 (115) = happyShift action_60 +action_289 (117) = happyShift action_61 +action_289 (118) = happyShift action_62 +action_289 (120) = happyShift action_129 +action_289 (121) = happyShift action_103 +action_289 (23) = happyGoto action_104 +action_289 (26) = happyGoto action_105 +action_289 (27) = happyGoto action_106 +action_289 (29) = happyGoto action_107 +action_289 (31) = happyGoto action_108 +action_289 (32) = happyGoto action_109 +action_289 (33) = happyGoto action_110 +action_289 (34) = happyGoto action_111 +action_289 (39) = happyGoto action_112 +action_289 (42) = happyGoto action_321 +action_289 (43) = happyGoto action_114 +action_289 (44) = happyGoto action_115 +action_289 (45) = happyGoto action_116 +action_289 (46) = happyGoto action_117 +action_289 (47) = happyGoto action_118 +action_289 (48) = happyGoto action_87 +action_289 _ = happyReduce_60 + +action_290 (102) = happyShift action_320 +action_290 _ = happyFail + +action_291 (74) = happyShift action_319 +action_291 (22) = happyGoto action_318 +action_291 _ = happyReduce_41 + +action_292 (67) = happyShift action_39 +action_292 (23) = happyGoto action_168 +action_292 (52) = happyGoto action_317 +action_292 _ = happyReduce_147 + +action_293 (108) = happyShift action_316 +action_293 _ = happyReduce_145 + +action_294 (67) = happyShift action_39 +action_294 (23) = happyGoto action_168 +action_294 (52) = happyGoto action_169 +action_294 (53) = happyGoto action_315 +action_294 _ = happyReduce_149 + +action_295 (67) = happyShift action_39 +action_295 (68) = happyShift action_93 +action_295 (69) = happyShift action_119 +action_295 (72) = happyShift action_95 +action_295 (79) = happyShift action_120 +action_295 (81) = happyShift action_121 +action_295 (89) = happyShift action_122 +action_295 (90) = happyShift action_123 +action_295 (91) = happyShift action_96 +action_295 (92) = happyShift action_97 +action_295 (93) = happyShift action_124 +action_295 (94) = happyShift action_99 +action_295 (97) = happyShift action_100 +action_295 (99) = happyShift action_125 +action_295 (101) = happyShift action_126 +action_295 (103) = happyShift action_127 +action_295 (105) = happyShift action_128 +action_295 (109) = happyShift action_57 +action_295 (113) = happyShift action_58 +action_295 (114) = happyShift action_59 +action_295 (115) = happyShift action_60 +action_295 (117) = happyShift action_61 +action_295 (118) = happyShift action_62 +action_295 (120) = happyShift action_129 +action_295 (121) = happyShift action_103 +action_295 (23) = happyGoto action_104 +action_295 (26) = happyGoto action_105 +action_295 (27) = happyGoto action_106 +action_295 (29) = happyGoto action_107 +action_295 (31) = happyGoto action_108 +action_295 (32) = happyGoto action_109 +action_295 (33) = happyGoto action_110 +action_295 (34) = happyGoto action_111 +action_295 (39) = happyGoto action_112 +action_295 (42) = happyGoto action_314 +action_295 (43) = happyGoto action_114 +action_295 (44) = happyGoto action_115 +action_295 (45) = happyGoto action_116 +action_295 (46) = happyGoto action_117 +action_295 (47) = happyGoto action_118 +action_295 (48) = happyGoto action_87 +action_295 _ = happyReduce_60 + +action_296 (97) = happyShift action_312 +action_296 (111) = happyShift action_313 +action_296 _ = happyReduce_138 + +action_297 (108) = happyShift action_311 +action_297 _ = happyFail + +action_298 _ = happyReduce_39 + +action_299 (67) = happyShift action_39 +action_299 (68) = happyShift action_93 +action_299 (69) = happyShift action_119 +action_299 (72) = happyShift action_95 +action_299 (79) = happyShift action_120 +action_299 (81) = happyShift action_121 +action_299 (89) = happyShift action_122 +action_299 (90) = happyShift action_123 +action_299 (91) = happyShift action_96 +action_299 (92) = happyShift action_97 +action_299 (93) = happyShift action_124 +action_299 (94) = happyShift action_99 +action_299 (97) = happyShift action_100 +action_299 (99) = happyShift action_125 +action_299 (101) = happyShift action_126 +action_299 (103) = happyShift action_127 +action_299 (105) = happyShift action_128 +action_299 (109) = happyShift action_57 +action_299 (113) = happyShift action_58 +action_299 (114) = happyShift action_59 +action_299 (115) = happyShift action_60 +action_299 (117) = happyShift action_61 +action_299 (118) = happyShift action_62 +action_299 (120) = happyShift action_129 +action_299 (121) = happyShift action_103 +action_299 (23) = happyGoto action_104 +action_299 (26) = happyGoto action_105 +action_299 (27) = happyGoto action_106 +action_299 (29) = happyGoto action_107 +action_299 (31) = happyGoto action_108 +action_299 (32) = happyGoto action_109 +action_299 (33) = happyGoto action_110 +action_299 (34) = happyGoto action_111 +action_299 (39) = happyGoto action_112 +action_299 (40) = happyGoto action_310 +action_299 (41) = happyGoto action_200 +action_299 (42) = happyGoto action_157 +action_299 (43) = happyGoto action_114 +action_299 (44) = happyGoto action_115 +action_299 (45) = happyGoto action_116 +action_299 (46) = happyGoto action_117 +action_299 (47) = happyGoto action_118 +action_299 (48) = happyGoto action_87 +action_299 _ = happyReduce_60 + +action_300 (67) = happyShift action_39 +action_300 (68) = happyShift action_93 +action_300 (69) = happyShift action_119 +action_300 (72) = happyShift action_95 +action_300 (79) = happyShift action_120 +action_300 (81) = happyShift action_121 +action_300 (89) = happyShift action_122 +action_300 (90) = happyShift action_123 +action_300 (91) = happyShift action_96 +action_300 (92) = happyShift action_97 +action_300 (93) = happyShift action_124 +action_300 (94) = happyShift action_99 +action_300 (97) = happyShift action_100 +action_300 (99) = happyShift action_125 +action_300 (101) = happyShift action_126 +action_300 (103) = happyShift action_127 +action_300 (105) = happyShift action_128 +action_300 (109) = happyShift action_57 +action_300 (113) = happyShift action_58 +action_300 (114) = happyShift action_59 +action_300 (115) = happyShift action_60 +action_300 (117) = happyShift action_61 +action_300 (118) = happyShift action_62 +action_300 (120) = happyShift action_129 +action_300 (121) = happyShift action_103 +action_300 (23) = happyGoto action_104 +action_300 (26) = happyGoto action_105 +action_300 (27) = happyGoto action_106 +action_300 (29) = happyGoto action_107 +action_300 (31) = happyGoto action_108 +action_300 (32) = happyGoto action_109 +action_300 (33) = happyGoto action_110 +action_300 (34) = happyGoto action_111 +action_300 (39) = happyGoto action_112 +action_300 (42) = happyGoto action_309 +action_300 (43) = happyGoto action_114 +action_300 (44) = happyGoto action_115 +action_300 (45) = happyGoto action_116 +action_300 (46) = happyGoto action_117 +action_300 (47) = happyGoto action_118 +action_300 (48) = happyGoto action_87 +action_300 _ = happyReduce_60 + +action_301 (67) = happyShift action_39 +action_301 (68) = happyShift action_93 +action_301 (69) = happyShift action_119 +action_301 (72) = happyShift action_95 +action_301 (79) = happyShift action_120 +action_301 (81) = happyShift action_121 +action_301 (89) = happyShift action_122 +action_301 (90) = happyShift action_123 +action_301 (91) = happyShift action_96 +action_301 (92) = happyShift action_97 +action_301 (93) = happyShift action_124 +action_301 (94) = happyShift action_99 +action_301 (97) = happyShift action_100 +action_301 (99) = happyShift action_125 +action_301 (101) = happyShift action_126 +action_301 (103) = happyShift action_127 +action_301 (105) = happyShift action_128 +action_301 (109) = happyShift action_57 +action_301 (113) = happyShift action_58 +action_301 (114) = happyShift action_59 +action_301 (115) = happyShift action_60 +action_301 (117) = happyShift action_61 +action_301 (118) = happyShift action_62 +action_301 (120) = happyShift action_129 +action_301 (121) = happyShift action_103 +action_301 (23) = happyGoto action_104 +action_301 (26) = happyGoto action_105 +action_301 (27) = happyGoto action_106 +action_301 (29) = happyGoto action_107 +action_301 (31) = happyGoto action_108 +action_301 (32) = happyGoto action_109 +action_301 (33) = happyGoto action_110 +action_301 (34) = happyGoto action_111 +action_301 (39) = happyGoto action_112 +action_301 (41) = happyGoto action_308 +action_301 (42) = happyGoto action_157 +action_301 (43) = happyGoto action_114 +action_301 (44) = happyGoto action_115 +action_301 (45) = happyGoto action_116 +action_301 (46) = happyGoto action_117 +action_301 (47) = happyGoto action_118 +action_301 (48) = happyGoto action_87 +action_301 _ = happyReduce_60 + +action_302 (67) = happyShift action_39 +action_302 (68) = happyShift action_93 +action_302 (69) = happyShift action_119 +action_302 (72) = happyShift action_95 +action_302 (79) = happyShift action_120 +action_302 (81) = happyShift action_121 +action_302 (89) = happyShift action_122 +action_302 (90) = happyShift action_123 +action_302 (91) = happyShift action_96 +action_302 (92) = happyShift action_97 +action_302 (93) = happyShift action_124 +action_302 (94) = happyShift action_99 +action_302 (97) = happyShift action_100 +action_302 (99) = happyShift action_125 +action_302 (101) = happyShift action_126 +action_302 (103) = happyShift action_127 +action_302 (105) = happyShift action_128 +action_302 (109) = happyShift action_57 +action_302 (113) = happyShift action_58 +action_302 (114) = happyShift action_59 +action_302 (115) = happyShift action_60 +action_302 (117) = happyShift action_61 +action_302 (118) = happyShift action_62 +action_302 (120) = happyShift action_129 +action_302 (121) = happyShift action_103 +action_302 (23) = happyGoto action_104 +action_302 (26) = happyGoto action_105 +action_302 (27) = happyGoto action_106 +action_302 (29) = happyGoto action_107 +action_302 (31) = happyGoto action_108 +action_302 (32) = happyGoto action_109 +action_302 (33) = happyGoto action_110 +action_302 (34) = happyGoto action_111 +action_302 (39) = happyGoto action_112 +action_302 (42) = happyGoto action_307 +action_302 (43) = happyGoto action_114 +action_302 (44) = happyGoto action_115 +action_302 (45) = happyGoto action_116 +action_302 (46) = happyGoto action_117 +action_302 (47) = happyGoto action_118 +action_302 (48) = happyGoto action_87 +action_302 _ = happyReduce_60 + +action_303 (67) = happyShift action_39 +action_303 (68) = happyShift action_93 +action_303 (69) = happyShift action_119 +action_303 (72) = happyShift action_95 +action_303 (79) = happyShift action_120 +action_303 (81) = happyShift action_121 +action_303 (89) = happyShift action_122 +action_303 (90) = happyShift action_123 +action_303 (91) = happyShift action_96 +action_303 (92) = happyShift action_97 +action_303 (93) = happyShift action_124 +action_303 (94) = happyShift action_99 +action_303 (97) = happyShift action_100 +action_303 (99) = happyShift action_125 +action_303 (101) = happyShift action_126 +action_303 (103) = happyShift action_127 +action_303 (105) = happyShift action_128 +action_303 (109) = happyShift action_57 +action_303 (113) = happyShift action_58 +action_303 (114) = happyShift action_59 +action_303 (115) = happyShift action_60 +action_303 (117) = happyShift action_61 +action_303 (118) = happyShift action_62 +action_303 (120) = happyShift action_129 +action_303 (121) = happyShift action_103 +action_303 (23) = happyGoto action_104 +action_303 (26) = happyGoto action_105 +action_303 (27) = happyGoto action_106 +action_303 (29) = happyGoto action_107 +action_303 (31) = happyGoto action_108 +action_303 (32) = happyGoto action_109 +action_303 (33) = happyGoto action_110 +action_303 (34) = happyGoto action_111 +action_303 (39) = happyGoto action_112 +action_303 (42) = happyGoto action_306 +action_303 (43) = happyGoto action_114 +action_303 (44) = happyGoto action_115 +action_303 (45) = happyGoto action_116 +action_303 (46) = happyGoto action_117 +action_303 (47) = happyGoto action_118 +action_303 (48) = happyGoto action_87 +action_303 _ = happyReduce_60 + +action_304 (67) = happyShift action_39 +action_304 (68) = happyShift action_93 +action_304 (69) = happyShift action_119 +action_304 (72) = happyShift action_95 +action_304 (79) = happyShift action_120 +action_304 (81) = happyShift action_121 +action_304 (89) = happyShift action_122 +action_304 (90) = happyShift action_123 +action_304 (91) = happyShift action_96 +action_304 (92) = happyShift action_97 +action_304 (93) = happyShift action_124 +action_304 (94) = happyShift action_99 +action_304 (97) = happyShift action_100 +action_304 (99) = happyShift action_125 +action_304 (101) = happyShift action_126 +action_304 (103) = happyShift action_127 +action_304 (105) = happyShift action_128 +action_304 (109) = happyShift action_57 +action_304 (113) = happyShift action_58 +action_304 (114) = happyShift action_59 +action_304 (115) = happyShift action_60 +action_304 (117) = happyShift action_61 +action_304 (118) = happyShift action_62 +action_304 (120) = happyShift action_129 +action_304 (121) = happyShift action_103 +action_304 (23) = happyGoto action_104 +action_304 (26) = happyGoto action_105 +action_304 (27) = happyGoto action_106 +action_304 (29) = happyGoto action_107 +action_304 (31) = happyGoto action_108 +action_304 (32) = happyGoto action_109 +action_304 (33) = happyGoto action_110 +action_304 (34) = happyGoto action_111 +action_304 (39) = happyGoto action_112 +action_304 (42) = happyGoto action_305 +action_304 (43) = happyGoto action_114 +action_304 (44) = happyGoto action_115 +action_304 (45) = happyGoto action_116 +action_304 (46) = happyGoto action_117 +action_304 (47) = happyGoto action_118 +action_304 (48) = happyGoto action_87 +action_304 _ = happyReduce_60 + +action_305 (104) = happyShift action_375 +action_305 _ = happyFail + +action_306 (104) = happyShift action_374 +action_306 _ = happyFail + +action_307 (104) = happyShift action_373 +action_307 _ = happyFail + +action_308 _ = happyReduce_101 + +action_309 (102) = happyShift action_372 +action_309 _ = happyFail + +action_310 _ = happyReduce_35 + +action_311 (67) = happyShift action_39 +action_311 (68) = happyShift action_93 +action_311 (69) = happyShift action_119 +action_311 (72) = happyShift action_95 +action_311 (79) = happyShift action_120 +action_311 (81) = happyShift action_121 +action_311 (89) = happyShift action_122 +action_311 (90) = happyShift action_123 +action_311 (91) = happyShift action_96 +action_311 (92) = happyShift action_97 +action_311 (93) = happyShift action_124 +action_311 (94) = happyShift action_99 +action_311 (97) = happyShift action_100 +action_311 (99) = happyShift action_125 +action_311 (101) = happyShift action_126 +action_311 (103) = happyShift action_127 +action_311 (105) = happyShift action_128 +action_311 (109) = happyShift action_57 +action_311 (113) = happyShift action_58 +action_311 (114) = happyShift action_59 +action_311 (115) = happyShift action_60 +action_311 (117) = happyShift action_61 +action_311 (118) = happyShift action_62 +action_311 (120) = happyShift action_129 +action_311 (121) = happyShift action_103 +action_311 (23) = happyGoto action_104 +action_311 (26) = happyGoto action_105 +action_311 (27) = happyGoto action_106 +action_311 (29) = happyGoto action_107 +action_311 (31) = happyGoto action_108 +action_311 (32) = happyGoto action_109 +action_311 (33) = happyGoto action_110 +action_311 (34) = happyGoto action_111 +action_311 (39) = happyGoto action_112 +action_311 (42) = happyGoto action_371 +action_311 (43) = happyGoto action_114 +action_311 (44) = happyGoto action_115 +action_311 (45) = happyGoto action_116 +action_311 (46) = happyGoto action_117 +action_311 (47) = happyGoto action_118 +action_311 (48) = happyGoto action_87 +action_311 _ = happyReduce_60 + +action_312 (67) = happyShift action_39 +action_312 (68) = happyShift action_93 +action_312 (69) = happyShift action_119 +action_312 (72) = happyShift action_95 +action_312 (79) = happyShift action_120 +action_312 (81) = happyShift action_121 +action_312 (89) = happyShift action_122 +action_312 (90) = happyShift action_123 +action_312 (91) = happyShift action_96 +action_312 (92) = happyShift action_97 +action_312 (93) = happyShift action_124 +action_312 (94) = happyShift action_99 +action_312 (97) = happyShift action_100 +action_312 (99) = happyShift action_125 +action_312 (101) = happyShift action_126 +action_312 (103) = happyShift action_127 +action_312 (105) = happyShift action_128 +action_312 (109) = happyShift action_57 +action_312 (113) = happyShift action_58 +action_312 (114) = happyShift action_59 +action_312 (115) = happyShift action_60 +action_312 (117) = happyShift action_61 +action_312 (118) = happyShift action_62 +action_312 (120) = happyShift action_129 +action_312 (121) = happyShift action_103 +action_312 (23) = happyGoto action_104 +action_312 (26) = happyGoto action_105 +action_312 (27) = happyGoto action_106 +action_312 (29) = happyGoto action_107 +action_312 (31) = happyGoto action_108 +action_312 (32) = happyGoto action_109 +action_312 (33) = happyGoto action_110 +action_312 (34) = happyGoto action_111 +action_312 (39) = happyGoto action_112 +action_312 (42) = happyGoto action_370 +action_312 (43) = happyGoto action_114 +action_312 (44) = happyGoto action_115 +action_312 (45) = happyGoto action_116 +action_312 (46) = happyGoto action_117 +action_312 (47) = happyGoto action_118 +action_312 (48) = happyGoto action_87 +action_312 _ = happyReduce_60 + +action_313 (67) = happyShift action_39 +action_313 (68) = happyShift action_93 +action_313 (69) = happyShift action_119 +action_313 (72) = happyShift action_95 +action_313 (79) = happyShift action_120 +action_313 (81) = happyShift action_121 +action_313 (89) = happyShift action_122 +action_313 (90) = happyShift action_123 +action_313 (91) = happyShift action_96 +action_313 (92) = happyShift action_97 +action_313 (93) = happyShift action_124 +action_313 (94) = happyShift action_99 +action_313 (97) = happyShift action_100 +action_313 (99) = happyShift action_125 +action_313 (101) = happyShift action_126 +action_313 (103) = happyShift action_127 +action_313 (105) = happyShift action_128 +action_313 (109) = happyShift action_57 +action_313 (113) = happyShift action_58 +action_313 (114) = happyShift action_59 +action_313 (115) = happyShift action_60 +action_313 (117) = happyShift action_61 +action_313 (118) = happyShift action_62 +action_313 (120) = happyShift action_129 +action_313 (121) = happyShift action_103 +action_313 (23) = happyGoto action_104 +action_313 (26) = happyGoto action_105 +action_313 (27) = happyGoto action_106 +action_313 (29) = happyGoto action_107 +action_313 (31) = happyGoto action_108 +action_313 (32) = happyGoto action_109 +action_313 (33) = happyGoto action_110 +action_313 (34) = happyGoto action_111 +action_313 (39) = happyGoto action_112 +action_313 (42) = happyGoto action_369 +action_313 (43) = happyGoto action_114 +action_313 (44) = happyGoto action_115 +action_313 (45) = happyGoto action_116 +action_313 (46) = happyGoto action_117 +action_313 (47) = happyGoto action_118 +action_313 (48) = happyGoto action_87 +action_313 _ = happyReduce_60 + +action_314 (104) = happyShift action_368 +action_314 _ = happyFail + +action_315 (100) = happyShift action_367 +action_315 (107) = happyShift action_292 +action_315 _ = happyFail + +action_316 (67) = happyShift action_39 +action_316 (68) = happyShift action_93 +action_316 (69) = happyShift action_119 +action_316 (72) = happyShift action_95 +action_316 (79) = happyShift action_120 +action_316 (81) = happyShift action_121 +action_316 (89) = happyShift action_122 +action_316 (90) = happyShift action_123 +action_316 (91) = happyShift action_96 +action_316 (92) = happyShift action_97 +action_316 (93) = happyShift action_124 +action_316 (94) = happyShift action_99 +action_316 (97) = happyShift action_100 +action_316 (99) = happyShift action_125 +action_316 (101) = happyShift action_126 +action_316 (103) = happyShift action_127 +action_316 (105) = happyShift action_128 +action_316 (109) = happyShift action_57 +action_316 (113) = happyShift action_58 +action_316 (114) = happyShift action_59 +action_316 (115) = happyShift action_60 +action_316 (117) = happyShift action_61 +action_316 (118) = happyShift action_62 +action_316 (120) = happyShift action_129 +action_316 (121) = happyShift action_103 +action_316 (23) = happyGoto action_104 +action_316 (26) = happyGoto action_105 +action_316 (27) = happyGoto action_106 +action_316 (29) = happyGoto action_107 +action_316 (31) = happyGoto action_108 +action_316 (32) = happyGoto action_109 +action_316 (33) = happyGoto action_110 +action_316 (34) = happyGoto action_111 +action_316 (39) = happyGoto action_112 +action_316 (42) = happyGoto action_366 +action_316 (43) = happyGoto action_114 +action_316 (44) = happyGoto action_115 +action_316 (45) = happyGoto action_116 +action_316 (46) = happyGoto action_117 +action_316 (47) = happyGoto action_118 +action_316 (48) = happyGoto action_87 +action_316 _ = happyReduce_60 + +action_317 _ = happyReduce_146 + +action_318 _ = happyReduce_28 + +action_319 (67) = happyShift action_39 +action_319 (23) = happyGoto action_138 +action_319 (25) = happyGoto action_365 +action_319 _ = happyFail + +action_320 _ = happyReduce_184 + +action_321 (104) = happyShift action_364 +action_321 _ = happyFail + +action_322 _ = happyReduce_183 + +action_323 (100) = happyShift action_363 +action_323 _ = happyFail + +action_324 _ = happyReduce_30 + +action_325 _ = happyReduce_155 + +action_326 _ = happyReduce_160 + +action_327 _ = happyReduce_103 + +action_328 _ = happyReduce_56 + +action_329 (102) = happyShift action_362 +action_329 _ = happyFail + +action_330 (102) = happyShift action_361 +action_330 _ = happyFail + +action_331 (100) = happyShift action_360 +action_331 _ = happyFail + +action_332 (100) = happyShift action_359 +action_332 _ = happyFail + +action_333 (100) = happyShift action_358 +action_333 _ = happyFail + +action_334 (108) = happyShift action_357 +action_334 _ = happyFail + +action_335 _ = happyReduce_104 + +action_336 (67) = happyShift action_39 +action_336 (68) = happyShift action_93 +action_336 (69) = happyShift action_119 +action_336 (72) = happyShift action_95 +action_336 (79) = happyShift action_120 +action_336 (81) = happyShift action_121 +action_336 (89) = happyShift action_122 +action_336 (90) = happyShift action_123 +action_336 (91) = happyShift action_96 +action_336 (92) = happyShift action_97 +action_336 (93) = happyShift action_124 +action_336 (94) = happyShift action_99 +action_336 (97) = happyShift action_100 +action_336 (99) = happyShift action_125 +action_336 (101) = happyShift action_126 +action_336 (103) = happyShift action_127 +action_336 (105) = happyShift action_128 +action_336 (109) = happyShift action_57 +action_336 (113) = happyShift action_58 +action_336 (114) = happyShift action_59 +action_336 (115) = happyShift action_60 +action_336 (117) = happyShift action_61 +action_336 (118) = happyShift action_62 +action_336 (120) = happyShift action_129 +action_336 (121) = happyShift action_103 +action_336 (23) = happyGoto action_104 +action_336 (26) = happyGoto action_105 +action_336 (27) = happyGoto action_106 +action_336 (29) = happyGoto action_107 +action_336 (31) = happyGoto action_108 +action_336 (32) = happyGoto action_109 +action_336 (33) = happyGoto action_110 +action_336 (34) = happyGoto action_111 +action_336 (39) = happyGoto action_112 +action_336 (42) = happyGoto action_356 +action_336 (43) = happyGoto action_114 +action_336 (44) = happyGoto action_115 +action_336 (45) = happyGoto action_116 +action_336 (46) = happyGoto action_117 +action_336 (47) = happyGoto action_118 +action_336 (48) = happyGoto action_87 +action_336 _ = happyReduce_60 + +action_337 (67) = happyShift action_39 +action_337 (93) = happyShift action_235 +action_337 (103) = happyShift action_236 +action_337 (109) = happyShift action_102 +action_337 (23) = happyGoto action_233 +action_337 (54) = happyGoto action_354 +action_337 (58) = happyGoto action_355 +action_337 (62) = happyGoto action_231 +action_337 _ = happyReduce_154 + +action_338 _ = happyReduce_113 + +action_339 (67) = happyShift action_39 +action_339 (68) = happyShift action_93 +action_339 (69) = happyShift action_119 +action_339 (72) = happyShift action_95 +action_339 (79) = happyShift action_120 +action_339 (81) = happyShift action_121 +action_339 (89) = happyShift action_122 +action_339 (90) = happyShift action_123 +action_339 (91) = happyShift action_96 +action_339 (92) = happyShift action_97 +action_339 (93) = happyShift action_124 +action_339 (94) = happyShift action_99 +action_339 (97) = happyShift action_100 +action_339 (99) = happyShift action_125 +action_339 (101) = happyShift action_126 +action_339 (103) = happyShift action_127 +action_339 (105) = happyShift action_128 +action_339 (109) = happyShift action_57 +action_339 (113) = happyShift action_58 +action_339 (114) = happyShift action_59 +action_339 (115) = happyShift action_60 +action_339 (117) = happyShift action_61 +action_339 (118) = happyShift action_62 +action_339 (120) = happyShift action_129 +action_339 (121) = happyShift action_103 +action_339 (23) = happyGoto action_104 +action_339 (26) = happyGoto action_105 +action_339 (27) = happyGoto action_106 +action_339 (29) = happyGoto action_107 +action_339 (31) = happyGoto action_108 +action_339 (32) = happyGoto action_109 +action_339 (33) = happyGoto action_110 +action_339 (34) = happyGoto action_111 +action_339 (39) = happyGoto action_112 +action_339 (42) = happyGoto action_353 +action_339 (43) = happyGoto action_114 +action_339 (44) = happyGoto action_115 +action_339 (45) = happyGoto action_116 +action_339 (46) = happyGoto action_117 +action_339 (47) = happyGoto action_118 +action_339 (48) = happyGoto action_87 +action_339 _ = happyReduce_60 + +action_340 (67) = happyShift action_39 +action_340 (68) = happyShift action_93 +action_340 (69) = happyShift action_119 +action_340 (72) = happyShift action_95 +action_340 (79) = happyShift action_120 +action_340 (81) = happyShift action_121 +action_340 (89) = happyShift action_122 +action_340 (90) = happyShift action_123 +action_340 (91) = happyShift action_96 +action_340 (92) = happyShift action_97 +action_340 (93) = happyShift action_124 +action_340 (94) = happyShift action_99 +action_340 (97) = happyShift action_100 +action_340 (99) = happyShift action_125 +action_340 (101) = happyShift action_126 +action_340 (103) = happyShift action_127 +action_340 (105) = happyShift action_128 +action_340 (109) = happyShift action_57 +action_340 (113) = happyShift action_58 +action_340 (114) = happyShift action_59 +action_340 (115) = happyShift action_60 +action_340 (117) = happyShift action_61 +action_340 (118) = happyShift action_62 +action_340 (120) = happyShift action_129 +action_340 (121) = happyShift action_103 +action_340 (23) = happyGoto action_104 +action_340 (26) = happyGoto action_105 +action_340 (27) = happyGoto action_106 +action_340 (29) = happyGoto action_107 +action_340 (31) = happyGoto action_108 +action_340 (32) = happyGoto action_109 +action_340 (33) = happyGoto action_110 +action_340 (34) = happyGoto action_111 +action_340 (39) = happyGoto action_112 +action_340 (42) = happyGoto action_352 +action_340 (43) = happyGoto action_114 +action_340 (44) = happyGoto action_115 +action_340 (45) = happyGoto action_116 +action_340 (46) = happyGoto action_117 +action_340 (47) = happyGoto action_118 +action_340 (48) = happyGoto action_87 +action_340 _ = happyReduce_60 + +action_341 (67) = happyShift action_39 +action_341 (68) = happyShift action_93 +action_341 (69) = happyShift action_119 +action_341 (72) = happyShift action_95 +action_341 (79) = happyShift action_120 +action_341 (81) = happyShift action_121 +action_341 (89) = happyShift action_122 +action_341 (90) = happyShift action_123 +action_341 (91) = happyShift action_96 +action_341 (92) = happyShift action_97 +action_341 (93) = happyShift action_124 +action_341 (94) = happyShift action_99 +action_341 (97) = happyShift action_100 +action_341 (99) = happyShift action_125 +action_341 (101) = happyShift action_126 +action_341 (103) = happyShift action_127 +action_341 (105) = happyShift action_128 +action_341 (109) = happyShift action_57 +action_341 (113) = happyShift action_58 +action_341 (114) = happyShift action_59 +action_341 (115) = happyShift action_60 +action_341 (117) = happyShift action_61 +action_341 (118) = happyShift action_62 +action_341 (120) = happyShift action_129 +action_341 (121) = happyShift action_103 +action_341 (23) = happyGoto action_104 +action_341 (26) = happyGoto action_105 +action_341 (27) = happyGoto action_106 +action_341 (29) = happyGoto action_107 +action_341 (31) = happyGoto action_108 +action_341 (32) = happyGoto action_109 +action_341 (33) = happyGoto action_110 +action_341 (34) = happyGoto action_111 +action_341 (39) = happyGoto action_112 +action_341 (42) = happyGoto action_351 +action_341 (43) = happyGoto action_114 +action_341 (44) = happyGoto action_115 +action_341 (45) = happyGoto action_116 +action_341 (46) = happyGoto action_117 +action_341 (47) = happyGoto action_118 +action_341 (48) = happyGoto action_87 +action_341 _ = happyReduce_60 + +action_342 (67) = happyShift action_39 +action_342 (68) = happyShift action_93 +action_342 (69) = happyShift action_119 +action_342 (72) = happyShift action_95 +action_342 (79) = happyShift action_120 +action_342 (81) = happyShift action_121 +action_342 (89) = happyShift action_122 +action_342 (90) = happyShift action_123 +action_342 (91) = happyShift action_96 +action_342 (92) = happyShift action_97 +action_342 (93) = happyShift action_124 +action_342 (94) = happyShift action_99 +action_342 (97) = happyShift action_100 +action_342 (99) = happyShift action_125 +action_342 (101) = happyShift action_126 +action_342 (103) = happyShift action_127 +action_342 (105) = happyShift action_128 +action_342 (109) = happyShift action_57 +action_342 (113) = happyShift action_58 +action_342 (114) = happyShift action_59 +action_342 (115) = happyShift action_60 +action_342 (117) = happyShift action_61 +action_342 (118) = happyShift action_62 +action_342 (120) = happyShift action_129 +action_342 (121) = happyShift action_103 +action_342 (23) = happyGoto action_104 +action_342 (26) = happyGoto action_105 +action_342 (27) = happyGoto action_106 +action_342 (29) = happyGoto action_107 +action_342 (31) = happyGoto action_108 +action_342 (32) = happyGoto action_109 +action_342 (33) = happyGoto action_110 +action_342 (34) = happyGoto action_111 +action_342 (39) = happyGoto action_112 +action_342 (42) = happyGoto action_306 +action_342 (43) = happyGoto action_114 +action_342 (44) = happyGoto action_115 +action_342 (45) = happyGoto action_116 +action_342 (46) = happyGoto action_117 +action_342 (47) = happyGoto action_350 +action_342 (48) = happyGoto action_87 +action_342 _ = happyReduce_60 + +action_343 (98) = happyShift action_349 +action_343 _ = happyFail + +action_344 (67) = happyShift action_39 +action_344 (23) = happyGoto action_37 +action_344 (24) = happyGoto action_246 +action_344 (49) = happyGoto action_348 +action_344 (50) = happyGoto action_248 +action_344 _ = happyReduce_141 + +action_345 _ = happyReduce_136 + +action_346 (67) = happyShift action_39 +action_346 (68) = happyShift action_93 +action_346 (69) = happyShift action_119 +action_346 (72) = happyShift action_95 +action_346 (79) = happyShift action_120 +action_346 (81) = happyShift action_121 +action_346 (89) = happyShift action_122 +action_346 (90) = happyShift action_123 +action_346 (91) = happyShift action_96 +action_346 (92) = happyShift action_97 +action_346 (93) = happyShift action_124 +action_346 (94) = happyShift action_99 +action_346 (97) = happyShift action_100 +action_346 (99) = happyShift action_125 +action_346 (101) = happyShift action_126 +action_346 (103) = happyShift action_127 +action_346 (105) = happyShift action_128 +action_346 (109) = happyShift action_57 +action_346 (113) = happyShift action_58 +action_346 (114) = happyShift action_59 +action_346 (115) = happyShift action_60 +action_346 (117) = happyShift action_61 +action_346 (118) = happyShift action_62 +action_346 (120) = happyShift action_129 +action_346 (121) = happyShift action_103 +action_346 (23) = happyGoto action_104 +action_346 (26) = happyGoto action_105 +action_346 (27) = happyGoto action_106 +action_346 (29) = happyGoto action_107 +action_346 (31) = happyGoto action_108 +action_346 (32) = happyGoto action_109 +action_346 (33) = happyGoto action_110 +action_346 (34) = happyGoto action_111 +action_346 (39) = happyGoto action_112 +action_346 (40) = happyGoto action_347 +action_346 (41) = happyGoto action_200 +action_346 (42) = happyGoto action_157 +action_346 (43) = happyGoto action_114 +action_346 (44) = happyGoto action_115 +action_346 (45) = happyGoto action_116 +action_346 (46) = happyGoto action_117 +action_346 (47) = happyGoto action_118 +action_346 (48) = happyGoto action_87 +action_346 _ = happyReduce_60 + +action_347 _ = happyReduce_142 + +action_348 _ = happyReduce_139 + +action_349 _ = happyReduce_131 + +action_350 (104) = happyReduce_171 +action_350 (106) = happyReduce_171 +action_350 _ = happyReduce_123 + +action_351 (104) = happyShift action_388 +action_351 _ = happyFail + +action_352 (104) = happyShift action_387 +action_352 _ = happyFail + +action_353 (104) = happyShift action_386 +action_353 _ = happyFail + +action_354 (100) = happyShift action_385 +action_354 _ = happyFail + +action_355 (107) = happyShift action_383 +action_355 (110) = happyShift action_384 +action_355 _ = happyReduce_153 + +action_356 (102) = happyShift action_382 +action_356 _ = happyFail + +action_357 (67) = happyShift action_39 +action_357 (68) = happyShift action_93 +action_357 (69) = happyShift action_119 +action_357 (72) = happyShift action_95 +action_357 (79) = happyShift action_120 +action_357 (81) = happyShift action_121 +action_357 (89) = happyShift action_122 +action_357 (90) = happyShift action_123 +action_357 (91) = happyShift action_96 +action_357 (92) = happyShift action_97 +action_357 (93) = happyShift action_124 +action_357 (94) = happyShift action_99 +action_357 (97) = happyShift action_100 +action_357 (99) = happyShift action_125 +action_357 (101) = happyShift action_126 +action_357 (103) = happyShift action_127 +action_357 (105) = happyShift action_128 +action_357 (109) = happyShift action_57 +action_357 (113) = happyShift action_58 +action_357 (114) = happyShift action_59 +action_357 (115) = happyShift action_60 +action_357 (117) = happyShift action_61 +action_357 (118) = happyShift action_62 +action_357 (120) = happyShift action_129 +action_357 (121) = happyShift action_103 +action_357 (23) = happyGoto action_104 +action_357 (26) = happyGoto action_105 +action_357 (27) = happyGoto action_106 +action_357 (29) = happyGoto action_107 +action_357 (31) = happyGoto action_108 +action_357 (32) = happyGoto action_109 +action_357 (33) = happyGoto action_110 +action_357 (34) = happyGoto action_111 +action_357 (39) = happyGoto action_112 +action_357 (42) = happyGoto action_381 +action_357 (43) = happyGoto action_114 +action_357 (44) = happyGoto action_115 +action_357 (45) = happyGoto action_116 +action_357 (46) = happyGoto action_117 +action_357 (47) = happyGoto action_118 +action_357 (48) = happyGoto action_87 +action_357 _ = happyReduce_60 + +action_358 _ = happyReduce_74 + +action_359 _ = happyReduce_75 + +action_360 _ = happyReduce_76 + +action_361 _ = happyReduce_72 + +action_362 _ = happyReduce_73 + +action_363 (74) = happyShift action_319 +action_363 (22) = happyGoto action_380 +action_363 _ = happyReduce_41 + +action_364 _ = happyReduce_186 + +action_365 _ = happyReduce_42 + +action_366 _ = happyReduce_144 + +action_367 (74) = happyShift action_319 +action_367 (22) = happyGoto action_379 +action_367 _ = happyReduce_41 + +action_368 _ = happyReduce_185 + +action_369 (104) = happyShift action_378 +action_369 _ = happyFail + +action_370 (104) = happyShift action_377 +action_370 _ = happyFail + +action_371 (104) = happyShift action_376 +action_371 _ = happyFail + +action_372 _ = happyReduce_71 + +action_373 _ = happyReduce_63 + +action_374 _ = happyReduce_64 + +action_375 _ = happyReduce_65 + +action_376 _ = happyReduce_66 + +action_377 _ = happyReduce_67 + +action_378 _ = happyReduce_68 + +action_379 _ = happyReduce_27 + +action_380 _ = happyReduce_29 + +action_381 (104) = happyShift action_392 +action_381 _ = happyFail + +action_382 (112) = happyShift action_391 +action_382 _ = happyFail + +action_383 (67) = happyShift action_39 +action_383 (93) = happyShift action_235 +action_383 (103) = happyShift action_236 +action_383 (109) = happyShift action_102 +action_383 (23) = happyGoto action_233 +action_383 (54) = happyGoto action_390 +action_383 (58) = happyGoto action_355 +action_383 (62) = happyGoto action_231 +action_383 _ = happyReduce_154 + +action_384 (67) = happyShift action_39 +action_384 (68) = happyShift action_93 +action_384 (69) = happyShift action_119 +action_384 (72) = happyShift action_95 +action_384 (79) = happyShift action_120 +action_384 (81) = happyShift action_121 +action_384 (89) = happyShift action_122 +action_384 (90) = happyShift action_123 +action_384 (91) = happyShift action_96 +action_384 (92) = happyShift action_97 +action_384 (93) = happyShift action_124 +action_384 (94) = happyShift action_99 +action_384 (97) = happyShift action_100 +action_384 (99) = happyShift action_125 +action_384 (101) = happyShift action_126 +action_384 (103) = happyShift action_127 +action_384 (105) = happyShift action_128 +action_384 (109) = happyShift action_57 +action_384 (113) = happyShift action_58 +action_384 (114) = happyShift action_59 +action_384 (115) = happyShift action_60 +action_384 (117) = happyShift action_61 +action_384 (118) = happyShift action_62 +action_384 (120) = happyShift action_129 +action_384 (121) = happyShift action_103 +action_384 (23) = happyGoto action_104 +action_384 (26) = happyGoto action_105 +action_384 (27) = happyGoto action_106 +action_384 (29) = happyGoto action_107 +action_384 (31) = happyGoto action_108 +action_384 (32) = happyGoto action_109 +action_384 (33) = happyGoto action_110 +action_384 (34) = happyGoto action_111 +action_384 (39) = happyGoto action_112 +action_384 (40) = happyGoto action_389 +action_384 (41) = happyGoto action_200 +action_384 (42) = happyGoto action_157 +action_384 (43) = happyGoto action_114 +action_384 (44) = happyGoto action_115 +action_384 (45) = happyGoto action_116 +action_384 (46) = happyGoto action_117 +action_384 (47) = happyGoto action_118 +action_384 (48) = happyGoto action_87 +action_384 _ = happyReduce_60 + +action_385 _ = happyReduce_105 + +action_386 (119) = happyReduce_66 +action_386 _ = happyReduce_66 + +action_387 (119) = happyReduce_67 +action_387 _ = happyReduce_67 + +action_388 (119) = happyReduce_68 +action_388 _ = happyReduce_68 + +action_389 (107) = happyShift action_395 +action_389 _ = happyReduce_151 + +action_390 _ = happyReduce_152 + +action_391 (67) = happyShift action_39 +action_391 (68) = happyShift action_93 +action_391 (69) = happyShift action_119 +action_391 (72) = happyShift action_95 +action_391 (79) = happyShift action_120 +action_391 (81) = happyShift action_121 +action_391 (89) = happyShift action_122 +action_391 (90) = happyShift action_123 +action_391 (91) = happyShift action_96 +action_391 (92) = happyShift action_97 +action_391 (93) = happyShift action_124 +action_391 (94) = happyShift action_99 +action_391 (97) = happyShift action_100 +action_391 (99) = happyShift action_125 +action_391 (101) = happyShift action_126 +action_391 (103) = happyShift action_127 +action_391 (105) = happyShift action_128 +action_391 (109) = happyShift action_57 +action_391 (113) = happyShift action_58 +action_391 (114) = happyShift action_59 +action_391 (115) = happyShift action_60 +action_391 (117) = happyShift action_61 +action_391 (118) = happyShift action_62 +action_391 (120) = happyShift action_129 +action_391 (121) = happyShift action_103 +action_391 (23) = happyGoto action_104 +action_391 (26) = happyGoto action_105 +action_391 (27) = happyGoto action_106 +action_391 (29) = happyGoto action_107 +action_391 (31) = happyGoto action_108 +action_391 (32) = happyGoto action_109 +action_391 (33) = happyGoto action_110 +action_391 (34) = happyGoto action_111 +action_391 (39) = happyGoto action_112 +action_391 (42) = happyGoto action_394 +action_391 (43) = happyGoto action_114 +action_391 (44) = happyGoto action_115 +action_391 (45) = happyGoto action_116 +action_391 (46) = happyGoto action_117 +action_391 (47) = happyGoto action_118 +action_391 (48) = happyGoto action_87 +action_391 _ = happyReduce_60 + +action_392 (112) = happyShift action_393 +action_392 _ = happyFail + +action_393 (67) = happyShift action_39 +action_393 (68) = happyShift action_93 +action_393 (69) = happyShift action_119 +action_393 (72) = happyShift action_95 +action_393 (79) = happyShift action_120 +action_393 (81) = happyShift action_121 +action_393 (89) = happyShift action_122 +action_393 (90) = happyShift action_123 +action_393 (91) = happyShift action_96 +action_393 (92) = happyShift action_97 +action_393 (93) = happyShift action_124 +action_393 (94) = happyShift action_99 +action_393 (97) = happyShift action_100 +action_393 (99) = happyShift action_125 +action_393 (101) = happyShift action_126 +action_393 (103) = happyShift action_127 +action_393 (105) = happyShift action_128 +action_393 (109) = happyShift action_57 +action_393 (113) = happyShift action_58 +action_393 (114) = happyShift action_59 +action_393 (115) = happyShift action_60 +action_393 (117) = happyShift action_61 +action_393 (118) = happyShift action_62 +action_393 (120) = happyShift action_129 +action_393 (121) = happyShift action_103 +action_393 (23) = happyGoto action_104 +action_393 (26) = happyGoto action_105 +action_393 (27) = happyGoto action_106 +action_393 (29) = happyGoto action_107 +action_393 (31) = happyGoto action_108 +action_393 (32) = happyGoto action_109 +action_393 (33) = happyGoto action_110 +action_393 (34) = happyGoto action_111 +action_393 (39) = happyGoto action_112 +action_393 (42) = happyGoto action_397 +action_393 (43) = happyGoto action_114 +action_393 (44) = happyGoto action_115 +action_393 (45) = happyGoto action_116 +action_393 (46) = happyGoto action_117 +action_393 (47) = happyGoto action_118 +action_393 (48) = happyGoto action_87 +action_393 _ = happyReduce_60 + +action_394 _ = happyReduce_85 + +action_395 (67) = happyShift action_39 +action_395 (93) = happyShift action_235 +action_395 (103) = happyShift action_236 +action_395 (109) = happyShift action_102 +action_395 (23) = happyGoto action_233 +action_395 (54) = happyGoto action_396 +action_395 (58) = happyGoto action_355 +action_395 (62) = happyGoto action_231 +action_395 _ = happyReduce_154 + +action_396 _ = happyReduce_150 + +action_397 _ = happyReduce_86 + +happyReduce_1 = happySpecReduce_1 4 happyReduction_1 +happyReduction_1 (HappyAbsSyn4 happy_var_1) + = HappyAbsSyn4 + (reverse happy_var_1 + ) +happyReduction_1 _ = notHappyAtAll + +happyReduce_2 = happySpecReduce_0 5 happyReduction_2 +happyReduction_2 = HappyAbsSyn4 + ([] + ) + +happyReduce_3 = happySpecReduce_2 5 happyReduction_3 +happyReduction_3 (HappyAbsSyn6 happy_var_2) + (HappyAbsSyn4 happy_var_1) + = HappyAbsSyn4 + (happy_var_2 : happy_var_1 + ) +happyReduction_3 _ _ = notHappyAtAll + +happyReduce_4 = happySpecReduce_1 6 happyReduction_4 +happyReduction_4 (HappyAbsSyn6 happy_var_1) + = HappyAbsSyn6 + (happy_var_1 + ) +happyReduction_4 _ = notHappyAtAll + +happyReduce_5 = happySpecReduce_1 6 happyReduction_5 +happyReduction_5 (HappyAbsSyn6 happy_var_1) + = HappyAbsSyn6 + (happy_var_1 + ) +happyReduction_5 _ = notHappyAtAll + +happyReduce_6 = happySpecReduce_1 6 happyReduction_6 +happyReduction_6 (HappyAbsSyn6 happy_var_1) + = HappyAbsSyn6 + (happy_var_1 + ) +happyReduction_6 _ = notHappyAtAll + +happyReduce_7 = happySpecReduce_1 6 happyReduction_7 +happyReduction_7 (HappyAbsSyn6 happy_var_1) + = HappyAbsSyn6 + (happy_var_1 + ) +happyReduction_7 _ = notHappyAtAll + +happyReduce_8 = happySpecReduce_1 6 happyReduction_8 +happyReduction_8 (HappyAbsSyn6 happy_var_1) + = HappyAbsSyn6 + (happy_var_1 + ) +happyReduction_8 _ = notHappyAtAll + +happyReduce_9 = happySpecReduce_1 6 happyReduction_9 +happyReduction_9 (HappyAbsSyn6 happy_var_1) + = HappyAbsSyn6 + (happy_var_1 + ) +happyReduction_9 _ = notHappyAtAll + +happyReduce_10 = happySpecReduce_1 6 happyReduction_10 +happyReduction_10 (HappyAbsSyn6 happy_var_1) + = HappyAbsSyn6 + (happy_var_1 + ) +happyReduction_10 _ = notHappyAtAll + +happyReduce_11 = happySpecReduce_1 6 happyReduction_11 +happyReduction_11 (HappyAbsSyn6 happy_var_1) + = HappyAbsSyn6 + (happy_var_1 + ) +happyReduction_11 _ = notHappyAtAll + +happyReduce_12 = happySpecReduce_1 6 happyReduction_12 +happyReduction_12 (HappyAbsSyn6 happy_var_1) + = HappyAbsSyn6 + (happy_var_1 + ) +happyReduction_12 _ = notHappyAtAll + +happyReduce_13 = happySpecReduce_1 6 happyReduction_13 +happyReduction_13 (HappyAbsSyn6 happy_var_1) + = HappyAbsSyn6 + (happy_var_1 + ) +happyReduction_13 _ = notHappyAtAll + +happyReduce_14 = happySpecReduce_2 6 happyReduction_14 +happyReduction_14 (HappyAbsSyn6 happy_var_2) + _ + = HappyAbsSyn6 + (C.OverrideDecl Impredicative [happy_var_2] + ) +happyReduction_14 _ _ = notHappyAtAll + +happyReduce_15 = happyReduce 4 6 happyReduction_15 +happyReduction_15 (_ `HappyStk` + (HappyAbsSyn4 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn6 + (C.OverrideDecl Impredicative happy_var_3 + ) `HappyStk` happyRest + +happyReduce_16 = happySpecReduce_2 6 happyReduction_16 +happyReduction_16 (HappyAbsSyn6 happy_var_2) + _ + = HappyAbsSyn6 + (C.OverrideDecl Fail [happy_var_2] + ) +happyReduction_16 _ _ = notHappyAtAll + +happyReduce_17 = happyReduce 4 6 happyReduction_17 +happyReduction_17 (_ `HappyStk` + (HappyAbsSyn4 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn6 + (C.OverrideDecl Fail happy_var_3 + ) `HappyStk` happyRest + +happyReduce_18 = happySpecReduce_2 6 happyReduction_18 +happyReduction_18 (HappyAbsSyn6 happy_var_2) + _ + = HappyAbsSyn6 + (C.OverrideDecl Check [happy_var_2] + ) +happyReduction_18 _ _ = notHappyAtAll + +happyReduce_19 = happyReduce 4 6 happyReduction_19 +happyReduction_19 (_ `HappyStk` + (HappyAbsSyn4 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn6 + (C.OverrideDecl Check happy_var_3 + ) `HappyStk` happyRest + +happyReduce_20 = happySpecReduce_2 6 happyReduction_20 +happyReduction_20 (HappyAbsSyn6 happy_var_2) + _ + = HappyAbsSyn6 + (C.OverrideDecl TrustMe [happy_var_2] + ) +happyReduction_20 _ _ = notHappyAtAll + +happyReduce_21 = happyReduce 4 6 happyReduction_21 +happyReduction_21 (_ `HappyStk` + (HappyAbsSyn4 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn6 + (C.OverrideDecl TrustMe happy_var_3 + ) `HappyStk` happyRest + +happyReduce_22 = happySpecReduce_2 7 happyReduction_22 +happyReduction_22 (HappyAbsSyn12 happy_var_2) + _ + = HappyAbsSyn6 + (let (n,tel,t,cs,fs) = happy_var_2 in C.DataDecl n A.NotSized A.Ind tel t cs fs + ) +happyReduction_22 _ _ = notHappyAtAll + +happyReduce_23 = happySpecReduce_3 8 happyReduction_23 +happyReduction_23 (HappyAbsSyn12 happy_var_3) + _ + _ + = HappyAbsSyn6 + (let (n,tel,t,cs,fs) = happy_var_3 in C.DataDecl n A.Sized A.Ind tel t cs fs + ) +happyReduction_23 _ _ _ = notHappyAtAll + +happyReduce_24 = happySpecReduce_2 9 happyReduction_24 +happyReduction_24 (HappyAbsSyn12 happy_var_2) + _ + = HappyAbsSyn6 + (let (n,tel,t,cs,fs) = happy_var_2 in C.DataDecl n A.NotSized A.CoInd tel t cs fs + ) +happyReduction_24 _ _ = notHappyAtAll + +happyReduce_25 = happySpecReduce_3 10 happyReduction_25 +happyReduction_25 (HappyAbsSyn12 happy_var_3) + _ + _ + = HappyAbsSyn6 + (let (n,tel,t,cs,fs) = happy_var_3 in C.DataDecl n A.Sized A.CoInd tel t cs fs + ) +happyReduction_25 _ _ _ = notHappyAtAll + +happyReduce_26 = happySpecReduce_2 11 happyReduction_26 +happyReduction_26 (HappyAbsSyn13 happy_var_2) + _ + = HappyAbsSyn6 + (let (n,tel,t,c,fs) = happy_var_2 in C.RecordDecl n tel t c fs + ) +happyReduction_26 _ _ = notHappyAtAll + +happyReduce_27 = happyReduce 8 12 happyReduction_27 +happyReduction_27 ((HappyAbsSyn22 happy_var_8) `HappyStk` + _ `HappyStk` + (HappyAbsSyn53 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn31 happy_var_2) `HappyStk` + (HappyAbsSyn23 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn12 + ((happy_var_1, happy_var_2, happy_var_4, reverse happy_var_6, happy_var_8) + ) `HappyStk` happyRest + +happyReduce_28 = happyReduce 6 12 happyReduction_28 +happyReduction_28 ((HappyAbsSyn22 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn53 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn31 happy_var_2) `HappyStk` + (HappyAbsSyn23 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn12 + ((happy_var_1, happy_var_2, C.set0, reverse happy_var_4, happy_var_6) + ) `HappyStk` happyRest + +happyReduce_29 = happyReduce 8 13 happyReduction_29 +happyReduction_29 ((HappyAbsSyn22 happy_var_8) `HappyStk` + _ `HappyStk` + (HappyAbsSyn52 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn31 happy_var_2) `HappyStk` + (HappyAbsSyn23 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn13 + ((happy_var_1, happy_var_2, happy_var_4, happy_var_6, happy_var_8) + ) `HappyStk` happyRest + +happyReduce_30 = happyReduce 6 13 happyReduction_30 +happyReduction_30 ((HappyAbsSyn22 happy_var_6) `HappyStk` + _ `HappyStk` + (HappyAbsSyn52 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn31 happy_var_2) `HappyStk` + (HappyAbsSyn23 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn13 + ((happy_var_1, happy_var_2, C.set0, happy_var_4, happy_var_6) + ) `HappyStk` happyRest + +happyReduce_31 = happyReduce 5 14 happyReduction_31 +happyReduction_31 (_ `HappyStk` + (HappyAbsSyn54 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn51 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn6 + (C.FunDecl A.Ind happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_32 = happyReduce 5 15 happyReduction_32 +happyReduction_32 (_ `HappyStk` + (HappyAbsSyn54 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn51 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn6 + (C.FunDecl A.CoInd happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_33 = happyReduce 4 16 happyReduction_33 +happyReduction_33 (_ `HappyStk` + (HappyAbsSyn4 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn6 + (C.MutualDecl (reverse happy_var_3) + ) `HappyStk` happyRest + +happyReduce_34 = happySpecReduce_3 17 happyReduction_34 +happyReduction_34 (HappyAbsSyn18 happy_var_3) + _ + (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn6 + (C.LetDecl happy_var_1 happy_var_3 + ) +happyReduction_34 _ _ _ = notHappyAtAll + +happyReduce_35 = happyReduce 5 18 happyReduction_35 +happyReduction_35 ((HappyAbsSyn40 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyAbsSyn20 happy_var_3) `HappyStk` + (HappyAbsSyn31 happy_var_2) `HappyStk` + (HappyAbsSyn36 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn18 + (let (dec,n) = happy_var_1 in C.LetDef dec n happy_var_2 happy_var_3 happy_var_5 + ) `HappyStk` happyRest + +happyReduce_36 = happySpecReduce_0 19 happyReduction_36 +happyReduction_36 = HappyAbsSyn19 + (False + ) + +happyReduce_37 = happySpecReduce_1 19 happyReduction_37 +happyReduction_37 _ + = HappyAbsSyn19 + (True + ) + +happyReduce_38 = happySpecReduce_0 20 happyReduction_38 +happyReduction_38 = HappyAbsSyn20 + (Nothing + ) + +happyReduce_39 = happySpecReduce_2 20 happyReduction_39 +happyReduction_39 (HappyAbsSyn40 happy_var_2) + _ + = HappyAbsSyn20 + (Just happy_var_2 + ) +happyReduction_39 _ _ = notHappyAtAll + +happyReduce_40 = happyReduce 4 21 happyReduction_40 +happyReduction_40 ((HappyAbsSyn58 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn22 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn6 + (C.PatternDecl (head happy_var_2) (tail happy_var_2) happy_var_4 + ) `HappyStk` happyRest + +happyReduce_41 = happySpecReduce_0 22 happyReduction_41 +happyReduction_41 = HappyAbsSyn22 + ([] + ) + +happyReduce_42 = happySpecReduce_2 22 happyReduction_42 +happyReduction_42 (HappyAbsSyn22 happy_var_2) + _ + = HappyAbsSyn22 + (happy_var_2 + ) +happyReduction_42 _ _ = notHappyAtAll + +happyReduce_43 = happySpecReduce_1 23 happyReduction_43 +happyReduction_43 (HappyTerminal (T.Id happy_var_1 _)) + = HappyAbsSyn23 + (C.Name happy_var_1 + ) +happyReduction_43 _ = notHappyAtAll + +happyReduce_44 = happySpecReduce_1 24 happyReduction_44 +happyReduction_44 (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn22 + ([happy_var_1] + ) +happyReduction_44 _ = notHappyAtAll + +happyReduce_45 = happySpecReduce_2 24 happyReduction_45 +happyReduction_45 (HappyAbsSyn22 happy_var_2) + (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn22 + (happy_var_1 : happy_var_2 + ) +happyReduction_45 _ _ = notHappyAtAll + +happyReduce_46 = happySpecReduce_1 25 happyReduction_46 +happyReduction_46 (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn22 + ([happy_var_1] + ) +happyReduction_46 _ = notHappyAtAll + +happyReduce_47 = happySpecReduce_3 25 happyReduction_47 +happyReduction_47 (HappyAbsSyn22 happy_var_3) + _ + (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn22 + (happy_var_1 : happy_var_3 + ) +happyReduction_47 _ _ _ = notHappyAtAll + +happyReduce_48 = happySpecReduce_1 26 happyReduction_48 +happyReduction_48 _ + = HappyAbsSyn26 + (SPos + ) + +happyReduce_49 = happySpecReduce_1 26 happyReduction_49 +happyReduction_49 _ + = HappyAbsSyn26 + (Pos + ) + +happyReduce_50 = happySpecReduce_1 26 happyReduction_50 +happyReduction_50 _ + = HappyAbsSyn26 + (Neg + ) + +happyReduce_51 = happySpecReduce_1 26 happyReduction_51 +happyReduction_51 _ + = HappyAbsSyn26 + (Const + ) + +happyReduce_52 = happySpecReduce_1 26 happyReduction_52 +happyReduction_52 _ + = HappyAbsSyn26 + (Param + ) + +happyReduce_53 = happySpecReduce_1 26 happyReduction_53 +happyReduction_53 _ + = HappyAbsSyn26 + (Rec + ) + +happyReduce_54 = happySpecReduce_2 27 happyReduction_54 +happyReduction_54 (HappyAbsSyn28 happy_var_2) + _ + = HappyAbsSyn27 + (A.Measure happy_var_2 + ) +happyReduction_54 _ _ = notHappyAtAll + +happyReduce_55 = happySpecReduce_2 28 happyReduction_55 +happyReduction_55 _ + (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn28 + ([happy_var_1] + ) +happyReduction_55 _ _ = notHappyAtAll + +happyReduce_56 = happySpecReduce_3 28 happyReduction_56 +happyReduction_56 (HappyAbsSyn28 happy_var_3) + _ + (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn28 + (happy_var_1 : happy_var_3 + ) +happyReduction_56 _ _ _ = notHappyAtAll + +happyReduce_57 = happySpecReduce_3 29 happyReduction_57 +happyReduction_57 (HappyAbsSyn27 happy_var_3) + _ + (HappyAbsSyn27 happy_var_1) + = HappyAbsSyn29 + (A.Bound A.Lt happy_var_1 happy_var_3 + ) +happyReduction_57 _ _ _ = notHappyAtAll + +happyReduce_58 = happySpecReduce_3 29 happyReduction_58 +happyReduction_58 (HappyAbsSyn27 happy_var_3) + _ + (HappyAbsSyn27 happy_var_1) + = HappyAbsSyn29 + (A.Bound A.Le happy_var_1 happy_var_3 + ) +happyReduction_58 _ _ _ = notHappyAtAll + +happyReduce_59 = happySpecReduce_1 30 happyReduction_59 +happyReduction_59 (HappyAbsSyn28 happy_var_1) + = HappyAbsSyn22 + (let { f (C.Ident (C.QName x)) = x + ; f e = error ("not an identifier: " ++ C.prettyExpr e) + } in map f happy_var_1 + ) +happyReduction_59 _ = notHappyAtAll + +happyReduce_60 = happySpecReduce_0 31 happyReduction_60 +happyReduction_60 = HappyAbsSyn31 + ([] + ) + +happyReduce_61 = happySpecReduce_2 31 happyReduction_61 +happyReduction_61 (HappyAbsSyn31 happy_var_2) + (HappyAbsSyn32 happy_var_1) + = HappyAbsSyn31 + (happy_var_1 : happy_var_2 + ) +happyReduction_61 _ _ = notHappyAtAll + +happyReduce_62 = happySpecReduce_2 31 happyReduction_62 +happyReduction_62 (HappyAbsSyn31 happy_var_2) + (HappyAbsSyn27 happy_var_1) + = HappyAbsSyn31 + (C.TMeasure happy_var_1 : happy_var_2 + ) +happyReduction_62 _ _ = notHappyAtAll + +happyReduce_63 = happyReduce 5 32 happyReduction_63 +happyReduction_63 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn22 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBind (Dec Default) happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_64 = happyReduce 5 32 happyReduction_64 +happyReduction_64 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBounded A.defaultDec happy_var_2 A.Lt happy_var_4 + ) `HappyStk` happyRest + +happyReduce_65 = happyReduce 5 32 happyReduction_65 +happyReduction_65 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBounded A.defaultDec happy_var_2 A.Le happy_var_4 + ) `HappyStk` happyRest + +happyReduce_66 = happyReduce 6 32 happyReduction_66 +happyReduction_66 (_ `HappyStk` + (HappyAbsSyn40 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyAbsSyn22 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyAbsSyn26 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBind (Dec happy_var_1) happy_var_3 happy_var_5 + ) `HappyStk` happyRest + +happyReduce_67 = happyReduce 6 32 happyReduction_67 +happyReduction_67 (_ `HappyStk` + (HappyAbsSyn40 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyAbsSyn26 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBounded (Dec happy_var_1) happy_var_3 A.Lt happy_var_5 + ) `HappyStk` happyRest + +happyReduce_68 = happyReduce 6 32 happyReduction_68 +happyReduction_68 (_ `HappyStk` + (HappyAbsSyn40 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyAbsSyn26 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBounded (Dec happy_var_1) happy_var_3 A.Le happy_var_5 + ) `HappyStk` happyRest + +happyReduce_69 = happySpecReduce_1 32 happyReduction_69 +happyReduction_69 (HappyAbsSyn32 happy_var_1) + = HappyAbsSyn32 + (happy_var_1 + ) +happyReduction_69 _ = notHappyAtAll + +happyReduce_70 = happySpecReduce_1 32 happyReduction_70 +happyReduction_70 (HappyAbsSyn32 happy_var_1) + = HappyAbsSyn32 + (happy_var_1 + ) +happyReduction_70 _ = notHappyAtAll + +happyReduce_71 = happyReduce 5 33 happyReduction_71 +happyReduction_71 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn22 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBind A.irrelevantDec happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_72 = happyReduce 5 33 happyReduction_72 +happyReduction_72 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBounded A.irrelevantDec happy_var_2 A.Lt happy_var_4 + ) `HappyStk` happyRest + +happyReduce_73 = happyReduce 5 33 happyReduction_73 +happyReduction_73 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBounded A.irrelevantDec happy_var_2 A.Le happy_var_4 + ) `HappyStk` happyRest + +happyReduce_74 = happyReduce 5 34 happyReduction_74 +happyReduction_74 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn22 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBind A.Hidden happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_75 = happyReduce 5 34 happyReduction_75 +happyReduction_75 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBounded A.Hidden happy_var_2 A.Lt happy_var_4 + ) `HappyStk` happyRest + +happyReduce_76 = happyReduce 5 34 happyReduction_76 +happyReduction_76 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBounded A.Hidden happy_var_2 A.Le happy_var_4 + ) `HappyStk` happyRest + +happyReduce_77 = happySpecReduce_1 35 happyReduction_77 +happyReduction_77 (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn35 + (C.TBind A.defaultDec [happy_var_1] Nothing + ) +happyReduction_77 _ = notHappyAtAll + +happyReduce_78 = happySpecReduce_3 35 happyReduction_78 +happyReduction_78 _ + (HappyAbsSyn23 happy_var_2) + _ + = HappyAbsSyn35 + (C.TBind A.irrelevantDec [happy_var_2] Nothing + ) +happyReduction_78 _ _ _ = notHappyAtAll + +happyReduce_79 = happySpecReduce_2 35 happyReduction_79 +happyReduction_79 (HappyAbsSyn23 happy_var_2) + (HappyAbsSyn26 happy_var_1) + = HappyAbsSyn35 + (C.TBind (Dec happy_var_1) [happy_var_2] Nothing + ) +happyReduction_79 _ _ = notHappyAtAll + +happyReduce_80 = happyReduce 4 35 happyReduction_80 +happyReduction_80 (_ `HappyStk` + (HappyAbsSyn23 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyAbsSyn26 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn35 + (C.TBind (Dec happy_var_1) [happy_var_3] Nothing + ) `HappyStk` happyRest + +happyReduce_81 = happySpecReduce_1 36 happyReduction_81 +happyReduction_81 (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn36 + ((A.defaultDec , happy_var_1) + ) +happyReduction_81 _ = notHappyAtAll + +happyReduce_82 = happySpecReduce_3 36 happyReduction_82 +happyReduction_82 _ + (HappyAbsSyn23 happy_var_2) + _ + = HappyAbsSyn36 + ((A.irrelevantDec, happy_var_2) + ) +happyReduction_82 _ _ _ = notHappyAtAll + +happyReduce_83 = happySpecReduce_2 36 happyReduction_83 +happyReduction_83 (HappyAbsSyn23 happy_var_2) + (HappyAbsSyn26 happy_var_1) + = HappyAbsSyn36 + ((Dec happy_var_1 , happy_var_2) + ) +happyReduction_83 _ _ = notHappyAtAll + +happyReduce_84 = happySpecReduce_1 37 happyReduction_84 +happyReduction_84 (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn18 + (happy_var_1 + ) +happyReduction_84 _ = notHappyAtAll + +happyReduce_85 = happyReduce 7 37 happyReduction_85 +happyReduction_85 ((HappyAbsSyn40 happy_var_7) `HappyStk` + _ `HappyStk` + _ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn18 + (C.LetDef A.irrelevantDec happy_var_2 [] (Just happy_var_4) happy_var_7 + ) `HappyStk` happyRest + +happyReduce_86 = happyReduce 8 37 happyReduction_86 +happyReduction_86 ((HappyAbsSyn40 happy_var_8) `HappyStk` + _ `HappyStk` + _ `HappyStk` + (HappyAbsSyn40 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyAbsSyn26 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn18 + (C.LetDef (Dec happy_var_1) happy_var_3 [] (Just happy_var_5) happy_var_8 + ) `HappyStk` happyRest + +happyReduce_87 = happySpecReduce_1 38 happyReduction_87 +happyReduction_87 (HappyAbsSyn35 happy_var_1) + = HappyAbsSyn35 + (happy_var_1 + ) +happyReduction_87 _ = notHappyAtAll + +happyReduce_88 = happySpecReduce_3 38 happyReduction_88 +happyReduction_88 (HappyAbsSyn40 happy_var_3) + _ + (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn35 + (C.TBind A.defaultDec [happy_var_1] (Just happy_var_3) + ) +happyReduction_88 _ _ _ = notHappyAtAll + +happyReduce_89 = happyReduce 5 38 happyReduction_89 +happyReduction_89 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn35 + (C.TBind A.defaultDec [happy_var_2] (Just happy_var_4) + ) `HappyStk` happyRest + +happyReduce_90 = happyReduce 5 38 happyReduction_90 +happyReduction_90 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn35 + (C.TBind A.irrelevantDec [happy_var_2] (Just happy_var_4) + ) `HappyStk` happyRest + +happyReduce_91 = happyReduce 6 38 happyReduction_91 +happyReduction_91 (_ `HappyStk` + (HappyAbsSyn40 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyAbsSyn23 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyAbsSyn26 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn35 + (C.TBind (Dec happy_var_1) [happy_var_3] (Just happy_var_5) + ) `HappyStk` happyRest + +happyReduce_92 = happySpecReduce_1 39 happyReduction_92 +happyReduction_92 (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn31 + ([C.TBind (Dec Default) {- A.defaultDec -} [] happy_var_1] + ) +happyReduction_92 _ = notHappyAtAll + +happyReduce_93 = happySpecReduce_3 39 happyReduction_93 +happyReduction_93 _ + (HappyAbsSyn40 happy_var_2) + _ + = HappyAbsSyn31 + ([C.TBind A.irrelevantDec [] happy_var_2] + ) +happyReduction_93 _ _ _ = notHappyAtAll + +happyReduce_94 = happySpecReduce_2 39 happyReduction_94 +happyReduction_94 (HappyAbsSyn40 happy_var_2) + (HappyAbsSyn26 happy_var_1) + = HappyAbsSyn31 + ([C.TBind (Dec happy_var_1) [] happy_var_2] + ) +happyReduction_94 _ _ = notHappyAtAll + +happyReduce_95 = happySpecReduce_1 39 happyReduction_95 +happyReduction_95 (HappyAbsSyn32 happy_var_1) + = HappyAbsSyn31 + ([happy_var_1] + ) +happyReduction_95 _ = notHappyAtAll + +happyReduce_96 = happySpecReduce_1 39 happyReduction_96 +happyReduction_96 (HappyAbsSyn27 happy_var_1) + = HappyAbsSyn31 + ([C.TMeasure happy_var_1] + ) +happyReduction_96 _ = notHappyAtAll + +happyReduce_97 = happySpecReduce_1 39 happyReduction_97 +happyReduction_97 (HappyAbsSyn29 happy_var_1) + = HappyAbsSyn31 + ([C.TBound happy_var_1] + ) +happyReduction_97 _ = notHappyAtAll + +happyReduce_98 = happySpecReduce_1 39 happyReduction_98 +happyReduction_98 (HappyAbsSyn31 happy_var_1) + = HappyAbsSyn31 + (happy_var_1 + ) +happyReduction_98 _ = notHappyAtAll + +happyReduce_99 = happySpecReduce_1 40 happyReduction_99 +happyReduction_99 (HappyAbsSyn28 happy_var_1) + = HappyAbsSyn40 + (foldr1 C.Pair happy_var_1 + ) +happyReduction_99 _ = notHappyAtAll + +happyReduce_100 = happySpecReduce_1 41 happyReduction_100 +happyReduction_100 (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn28 + ([happy_var_1] + ) +happyReduction_100 _ = notHappyAtAll + +happyReduce_101 = happySpecReduce_3 41 happyReduction_101 +happyReduction_101 (HappyAbsSyn28 happy_var_3) + _ + (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn28 + (happy_var_1 : happy_var_3 + ) +happyReduction_101 _ _ _ = notHappyAtAll + +happyReduce_102 = happySpecReduce_3 42 happyReduction_102 +happyReduction_102 (HappyAbsSyn40 happy_var_3) + _ + (HappyAbsSyn31 happy_var_1) + = HappyAbsSyn40 + (C.Quant A.Pi happy_var_1 happy_var_3 + ) +happyReduction_102 _ _ _ = notHappyAtAll + +happyReduce_103 = happyReduce 4 42 happyReduction_103 +happyReduction_103 ((HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn22 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn40 + (foldr C.Lam happy_var_4 happy_var_2 + ) `HappyStk` happyRest + +happyReduce_104 = happyReduce 4 42 happyReduction_104 +happyReduction_104 ((HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn18 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn40 + (C.LLet happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_105 = happyReduce 6 42 happyReduction_105 +happyReduction_105 (_ `HappyStk` + (HappyAbsSyn54 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyAbsSyn20 happy_var_3) `HappyStk` + (HappyAbsSyn40 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn40 + (C.Case happy_var_2 happy_var_3 happy_var_5 + ) `HappyStk` happyRest + +happyReduce_106 = happySpecReduce_1 42 happyReduction_106 +happyReduction_106 (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn40 + (happy_var_1 + ) +happyReduction_106 _ = notHappyAtAll + +happyReduce_107 = happySpecReduce_3 42 happyReduction_107 +happyReduction_107 (HappyAbsSyn40 happy_var_3) + _ + (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn40 + (C.Plus happy_var_1 happy_var_3 + ) +happyReduction_107 _ _ _ = notHappyAtAll + +happyReduce_108 = happySpecReduce_3 42 happyReduction_108 +happyReduction_108 (HappyAbsSyn40 happy_var_3) + _ + (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn40 + (C.App happy_var_1 [happy_var_3] + ) +happyReduction_108 _ _ _ = notHappyAtAll + +happyReduce_109 = happySpecReduce_3 42 happyReduction_109 +happyReduction_109 (HappyAbsSyn40 happy_var_3) + _ + (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn40 + (C.App happy_var_3 [happy_var_1] + ) +happyReduction_109 _ _ _ = notHappyAtAll + +happyReduce_110 = happySpecReduce_1 43 happyReduction_110 +happyReduction_110 (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn40 + (happy_var_1 + ) +happyReduction_110 _ = notHappyAtAll + +happyReduce_111 = happySpecReduce_3 43 happyReduction_111 +happyReduction_111 (HappyAbsSyn40 happy_var_3) + _ + (HappyAbsSyn32 happy_var_1) + = HappyAbsSyn40 + (C.Quant A.Sigma [happy_var_1] happy_var_3 + ) +happyReduction_111 _ _ _ = notHappyAtAll + +happyReduce_112 = happySpecReduce_1 44 happyReduction_112 +happyReduction_112 (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn32 + (C.TBind (Dec Default) {- A.defaultDec -} [] happy_var_1 + ) +happyReduction_112 _ = notHappyAtAll + +happyReduce_113 = happySpecReduce_3 44 happyReduction_113 +happyReduction_113 _ + (HappyAbsSyn40 happy_var_2) + _ + = HappyAbsSyn32 + (C.TBind A.irrelevantDec [] happy_var_2 + ) +happyReduction_113 _ _ _ = notHappyAtAll + +happyReduce_114 = happySpecReduce_2 44 happyReduction_114 +happyReduction_114 (HappyAbsSyn40 happy_var_2) + (HappyAbsSyn26 happy_var_1) + = HappyAbsSyn32 + (C.TBind (Dec happy_var_1) [] happy_var_2 + ) +happyReduction_114 _ _ = notHappyAtAll + +happyReduce_115 = happySpecReduce_1 44 happyReduction_115 +happyReduction_115 (HappyAbsSyn32 happy_var_1) + = HappyAbsSyn32 + (happy_var_1 + ) +happyReduction_115 _ = notHappyAtAll + +happyReduce_116 = happySpecReduce_1 44 happyReduction_116 +happyReduction_116 (HappyAbsSyn27 happy_var_1) + = HappyAbsSyn32 + (C.TMeasure happy_var_1 + ) +happyReduction_116 _ = notHappyAtAll + +happyReduce_117 = happySpecReduce_1 44 happyReduction_117 +happyReduction_117 (HappyAbsSyn29 happy_var_1) + = HappyAbsSyn32 + (C.TBound happy_var_1 + ) +happyReduction_117 _ = notHappyAtAll + +happyReduce_118 = happySpecReduce_1 45 happyReduction_118 +happyReduction_118 (HappyAbsSyn28 happy_var_1) + = HappyAbsSyn40 + (let (f : args) = reverse happy_var_1 in + if null args then f else C.App f args + ) +happyReduction_118 _ = notHappyAtAll + +happyReduce_119 = happySpecReduce_2 45 happyReduction_119 +happyReduction_119 (HappyAbsSyn40 happy_var_2) + _ + = HappyAbsSyn40 + (C.CoSet happy_var_2 + ) +happyReduction_119 _ _ = notHappyAtAll + +happyReduce_120 = happySpecReduce_1 45 happyReduction_120 +happyReduction_120 _ + = HappyAbsSyn40 + (C.Set C.Zero + ) + +happyReduce_121 = happySpecReduce_2 45 happyReduction_121 +happyReduction_121 (HappyAbsSyn40 happy_var_2) + _ + = HappyAbsSyn40 + (C.Set happy_var_2 + ) +happyReduction_121 _ _ = notHappyAtAll + +happyReduce_122 = happySpecReduce_3 45 happyReduction_122 +happyReduction_122 (HappyAbsSyn40 happy_var_3) + _ + (HappyTerminal (T.Number happy_var_1 _)) + = HappyAbsSyn40 + (let n = read happy_var_1 in + if n==0 then C.Zero else + iterate (C.Plus happy_var_3) happy_var_3 !! (n-1) + ) +happyReduction_122 _ _ _ = notHappyAtAll + +happyReduce_123 = happySpecReduce_1 46 happyReduction_123 +happyReduction_123 (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn28 + ([happy_var_1] + ) +happyReduction_123 _ = notHappyAtAll + +happyReduce_124 = happySpecReduce_2 46 happyReduction_124 +happyReduction_124 (HappyAbsSyn40 happy_var_2) + (HappyAbsSyn28 happy_var_1) + = HappyAbsSyn28 + (happy_var_2 : happy_var_1 + ) +happyReduction_124 _ _ = notHappyAtAll + +happyReduce_125 = happySpecReduce_3 46 happyReduction_125 +happyReduction_125 (HappyAbsSyn23 happy_var_3) + _ + (HappyAbsSyn28 happy_var_1) + = HappyAbsSyn28 + (C.Proj happy_var_3 : happy_var_1 + ) +happyReduction_125 _ _ _ = notHappyAtAll + +happyReduce_126 = happySpecReduce_2 46 happyReduction_126 +happyReduction_126 _ + (HappyAbsSyn28 happy_var_1) + = HappyAbsSyn28 + (C.Set C.Zero : happy_var_1 + ) +happyReduction_126 _ _ = notHappyAtAll + +happyReduce_127 = happySpecReduce_1 47 happyReduction_127 +happyReduction_127 _ + = HappyAbsSyn40 + (C.Size + ) + +happyReduce_128 = happySpecReduce_1 47 happyReduction_128 +happyReduction_128 _ + = HappyAbsSyn40 + (C.Max + ) + +happyReduce_129 = happySpecReduce_1 47 happyReduction_129 +happyReduction_129 _ + = HappyAbsSyn40 + (C.Infty + ) + +happyReduce_130 = happySpecReduce_1 47 happyReduction_130 +happyReduction_130 (HappyAbsSyn48 happy_var_1) + = HappyAbsSyn40 + (C.Ident happy_var_1 + ) +happyReduction_130 _ = notHappyAtAll + +happyReduce_131 = happyReduce 5 47 happyReduction_131 +happyReduction_131 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn40 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn40 + (C.Sing happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_132 = happySpecReduce_3 47 happyReduction_132 +happyReduction_132 _ + (HappyAbsSyn40 happy_var_2) + _ + = HappyAbsSyn40 + (happy_var_2 + ) +happyReduction_132 _ _ _ = notHappyAtAll + +happyReduce_133 = happySpecReduce_1 47 happyReduction_133 +happyReduction_133 _ + = HappyAbsSyn40 + (C.Unknown + ) + +happyReduce_134 = happySpecReduce_2 47 happyReduction_134 +happyReduction_134 (HappyAbsSyn40 happy_var_2) + _ + = HappyAbsSyn40 + (C.Succ happy_var_2 + ) +happyReduction_134 _ _ = notHappyAtAll + +happyReduce_135 = happySpecReduce_1 47 happyReduction_135 +happyReduction_135 (HappyTerminal (T.Number happy_var_1 _)) + = HappyAbsSyn40 + (iterate C.Succ C.Zero !! (read happy_var_1) + ) +happyReduction_135 _ = notHappyAtAll + +happyReduce_136 = happyReduce 4 47 happyReduction_136 +happyReduction_136 (_ `HappyStk` + (HappyAbsSyn49 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn40 + (C.Record happy_var_3 + ) `HappyStk` happyRest + +happyReduce_137 = happySpecReduce_1 48 happyReduction_137 +happyReduction_137 (HappyTerminal (T.QualId happy_var_1 _)) + = HappyAbsSyn48 + (let (m,n) = happy_var_1 in C.Qual (C.Name m) (C.Name n) + ) +happyReduction_137 _ = notHappyAtAll + +happyReduce_138 = happySpecReduce_1 48 happyReduction_138 +happyReduction_138 (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn48 + (C.QName happy_var_1 + ) +happyReduction_138 _ = notHappyAtAll + +happyReduce_139 = happySpecReduce_3 49 happyReduction_139 +happyReduction_139 (HappyAbsSyn49 happy_var_3) + _ + (HappyAbsSyn50 happy_var_1) + = HappyAbsSyn49 + (happy_var_1 : happy_var_3 + ) +happyReduction_139 _ _ _ = notHappyAtAll + +happyReduce_140 = happySpecReduce_1 49 happyReduction_140 +happyReduction_140 (HappyAbsSyn50 happy_var_1) + = HappyAbsSyn49 + ([happy_var_1] + ) +happyReduction_140 _ = notHappyAtAll + +happyReduce_141 = happySpecReduce_0 49 happyReduction_141 +happyReduction_141 = HappyAbsSyn49 + ([] + ) + +happyReduce_142 = happySpecReduce_3 50 happyReduction_142 +happyReduction_142 (HappyAbsSyn40 happy_var_3) + _ + (HappyAbsSyn22 happy_var_1) + = HappyAbsSyn50 + ((happy_var_1,happy_var_3) + ) +happyReduction_142 _ _ _ = notHappyAtAll + +happyReduce_143 = happySpecReduce_3 51 happyReduction_143 +happyReduction_143 (HappyAbsSyn40 happy_var_3) + _ + (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn51 + (C.TypeSig happy_var_1 happy_var_3 + ) +happyReduction_143 _ _ _ = notHappyAtAll + +happyReduce_144 = happyReduce 4 52 happyReduction_144 +happyReduction_144 ((HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn31 happy_var_2) `HappyStk` + (HappyAbsSyn23 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn52 + (C.Constructor happy_var_1 happy_var_2 (Just happy_var_4) + ) `HappyStk` happyRest + +happyReduce_145 = happySpecReduce_2 52 happyReduction_145 +happyReduction_145 (HappyAbsSyn31 happy_var_2) + (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn52 + (C.Constructor happy_var_1 happy_var_2 Nothing + ) +happyReduction_145 _ _ = notHappyAtAll + +happyReduce_146 = happySpecReduce_3 53 happyReduction_146 +happyReduction_146 (HappyAbsSyn52 happy_var_3) + _ + (HappyAbsSyn53 happy_var_1) + = HappyAbsSyn53 + (happy_var_3 : happy_var_1 + ) +happyReduction_146 _ _ _ = notHappyAtAll + +happyReduce_147 = happySpecReduce_2 53 happyReduction_147 +happyReduction_147 _ + (HappyAbsSyn53 happy_var_1) + = HappyAbsSyn53 + (happy_var_1 + ) +happyReduction_147 _ _ = notHappyAtAll + +happyReduce_148 = happySpecReduce_1 53 happyReduction_148 +happyReduction_148 (HappyAbsSyn52 happy_var_1) + = HappyAbsSyn53 + ([happy_var_1] + ) +happyReduction_148 _ = notHappyAtAll + +happyReduce_149 = happySpecReduce_0 53 happyReduction_149 +happyReduction_149 = HappyAbsSyn53 + ([] + ) + +happyReduce_150 = happyReduce 5 54 happyReduction_150 +happyReduction_150 ((HappyAbsSyn54 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyAbsSyn40 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyAbsSyn58 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn54 + ((C.Clause Nothing [happy_var_1] (Just happy_var_3)) : happy_var_5 + ) `HappyStk` happyRest + +happyReduce_151 = happySpecReduce_3 54 happyReduction_151 +happyReduction_151 (HappyAbsSyn40 happy_var_3) + _ + (HappyAbsSyn58 happy_var_1) + = HappyAbsSyn54 + ((C.Clause Nothing [happy_var_1] (Just happy_var_3)) : [] + ) +happyReduction_151 _ _ _ = notHappyAtAll + +happyReduce_152 = happySpecReduce_3 54 happyReduction_152 +happyReduction_152 (HappyAbsSyn54 happy_var_3) + _ + (HappyAbsSyn58 happy_var_1) + = HappyAbsSyn54 + ((C.Clause Nothing [happy_var_1] Nothing) : happy_var_3 + ) +happyReduction_152 _ _ _ = notHappyAtAll + +happyReduce_153 = happySpecReduce_1 54 happyReduction_153 +happyReduction_153 (HappyAbsSyn58 happy_var_1) + = HappyAbsSyn54 + ((C.Clause Nothing [happy_var_1] Nothing) : [] + ) +happyReduction_153 _ = notHappyAtAll + +happyReduce_154 = happySpecReduce_0 54 happyReduction_154 +happyReduction_154 = HappyAbsSyn54 + ([] + ) + +happyReduce_155 = happyReduce 4 55 happyReduction_155 +happyReduction_155 ((HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn56 happy_var_2) `HappyStk` + (HappyAbsSyn23 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn55 + (C.Clause (Just happy_var_1) happy_var_2 (Just happy_var_4) + ) `HappyStk` happyRest + +happyReduce_156 = happySpecReduce_2 55 happyReduction_156 +happyReduction_156 (HappyAbsSyn56 happy_var_2) + (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn55 + (C.Clause (Just happy_var_1) happy_var_2 Nothing + ) +happyReduction_156 _ _ = notHappyAtAll + +happyReduce_157 = happySpecReduce_1 56 happyReduction_157 +happyReduction_157 (HappyAbsSyn56 happy_var_1) + = HappyAbsSyn56 + (reverse happy_var_1 + ) +happyReduction_157 _ = notHappyAtAll + +happyReduce_158 = happySpecReduce_0 57 happyReduction_158 +happyReduction_158 = HappyAbsSyn56 + ([] + ) + +happyReduce_159 = happySpecReduce_2 57 happyReduction_159 +happyReduction_159 (HappyAbsSyn58 happy_var_2) + (HappyAbsSyn56 happy_var_1) + = HappyAbsSyn56 + (happy_var_2 : happy_var_1 + ) +happyReduction_159 _ _ = notHappyAtAll + +happyReduce_160 = happySpecReduce_3 57 happyReduction_160 +happyReduction_160 (HappyAbsSyn58 happy_var_3) + _ + (HappyAbsSyn56 happy_var_1) + = HappyAbsSyn56 + (happy_var_3 : happy_var_1 + ) +happyReduction_160 _ _ _ = notHappyAtAll + +happyReduce_161 = happySpecReduce_2 58 happyReduction_161 +happyReduction_161 _ + _ + = HappyAbsSyn58 + (C.AbsurdP + ) + +happyReduce_162 = happySpecReduce_3 58 happyReduction_162 +happyReduction_162 _ + (HappyAbsSyn58 happy_var_2) + _ + = HappyAbsSyn58 + (happy_var_2 + ) +happyReduction_162 _ _ _ = notHappyAtAll + +happyReduce_163 = happySpecReduce_1 58 happyReduction_163 +happyReduction_163 (HappyAbsSyn58 happy_var_1) + = HappyAbsSyn58 + (happy_var_1 + ) +happyReduction_163 _ = notHappyAtAll + +happyReduce_164 = happySpecReduce_2 58 happyReduction_164 +happyReduction_164 (HappyAbsSyn58 happy_var_2) + _ + = HappyAbsSyn58 + (C.SuccP happy_var_2 + ) +happyReduction_164 _ _ = notHappyAtAll + +happyReduce_165 = happySpecReduce_2 58 happyReduction_165 +happyReduction_165 _ + _ + = HappyAbsSyn58 + (C.DotP (C.Set C.Zero) + ) + +happyReduce_166 = happySpecReduce_2 58 happyReduction_166 +happyReduction_166 (HappyAbsSyn40 happy_var_2) + _ + = HappyAbsSyn58 + (C.DotP happy_var_2 + ) +happyReduction_166 _ _ = notHappyAtAll + +happyReduce_167 = happySpecReduce_3 59 happyReduction_167 +happyReduction_167 (HappyAbsSyn58 happy_var_3) + _ + (HappyAbsSyn58 happy_var_1) + = HappyAbsSyn58 + (C.PairP happy_var_1 happy_var_3 + ) +happyReduction_167 _ _ _ = notHappyAtAll + +happyReduce_168 = happySpecReduce_1 59 happyReduction_168 +happyReduction_168 (HappyAbsSyn58 happy_var_1) + = HappyAbsSyn58 + (happy_var_1 + ) +happyReduction_168 _ = notHappyAtAll + +happyReduce_169 = happySpecReduce_1 60 happyReduction_169 +happyReduction_169 (HappyAbsSyn58 happy_var_1) + = HappyAbsSyn58 + (happy_var_1 + ) +happyReduction_169 _ = notHappyAtAll + +happyReduce_170 = happySpecReduce_3 60 happyReduction_170 +happyReduction_170 (HappyAbsSyn23 happy_var_3) + _ + (HappyAbsSyn40 happy_var_1) + = HappyAbsSyn58 + (C.SizeP happy_var_1 happy_var_3 + ) +happyReduction_170 _ _ _ = notHappyAtAll + +happyReduce_171 = happySpecReduce_3 60 happyReduction_171 +happyReduction_171 (HappyAbsSyn40 happy_var_3) + _ + (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn58 + (C.SizeP happy_var_3 happy_var_1 + ) +happyReduction_171 _ _ _ = notHappyAtAll + +happyReduce_172 = happySpecReduce_1 60 happyReduction_172 +happyReduction_172 (HappyAbsSyn58 happy_var_1) + = HappyAbsSyn58 + (happy_var_1 + ) +happyReduction_172 _ = notHappyAtAll + +happyReduce_173 = happySpecReduce_3 60 happyReduction_173 +happyReduction_173 (HappyAbsSyn58 happy_var_3) + _ + (HappyAbsSyn58 happy_var_1) + = HappyAbsSyn58 + (patApp happy_var_1 [happy_var_3] + ) +happyReduction_173 _ _ _ = notHappyAtAll + +happyReduce_174 = happySpecReduce_2 61 happyReduction_174 +happyReduction_174 (HappyAbsSyn58 happy_var_2) + (HappyAbsSyn58 happy_var_1) + = HappyAbsSyn58 + (patApp happy_var_1 [happy_var_2] + ) +happyReduction_174 _ _ = notHappyAtAll + +happyReduce_175 = happySpecReduce_2 61 happyReduction_175 +happyReduction_175 (HappyAbsSyn58 happy_var_2) + (HappyAbsSyn58 happy_var_1) + = HappyAbsSyn58 + (patApp happy_var_1 [happy_var_2] + ) +happyReduction_175 _ _ = notHappyAtAll + +happyReduce_176 = happySpecReduce_1 62 happyReduction_176 +happyReduction_176 (HappyAbsSyn23 happy_var_1) + = HappyAbsSyn58 + (C.IdentP (C.QName happy_var_1) + ) +happyReduction_176 _ = notHappyAtAll + +happyReduce_177 = happySpecReduce_2 62 happyReduction_177 +happyReduction_177 (HappyAbsSyn23 happy_var_2) + _ + = HappyAbsSyn58 + (C.ConP True (C.QName happy_var_2) [] + ) +happyReduction_177 _ _ = notHappyAtAll + +happyReduce_178 = happySpecReduce_1 63 happyReduction_178 +happyReduction_178 (HappyAbsSyn64 happy_var_1) + = HappyAbsSyn54 + (reverse happy_var_1 + ) +happyReduction_178 _ = notHappyAtAll + +happyReduce_179 = happySpecReduce_3 64 happyReduction_179 +happyReduction_179 (HappyAbsSyn55 happy_var_3) + _ + (HappyAbsSyn64 happy_var_1) + = HappyAbsSyn64 + (happy_var_3 : happy_var_1 + ) +happyReduction_179 _ _ _ = notHappyAtAll + +happyReduce_180 = happySpecReduce_2 64 happyReduction_180 +happyReduction_180 _ + (HappyAbsSyn64 happy_var_1) + = HappyAbsSyn64 + (happy_var_1 + ) +happyReduction_180 _ _ = notHappyAtAll + +happyReduce_181 = happySpecReduce_1 64 happyReduction_181 +happyReduction_181 (HappyAbsSyn55 happy_var_1) + = HappyAbsSyn64 + ([happy_var_1] + ) +happyReduction_181 _ = notHappyAtAll + +happyReduce_182 = happySpecReduce_0 64 happyReduction_182 +happyReduction_182 = HappyAbsSyn64 + ([] + ) + +happyReduce_183 = happyReduce 5 65 happyReduction_183 +happyReduction_183 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn22 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBind (Dec Default) happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_184 = happyReduce 5 65 happyReduction_184 +happyReduction_184 (_ `HappyStk` + (HappyAbsSyn40 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn22 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBind A.irrelevantDec happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_185 = happyReduce 6 65 happyReduction_185 +happyReduction_185 (_ `HappyStk` + (HappyAbsSyn40 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyAbsSyn22 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyAbsSyn26 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBind (Dec happy_var_1) happy_var_3 happy_var_5 + ) `HappyStk` happyRest + +happyReduce_186 = happyReduce 6 65 happyReduction_186 +happyReduction_186 (_ `HappyStk` + (HappyAbsSyn40 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyAbsSyn22 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn32 + (C.TBind (Dec SPos) happy_var_3 happy_var_5 + ) `HappyStk` happyRest + +happyReduce_187 = happySpecReduce_0 66 happyReduction_187 +happyReduction_187 = HappyAbsSyn31 + ([] + ) + +happyReduce_188 = happySpecReduce_2 66 happyReduction_188 +happyReduction_188 (HappyAbsSyn31 happy_var_2) + (HappyAbsSyn32 happy_var_1) + = HappyAbsSyn31 + (happy_var_1 : happy_var_2 + ) +happyReduction_188 _ _ = notHappyAtAll + +happyNewToken action sts stk [] = + action 122 122 notHappyAtAll (HappyState action) sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = action i i tk (HappyState action) sts stk tks in + case tk of { + T.Id happy_dollar_dollar _ -> cont 67; + T.QualId happy_dollar_dollar _ -> cont 68; + T.Number happy_dollar_dollar _ -> cont 69; + T.Data _ -> cont 70; + T.CoData _ -> cont 71; + T.Record _ -> cont 72; + T.Sized _ -> cont 73; + T.Fields _ -> cont 74; + T.Mutual _ -> cont 75; + T.Fun _ -> cont 76; + T.CoFun _ -> cont 77; + T.Pattern _ -> cont 78; + T.Case _ -> cont 79; + T.Def _ -> cont 80; + T.Let _ -> cont 81; + T.In _ -> cont 82; + T.Eval _ -> cont 83; + T.Fail _ -> cont 84; + T.Check _ -> cont 85; + T.TrustMe _ -> cont 86; + T.Impredicative _ -> cont 87; + T.Type _ -> cont 88; + T.Set _ -> cont 89; + T.CoSet _ -> cont 90; + T.Size _ -> cont 91; + T.Infty _ -> cont 92; + T.Succ _ -> cont 93; + T.Max _ -> cont 94; + T.LTri _ -> cont 95; + T.RTri _ -> cont 96; + T.AngleOpen _ -> cont 97; + T.AngleClose _ -> cont 98; + T.BrOpen _ -> cont 99; + T.BrClose _ -> cont 100; + T.BracketOpen _ -> cont 101; + T.BracketClose _ -> cont 102; + T.PrOpen _ -> cont 103; + T.PrClose _ -> cont 104; + T.Bar _ -> cont 105; + T.Comma _ -> cont 106; + T.Sem _ -> cont 107; + T.Col _ -> cont 108; + T.Dot _ -> cont 109; + T.Arrow _ -> cont 110; + T.Leq _ -> cont 111; + T.Eq _ -> cont 112; + T.PlusPlus _ -> cont 113; + T.Plus _ -> cont 114; + T.Minus _ -> cont 115; + T.Slash _ -> cont 116; + T.Times _ -> cont 117; + T.Hat _ -> cont 118; + T.Amp _ -> cont 119; + T.Lam _ -> cont 120; + T.Underscore _ -> cont 121; + _ -> happyError' (tk:tks) + } + +happyError_ 122 tk tks = happyError' tks +happyError_ _ tk tks = happyError' (tk:tks) + +newtype HappyIdentity a = HappyIdentity a +happyIdentity = HappyIdentity +happyRunIdentity (HappyIdentity a) = a + +instance Functor HappyIdentity where + fmap f (HappyIdentity a) = HappyIdentity (f a) + +instance Applicative HappyIdentity where + pure = return + (<*>) = ap +instance Monad HappyIdentity where + return = HappyIdentity + (HappyIdentity p) >>= q = q p + +happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b +happyThen = (>>=) +happyReturn :: () => a -> HappyIdentity a +happyReturn = (return) +happyThen1 m k tks = (>>=) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> HappyIdentity a +happyReturn1 = \a tks -> (return) a +happyError' :: () => [(T.Token)] -> HappyIdentity a +happyError' = HappyIdentity . parseError + +parse tks = happyRunIdentity happySomeParser where + happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll }) + +happySeq = happyDontSeq + + +parseError :: [T.Token] -> a +parseError [] = error "Parse error at EOF" +parseError (x : xs) = error ("Parse error at token " ++ T.prettyTok x) +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} + + + + + + + +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{-# LINE 7 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 13 "templates/GenericTemplate.hs" #-} + +{-# LINE 46 "templates/GenericTemplate.hs" #-} + + + + + + + + +{-# LINE 67 "templates/GenericTemplate.hs" #-} + +{-# LINE 77 "templates/GenericTemplate.hs" #-} + +{-# LINE 86 "templates/GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is (1), it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + +{-# LINE 155 "templates/GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + + + +newtype HappyState b c = HappyState + (Int -> -- token number + Int -> -- token number (yes, again) + b -> -- token semantic value + HappyState b c -> -- current state + [HappyState b c] -> -- state stack + c) + + + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state (1) tk st sts stk@(x `HappyStk` _) = + let i = (case x of { HappyErrorToken (i) -> i }) in +-- trace "shifting the error token" $ + new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk + = action nt j tk st ((st):(sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (action nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k - ((1) :: Int)) sts of + sts1@(((st1@(HappyState (action))):(_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (action nt j tk st1 sts1 r) + +happyMonadReduce k nt fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + case happyDrop k ((st):(sts)) of + sts1@(((st1@(HappyState (action))):(_))) -> + let drop_stk = happyDropStk k stk in + happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) + +happyMonad2Reduce k nt fn (1) tk st sts stk + = happyFail (1) tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + case happyDrop k ((st):(sts)) of + sts1@(((st1@(HappyState (action))):(_))) -> + let drop_stk = happyDropStk k stk + + + + + + new_state = action + + in + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + +happyDrop (0) l = l +happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t + +happyDropStk (0) l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + +{-# LINE 256 "templates/GenericTemplate.hs" #-} +happyGoto action j tk st = action j j tk (HappyState action) + + +----------------------------------------------------------------------------- +-- Error recovery ((1) is the error token) + +-- parse error if we are in recovery and we fail again +happyFail (1) tk old_st _ stk@(x `HappyStk` _) = + let i = (case x of { HappyErrorToken (i) -> i }) in +-- trace "failing" $ + happyError_ i tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail (1) tk old_st (((HappyState (action))):(sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (HappyState (action)) sts stk = +-- trace "entering error recovery" $ + action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + + + + + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + +{-# LINE 322 "templates/GenericTemplate.hs" #-} +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/src/Parser.y b/src/Parser.y new file mode 100644 --- /dev/null +++ b/src/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/src/Polarity.hs b/src/Polarity.hs new file mode 100644 --- /dev/null +++ b/src/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/src/PrettyTCM.hs b/src/PrettyTCM.hs new file mode 100644 --- /dev/null +++ b/src/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/src/ScopeChecker.hs b/src/ScopeChecker.hs new file mode 100644 --- /dev/null +++ b/src/ScopeChecker.hs @@ -0,0 +1,1124 @@ +-- NOTE: insertion of polarity variables disabled here, must be done +-- in TypeChecker + +{-# LANGUAGE TupleSections, DeriveFunctor, GeneralizedNewtypeDeriving, + FlexibleContexts, FlexibleInstances, UndecidableInstances, + MultiParamTypeClasses #-} + +module ScopeChecker (scopeCheck) where + +import Prelude hiding (mapM, null) + +import Control.Applicative +import Control.Monad.Identity hiding (mapM) +import Control.Monad.Reader hiding (mapM) +import Control.Monad.State hiding (mapM) +import Control.Monad.Except hiding (mapM) + +import Data.List as List hiding (null) +import Data.Maybe +import Data.Traversable (mapM) + +import Debug.Trace + +import Polarity(Pol(..)) +import qualified Polarity as A +import Abstract (Sized,mkExtRef,Co,ConK(..),PrePost(..),MVar,Decoration(..),Override(..),Measure(..),adjustTopDecsM,Arity,polarity,LensPol(..)) +import qualified Abstract as A +import qualified Concrete as C + +import TraceError + +import Util + +-- * scope checker +-- check that all identifiers are in scope and global identifiers are only used once +-- replaces Ident with Con, Def, Let or Var +-- replaces IdentP with ConP or VarP in patterns +-- replaces Unknown by a new Meta-Variable +-- check pattern length is equal in each clause +-- group mutual declarations + +-- | Entry point for scope checker. +scopeCheck :: [C.Declaration] -> Either TraceError ([A.Declaration],SCState) +scopeCheck dl = runScopeCheck initCtx initSt (scopeCheckDecls dl) + +-- * Local identifiers. + +-- ** local environment of scope checker + +data SCCxt = SCCxt + { stack :: Stack -- ^ Local names in scope. + -- We keep a stack of these to disallow shadowing on the same level. + , defaultPolarity :: Pol -- ^ Replacement for @Default@ polarity. + , constraintAllowed :: Bool -- ^ Is a constraint @|m| < |m'|@ legal now, since we just parsed a quantifier? + } + +type Stack = [Context] + +initCtx :: SCCxt +initCtx = SCCxt + { stack = [[]] -- one empty context to begin with + , defaultPolarity = A.Rec -- POL VARS DISABLED!! + , constraintAllowed = False + } + +-- ** A lens for @constraintAllowed@ + +class LensConstraintAllowed a where + mapConstraintAllowed :: (Bool -> Bool) -> a -> a + setConstraintAllowed :: Bool -> a -> a + setConstraintAllowed b = mapConstraintAllowed (const b) + +instance LensConstraintAllowed SCCxt where + mapConstraintAllowed f sc = sc { constraintAllowed = f (constraintAllowed sc) } + +instance (LensConstraintAllowed r, MonadReader r m) => LensConstraintAllowed (m a) where + mapConstraintAllowed f = local (mapConstraintAllowed f) + +-- ** Managing the stack of local contexts. + +newLevel :: ScopeCheck a -> ScopeCheck a +newLevel = local $ \ cxt -> cxt { stack = [] : stack cxt } + +thisLevel :: SCCxt -> Context +thisLevel cxt = head (stack cxt) + +instance Push Local SCCxt where + push nx sc = sc { stack = push nx (stack sc) } + +-- ** translating concrete names to abstract names + +type Local = (C.Name,A.Name) +type Context = [Local] + +emptyCtx :: Context +emptyCtx = [] + +newLocal :: Push Local b => C.Name -> b -> (A.Name, b) +newLocal n cxt = (x, push (n, x) cxt) + where x = A.fresh $ C.theName n + +lookupLocal :: C.Name -> ScopeCheck (Maybe A.Name) +lookupLocal n = retrieve n <$> asks stack + +lookupGlobal :: C.QName -> ScopeCheck (Maybe DefI) +lookupGlobal n = lookupSig n <$> getSig + +addContext :: Context -> SCCxt -> SCCxt +addContext delta sc = sc { stack = delta : stack sc } + +-- * Global identifiers. + +-- | Kind of identifier. +data IKind + = DataK + | ConK ConK + | FunK Bool -- ^ @False@ = inside body, @True@ = outside body + | ProjK -- ^ a record projection + | LetK + +-- | Global identifier. +data DefI = DefI { ikind :: IKind, aname :: A.QName } + +-- | Scope check signature. +type Sig = [(C.QName,DefI)] + +emptySig :: Sig +emptySig = [] + +lookupSigU :: C.Name -> Sig -> Maybe DefI +lookupSigU n = lookupSig (C.QName n) + +lookupSig :: C.QName -> Sig -> Maybe DefI +lookupSig n [] = Nothing +lookupSig n ((x,k):xs) = if (x == n) then Just k else lookupSig n xs + +-- ** State of scope checker. + +data SCState = SCState + { signature :: Sig + , nextMeta :: MVar + , nextPolVar :: MVar + } + +initSt = SCState emptySig 0 0 + +-- * The scope checking monad. + +-- | Scope checking monad. +-- +-- Reader monad for local environment of variables (used in expresssions and patterns). +-- State monad (hidden) for global signature. +-- Error monad for reporting scope violations. +newtype ScopeCheck a = ScopeCheck { unScopeCheck :: + ReaderT SCCxt (StateT SCState (ExceptT TraceError Identity)) a } + deriving (Functor, Applicative, Monad, + MonadReader SCCxt, MonadError TraceError) + +runScopeCheck + :: SCCxt -- ^ Local variable mapping. + -> SCState -- ^ Global identifier mapping. + -> ScopeCheck a -- ^ The computation. + -> Either TraceError (a, SCState) +runScopeCheck ctx st (ScopeCheck sc) = runIdentity $ runExceptT $ + runStateT (runReaderT sc ctx) st + +-- ** Local state. + +-- | Add a local identifier. +-- (Not tail recursive, since it also returns the generate id.) +addBind' :: Show e => e -> C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck (A.Name, a) +addBind' e n k = do + ctx <- ask + case retrieve n (thisLevel ctx) of + Just _ -> errorAlreadyInContext e n + Nothing -> do + let (x, ctx') = newLocal n ctx -- addCtx' n ctx + a <- local (const ctx') $ k x + return (x, a) + +addBind :: Show e => e -> C.Name -> ScopeCheck a -> ScopeCheck (A.Name, a) +addBind e n k = addBind' e n $ const k + +addBinds :: Show e => e -> [C.Name] -> ScopeCheck a -> ScopeCheck ([A.Name], a) +addBinds e ns k = foldr step start ns where + start = do + a <- k + return ([], a) + step n k = do + (x, (xs, a)) <- addBind e n k + return (x:xs, a) + +-- | Add local variable without checking shadowing. +addLocal :: C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck a +addLocal n k = do + ctx <- ask + let (x, ctx') = newLocal n ctx + local (const ctx') $ k x + +addTel :: C.Telescope -> A.Telescope -> ScopeCheck a -> ScopeCheck a +addTel ctel atel = local (addContext nxs) + where nxs = reverse $ zipTels ctel atel + +zipTels :: C.Telescope -> A.Telescope -> [(C.Name,A.Name)] +zipTels ctel atel = zip ns xs + where ns = collectTelescopeNames ctel + xs = map A.boundName $ A.telescope atel + +-- ** Global state. + +getSig :: ScopeCheck Sig +getSig = ScopeCheck $ gets signature + +-- | Add a global identifier. +addName :: IKind -> C.Name -> ScopeCheck A.Name +addName k n = do + sig <- getSig + when (isJust (lookupSig (C.QName n) sig)) $ + errorAlreadyInSignature "shadowing of global definitions forbidden" n + let x = A.fresh $ C.theName n + addANameU k n x + return x + +-- addNameU :: IKind -> C.Name -> ScopeCheck A.Name +-- addNameU k n = A.unqual <$> addName k (C.QName n) + +-- | Add an already translated global identifier. +addAName :: IKind -> C.QName -> A.QName -> ScopeCheck () +addAName k n x = ScopeCheck $ modify $ \ st -> + st { signature = (n, DefI k x) : signature st } + +addANameU :: IKind -> C.Name -> A.Name -> ScopeCheck () +addANameU ki n x = addAName ki (C.QName n) (A.QName x) + +-- | Add or reuse an unqualified name. +overloadName :: IKind -> C.Name -> ScopeCheck A.Name +overloadName k n = do + sig <- getSig + case lookupSigU n sig of + Nothing -> do + let x = A.fresh $ C.theName n + addANameU k n x + return x + Just (DefI k' (A.QName x)) -> return x + +{- UNUSED +addDecl :: C.Declaration -> ScopeCheck A.Name +addDecl (C.DataDecl n _ _ _ _ _ _) = addName DataK n +addDecl (C.RecordDecl n _ _ _ _) = addName DataK n +-} +{- UNUSED +addFunDecl :: Bool -> C.Declaration -> ScopeCheck A.Name +addFunDecl b (C.FunDecl _ ts _) = addTypeSig (FunK b) ts +-} + +addTypeSig :: IKind -> C.TypeSig -> A.TypeSig -> ScopeCheck () +addTypeSig kind (C.TypeSig n _) (A.TypeSig x _) = addANameU kind n x + +{- UNUSED +-- | Add a global identifier. Fail if already in signature. +addGlobal :: Show d => d -> IKind -> C.Name -> ScopeCheck A.Name +addGlobal d k n = enterShow n $ do + sig <- getSig + case lookupSig n sig of + Just _ -> errorAlreadyInSignature d n + Nothing -> addName k n +-} + +-- | Create a meta variable. +nextMVar :: (MVar -> ScopeCheck a) -> ScopeCheck a +nextMVar f = ScopeCheck $ do + st <- get + put $ st { nextMeta = nextMeta st + 1 } + unScopeCheck $ f (nextMeta st) + +-- | Create a polarity meta variable. +nextPVar :: (MVar -> ScopeCheck a) -> ScopeCheck a +nextPVar f = ScopeCheck $ do + st <- get + put $ st { nextPolVar = nextPolVar st + 1 } + unScopeCheck $ f (nextPolVar st) + +-- ** Additional services of scope monad. + +-- | Default polarity is context-sensitive. +setDefaultPolarity :: Pol -> ScopeCheck a -> ScopeCheck a +setDefaultPolarity p = local (\ sccxt -> sccxt { defaultPolarity = p }) +{- +insertingPolVars :: Bool -> ScopeCheck a -> ScopeCheck a +insertingPolVars b = local (\ sccxt -> sccxt { insertPolVars = b }) +-} + +-- | Insert polarity variables for omitted polarities. +generalizeDec :: A.Dec -> ScopeCheck A.Dec +generalizeDec dec@A.Hidden = return dec +generalizeDec dec@A.Dec{} = + if (polarity dec == Default) then do + p0 <- asks defaultPolarity + case p0 of + PVar{} -> nextPVar $ \ i -> + return $ setPol (PVar i) dec + _ -> return $ setPol p0 dec + else return dec + +generalizeTBind :: C.TBind -> ScopeCheck C.TBind +generalizeTBind tb@C.TMeasure{} = return tb +generalizeTBind tb = do + dec' <- generalizeDec (C.boundDec tb) + return $ tb { C.boundDec = dec' } + +-- | Insert polarity variables in telescope. +generalizeTel :: C.Telescope -> ScopeCheck C.Telescope +generalizeTel = mapM generalizeTBind + +-- * Scope checking concrete syntax. +---------------------------------------------------------------------- + +scopeCheckDecls :: [C.Declaration] -> ScopeCheck [A.Declaration] +scopeCheckDecls = mapM scopeCheckDeclaration + +scopeCheckDeclaration :: C.Declaration -> ScopeCheck A.Declaration + +scopeCheckDeclaration (C.OverrideDecl Check ds) = ScopeCheck $ do + st <- get + as <- unScopeCheck $ scopeCheckDecls ds -- declarations need to scope check + put st -- but then forget their effect: restore old state + return $ A.OverrideDecl Check as + +scopeCheckDeclaration (C.OverrideDecl Fail ds) = ScopeCheck $ do + st <- get + as <- unScopeCheck $ scopeCheckDecls ds + `catchError` (const $ return []) --on error discard block + put st + return $ A.OverrideDecl Fail as +{- +scopeCheckDeclaration (C.OverrideDecl Fail ds) = do + st <- get + (as,st') <- (do as <- scopeCheckDecls ds + st' <- get + return (as,st')) + `catchError` (const $ return ([],st)) --on error discard block + put st' + return $ A.OverrideDecl Fail as +-} +scopeCheckDeclaration (C.OverrideDecl override ds) = do -- TrustMe,Impredicative + as <- scopeCheckDecls ds + return $ A.OverrideDecl override as + +scopeCheckDeclaration (C.RecordDecl n tel t c fields) = + scopeCheckRecordDecl n tel t c fields + +scopeCheckDeclaration d@(C.DataDecl{}) = + scopeCheckDataDecl d -- >>= return . (:[]) + +scopeCheckDeclaration d@(C.FunDecl co _ _) = + scopeCheckFunDecls co [d] -- >>= return . (:[]) + +scopeCheckDeclaration (C.LetDecl eval letdef@C.LetDef{ C.letDefDec = dec, C.letDefName = n }) = do + unless (dec == A.defaultDec) $ + throwErrorMsg $ "polarity annotation not supported in global let definition of " ++ show n + (tel, mt, e) <- scopeCheckLetDef letdef + x <- addName LetK n + return $ A.LetDecl eval x tel mt e + +scopeCheckDeclaration d@(C.PatternDecl n ns p) = do + let errorHead = "invalid pattern declaration\n" ++ C.prettyDecl d ++ "\n" + -- check pattern + (p, delta) <- runStateT (scopeCheckPattern p) emptyCtx + p <- local (addContext delta) $ scopeCheckDotPattern p + -- ensure that pattern variables are the declared variables + unless (sort ns == sort (map fst delta)) $ do + let usedNames = map fst delta + unusedNames = ns \\ usedNames + undeclaredNames = usedNames \\ ns + when (not (null unusedNames)) $ throwErrorMsg $ + errorHead ++ "unsed variables in pattern: " + ++ Util.showList " " show unusedNames + when (not (null undeclaredNames)) $ throwErrorMsg $ + errorHead ++ "undeclared variables in pattern: " + ++ Util.showList " " show undeclaredNames + -- when (n `elem` ns) $ throwErrorMsg $ errorHead ++ "pattern" + x <- addName (ConK DefPat) n + let xs = map (fromJust . flip lookup delta) ns + return (A.PatternDecl x xs p) + +-- we support +-- - mutual (co)funs +-- - mutual (co)data + +scopeCheckDeclaration (C.MutualDecl []) = throwErrorMsg "empty mutual block" +scopeCheckDeclaration (C.MutualDecl l@(C.DataDecl{}:xl)) = + scopeCheckMutual l +scopeCheckDeclaration (C.MutualDecl l@(C.FunDecl co _ _:xl)) = + scopeCheckFunDecls co l -- >>= return . (:[]) +scopeCheckDeclaration (C.MutualDecl _) = throwErrorMsg "mutual combination not supported" + +scopeCheckLetDef :: C.LetDef -> ScopeCheck (A.Telescope, Maybe (A.Type), A.Expr) +scopeCheckLetDef (C.LetDef dec n tel mt e) = setDefaultPolarity A.Rec $ do + tel <- generalizeTel tel + (tel, (mt, e)) <- scopeCheckTele tel $ do + (,) <$> mapM scopeCheckExprN mt -- allow shadowing after : in type + <*> scopeCheckExprN e -- allow shadowing after = + return (tel, mt, e) + +{- scopeCheck Mutual block +first check signatures +then bodies +-} +scopeCheckMutual :: [C.Declaration] -> ScopeCheck A.Declaration +scopeCheckMutual ds0 = do + -- flatten nested mutual blocks and override decls + ds <- mutualFlattenDecls ds0 + -- extract, check, and add type signatures + let ktsigs = map mutualGetTypeSig ds + (mmm, tsigs') <- unzip <$> mapM checkAndAddTypeSig ktsigs + -- funs have been added with internal names + -- check that all functions are unmeasured or have a same length measure + let (ns, mll) = unzip $ compressMaybes mmm + let measured = null mll || isJust (head mll) + let ok = null mll || all ((head mll)==) (tail mll) + when (not ok) $ throwErrorMsg $ "in a mutual function block, either all functions must be without measure or have a measure of the same length" +{- + -- switch to internal fun ids + let funNames = [ n | (FunK _ , A.TypeSig n _) <- ktsigs ] -- internal fun names +{- SAME W/O COMPR + let funNames = map (\ (_, C.TypeSig n _) -> n) $ filter aux ktsigs where + aux (FunK _, _) = True + aux _ = False +-} + mapM_ (addName (FunK False)) funNames -- TODO +-} + -- check bodies of declarations + ds' <- mapM (setDefaultPolarity A.Rec . checkBody) (zip tsigs' ds) + -- switch back to external fun ids + let funNames = [ x | A.FunDecl _ (A.Fun _ x _ _) <- ds' ] -- external fun names + zipWithM_ (addANameU (LetK)) ns funNames +-- zipWithM_ (addAName (FunK True)) ns funNames + return $ A.MutualDecl measured ds' + +scopeCheckTele :: C.Telescope -> ScopeCheck a -> ScopeCheck (A.Telescope, a) +scopeCheckTele [] cont = (A.emptyTel,) <$> cont +scopeCheckTele (tb : tel) cont = do + (tbs, (A.Telescope tel, a)) <- scopeCheckTBind tb $ scopeCheckTele tel cont + return (A.Telescope $ tbs ++ tel, a) + +scopeCheckTBind :: C.TBind -> ScopeCheck a -> ScopeCheck ([A.TBind], a) +scopeCheckTBind tb cont = do + let contYes = setConstraintAllowed True cont + contNo = setConstraintAllowed False cont + case tb of + C.TBind dec [] t -> do -- non-dependent function type + t <- scopeCheckExprN t + ([A.noBind $ A.Domain t A.defaultKind dec],) <$> contNo + C.TBind dec ns t -> do + t <- scopeCheckExprN t + (xs, a) <- addBinds tb ns $ contYes + return (map (\ x -> A.TBind x (A.Domain t A.defaultKind dec)) xs, a) + C.TBounded dec n ltle e -> do + e <- scopeCheckExprN e + (x, a) <- addBind tb n $ contYes + return ([A.TBind x (A.Domain (A.Below ltle e) A.defaultKind dec)], a) + C.TMeasure mu -> do + mu <- scopeCheckMeasure mu + ([A.TMeasure mu],) <$> cont +-- C.TMeasure mu -> throwErrorMsg $ "measure not allowed in telescope" + C.TBound beta -> do + unlessM (asks constraintAllowed) $ + errorConstraintNotAllowed beta + beta <- scopeCheckBound beta + ([A.TBound beta],) <$> cont + +checkBody :: (A.TypeSig, C.Declaration) -> ScopeCheck A.Declaration +checkBody (A.TypeSig x tt, C.DataDecl n sz co tel _ cs fields) = + checkDataBody tt n x sz co tel cs fields +checkBody (ts@(A.TypeSig n t), d@(C.FunDecl co tsig cls)) = do + (ar,cls') <- scopeCheckFunClauses d + let n' = A.mkExtName n + return $ A.FunDecl co $ A.Fun ts n' ar cls' + +mutualFlattenDecls :: [C.Declaration] -> ScopeCheck [C.Declaration] +mutualFlattenDecls ds = mapM mutualFlattenDecl ds >>= return . concat + +mutualFlattenDecl :: C.Declaration -> ScopeCheck [C.Declaration] +mutualFlattenDecl (C.MutualDecl ds) = mutualFlattenDecls ds +mutualFlattenDecl (C.OverrideDecl Fail _) = throwErrorMsg $ "fail declaration not supported in mutual block" +mutualFlattenDecl (C.OverrideDecl o ds) = do + ds' <- mutualFlattenDecls ds + return $ map (\ d -> C.OverrideDecl o [d]) ds' +mutualFlattenDecl (C.LetDecl{}) = throwErrorMsg $ "let in mutual block not supported" +mutualFlattenDecl d = return $ [d] + +-- extract type sigs of a mutual block in order, error on nested mutual +mutualGetTypeSig :: C.Declaration -> (IKind, C.TypeSig) +mutualGetTypeSig (C.DataDecl n sz co tel t cs fields) = + (DataK, C.TypeSig n (C.teleToType tel t)) +mutualGetTypeSig (C.FunDecl co tsig cls) = + (FunK False, tsig) -- fun id for use inside defining body +mutualGetTypeSig (C.LetDecl ev (C.LetDef dec n tel Nothing e)) = + error $ "let declaration of " ++ show n ++ ": type required in mutual block" +mutualGetTypeSig (C.LetDecl ev (C.LetDef dec n tel (Just t) e)) = + (LetK, C.TypeSig n (C.teleToType tel t)) +{- mutualGetTypeSig (C.LetDecl ev tsig e) = + (LetK, tsig) -} +mutualGetTypeSig (C.OverrideDecl _ [d]) = + mutualGetTypeSig d + + +scopeCheckRecordDecl :: C.Name -> C.Telescope -> C.Type -> C.Constructor -> [C.Name] -> + ScopeCheck A.Declaration +scopeCheckRecordDecl n tel t c cfields = enterShow n $ do + setDefaultPolarity A.Param $ do + tel <- generalizeTel tel + -- STALE COMMENT: we do not infer at all: -- do not infer polarities in index arguments + (A.TypeSig x tt') <- scopeCheckTypeSig (C.TypeSig n $ C.teleToType tel t) + addANameU DataK n x + let names = collectTelescopeNames tel + target = C.App (C.ident n) (map C.ident names) -- R pars + (tel',t') = A.typeToTele' (length names) tt' + c' <- scopeCheckConstructor n x (zipTels tel tel') A.CoInd target c + let delta = contextFromConstructors c c' + afields <- addFields ProjK delta cfields + return $ A.RecordDecl x tel' t' c' afields + +contextFromConstructors :: C.Constructor -> A.Constructor -> Context +contextFromConstructors (C.Constructor _ ctel0 mct) (A.Constructor _ _ at) = delta + where ctel = maybe [] (fst . C.typeToTele) mct + (atel, _) = A.typeToTele at + delta = zipTels (ctel0 ++ ctel) atel + +scopeCheckField :: Context -> C.Name -> ScopeCheck A.Name +scopeCheckField delta n = + case lookup n delta of + Nothing -> errorNotAField n + Just x -> return $ x + +addFields :: IKind -> Context -> [C.Name] -> ScopeCheck [A.Name] +addFields kind delta cfields = do + afields <- mapM (scopeCheckField delta) cfields + mapM (uncurry $ addANameU kind) $ zip cfields afields + return afields + +scopeCheckDataDecl :: C.Declaration -> ScopeCheck A.Declaration +scopeCheckDataDecl decl@(C.DataDecl n sz co tel0 t cs fields) = enterShow n $ do + setDefaultPolarity A.Param $ do + tel <- generalizeTel tel0 + -- STALE: -- do not infer polarities in index arguments + (A.TypeSig x tt') <- scopeCheckTypeSig (C.TypeSig n $ C.teleToType tel t) + addANameU DataK n x + checkDataBody tt' n x sz co tel cs fields + +-- precondition: name already added to signature +checkDataBody :: A.Type -> C.Name -> A.Name -> Sized -> Co -> C.Telescope -> [C.Constructor] -> [C.Name] -> ScopeCheck A.Declaration +checkDataBody tt' n x sz co tel cs fields = do + let cnames = collectTelescopeNames tel -- parameters + target = C.App (C.ident n) $ map C.ident cnames -- D pars + (tel',t') = A.typeToTele' (length cnames) tt' + cs' <- mapM (scopeCheckConstructor n x (zipTels tel tel') co target) cs +{- NO LONGER INFER DESTRUCTORS + -- traceM ("constructors: " ++ show cs') +-- when (t' == A.Sort A.Set && length cs' == 1) $ do +-- when (length cs' == 1) $ do -- TOO STRICT, DOES NOT TREAT Vec right + let cis = A.analyzeConstructors co n tel' cs' + flip mapM_ cis $ \ ci -> when (A.cEtaExp ci) $ do +-- Add destructor names + let fields = A.cFields ci -- A.classifyFields co n (A.typePart c) + -- TODO Check for recursive occurrence! + -- when (A.etaExpandable fields) $ + let destrNames = A.destructorNames fields + --when (not (null (destrNames))) $ + -- traceM ("fields: " ++ show fields) + -- traceM ("destructors: " ++ show destrNames) + mapM_ (addName (FunK True)) $ destrNames -- destructors are also upped + {- + let (ctel,_) = A.typeToTele (A.typePart (head cs')) + let destrNames = map (\(_,x,_) -> x) ctel + when (all (/= "") destrNames) $ + mapM_ (addName (FunK True)) destrNames -- destructors are also upped +-} +-} + -- add declared destructor names + let delta = concat $ map (uncurry contextFromConstructors) $ zip cs cs' + -- fields <- addFields (LetK) delta fields + -- 2012-01-26 register as projections + fields <- addFields ProjK delta fields + let pos = map (A.polarity . A.decor . A.boundDom) $ A.telescope tel' + return $ A.DataDecl x sz co pos tel' t' cs' fields + +-- check whether all declarations in mutual block are (co)funs +checkFunMutual :: Co -> [C.Declaration] -> ScopeCheck () +checkFunMutual co [] = return () +checkFunMutual co (C.FunDecl co' _ _:xl) | co == co' = checkFunMutual co xl +checkFunMutual _ _ = throwErrorMsg "mutual combination not supported" + +scopeCheckFunDecls :: Co -> [C.Declaration] -> ScopeCheck A.Declaration +scopeCheckFunDecls co l = do + -- check for uniformity of mutual block (all funs/all cofuns) + checkFunMutual co l + -- check signatures and look for measures + r <- mapM (\ (C.FunDecl _ tysig _) -> scopeCheckFunSig tysig) l + let (ml:mll, tsl') = unzip r + let ok = all (ml==) mll + when (not ok) $ throwErrorMsg $ "in a mutual function block, either all functions must be without measure or have a measure of the same length" + -- add names as internal ids and check bodies + let nxs = zipWith (\ (C.FunDecl _ (C.TypeSig n _) _) (A.TypeSig x _) -> (n,x)) l tsl' + --let addFuns b = mapM (uncurry $ addAName $ FunK b) nxs +-- let addFuns b = mapM (\ (n,x) -> addAName (FunK b) n x) nxs + -- addFuns False + mapM (uncurry $ addANameU $ FunK False) nxs + arcll' <- mapM (setDefaultPolarity A.Rec . scopeCheckFunClauses) l + -- add names as external ids + --addFuns True + let nxs' = map (mapPair id A.mkExtName) nxs + mapM (uncurry $ addANameU (LetK)) nxs' +-- mapM (uncurry $ addAName (FunK True)) nxs' + return $ A.MutualFunDecl (isJust ml) co $ + zipWith3 (\ ts (_, x') (ar, cls) -> A.Fun ts x' ar cls) tsl' nxs' arcll' + +-- | Does not add name to signature. +scopeCheckFunSig :: C.TypeSig -> ScopeCheck (Maybe Int, A.TypeSig) +scopeCheckFunSig d@(C.TypeSig n t) = checkInSig d n $ \ x -> do + (ml, t') <- scopeCheckFunType t + return (ml, A.TypeSig x t') + +-- scope check type of mutual function, return length of measure (if present) +-- a fun type is a telescope followed by (maybe) a measure and a type expression +scopeCheckFunType :: C.Expr -> ScopeCheck (Maybe Int, A.Expr) +scopeCheckFunType t = + case t of + + -- found a measure: continue normal scope checking + C.Quant A.Pi [C.TMeasure mu] e1 -> do + mu' <- scopeCheckMeasure mu + e1' <- scopeCheckExprN e1 + return (Just $ length (measure mu'), A.pi (A.TMeasure mu') e1') + + -- bounds are allowed here, since we check a function type + C.Quant A.Pi [C.TBound beta] e1 -> do + beta' <- scopeCheckBound beta + (ml, e1') <- scopeCheckFunType e1 + return (ml, A.pi (A.TBound beta') e1') + + C.Quant A.Pi tel e -> do + tel <- generalizeTel tel + (tel, (ml, e)) <- setDefaultPolarity A.Rec $ setConstraintAllowed False $ + scopeCheckTele tel $ setConstraintAllowed True $ scopeCheckFunType e + ml' <- findMeasure tel + ml <- case (ml,ml') of + (Nothing,ml') -> return ml' + (ml, Nothing) -> return ml + (Just{}, Just{}) -> errorOnlyOneMeasure + return (ml, A.teleToType tel e) + + t -> (Nothing,) <$> scopeCheckExpr t -- no measure found + +findMeasure :: A.Telescope -> ScopeCheck (Maybe Int) +findMeasure (A.Telescope tel) = + case [ mu | A.TMeasure mu <- tel ] of + [] -> return Nothing + [Measure mu] -> return $ Just $ length mu + _ -> errorOnlyOneMeasure + +-- | Check whether concrete name is already in signature. +-- If yes, fail. If no, create abstract name and continue. +checkInSig :: Show d => d -> C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck a +checkInSig d n k = enterShow n $ do + sig <- getSig + case lookupSig (C.QName n) sig of + Just _ -> errorAlreadyInSignature d n + Nothing -> k (A.fresh $ C.theName n) + +-- checkInSigU :: Show d => d -> C.Name -> (A.Name -> ScopeCheck a) -> ScopeCheck a +-- checkInSigU d n k = checkInSig d (C.QName n) (k . A.unqual) + +scopeCheckFunClauses :: C.Declaration -> ScopeCheck (Arity, [A.Clause]) +scopeCheckFunClauses (C.FunDecl _ (C.TypeSig n _) cl) = enterShow n $ do + cl <- mapM (scopeCheckClause (Just n)) cl + let m = if null cl then 0 else + List.foldl1 min $ map (length . A.clPatterns) cl + return (A.Arity m Nothing, cl) +{- + let b = checkPatternLength cl + case b of + Just m -> return $ (A.Arity m Nothing, cl) + Nothing -> throwErrorMsg $ " pattern length differs" +-} + +-- | Check the type of a signature and generate abstract name. +-- Does not add abstract name to signature. +scopeCheckTypeSig :: C.TypeSig -> ScopeCheck A.TypeSig +scopeCheckTypeSig d@(C.TypeSig n t) = checkInSig d n $ \ x -> do + t' <- scopeCheckExpr t + return $ A.TypeSig x t' + +-- | Results: +-- +-- @Nothing@ Not a function declaration. +-- +-- @Just (n, Nothing)@ Unmeasured function. +-- +-- @Just (n, Just m)@ Function with measure of length m +checkAndAddTypeSig :: (IKind, C.TypeSig) -> ScopeCheck (Maybe (C.Name, Maybe Int), A.TypeSig) +checkAndAddTypeSig (kind, ts@(C.TypeSig n _)) = do + (mm, ts'@(A.TypeSig x _)) <- + case kind of + FunK _ -> mapPair (Just . (n,)) id <$> scopeCheckFunSig ts +{- + do + (mi, ts) <- scopeCheckFunSig ts + return (Just mi, ts) +-} + _ -> (Nothing,) <$> scopeCheckTypeSig ts + addANameU kind n x -- or: addTypeSig kind ts ts' + return (mm, ts') + +collectTelescopeNames :: C.Telescope -> [C.Name] +collectTelescopeNames = concat . map C.boundNames + +-- | Check whether concrete name is already in signature. +-- If yes, fail. If no, create abstract name and continue. +checkConsInSig :: Show decl => decl -> C.Name -> A.Name -> IKind -> C.Name -> (A.QName -> ScopeCheck a) -> ScopeCheck a +checkConsInSig decl d dx ki n cont = enterShow n $ do + -- first check whether the datatype has this constructor already + ifJustM (lookupSig (C.Qual d n) <$> getSig) (const $ errorAlreadyInSignature decl n) $ do + -- then check the overloaded name and possibly add it + x <- overloadName ki n + -- the qualified name is added in the continuation + cont $ A.Qual dx x + +-- | @cxt@ is the data telescope. +scopeCheckConstructor :: C.Name -> A.Name -> Context -> Co -> C.Type -> C.Constructor -> ScopeCheck A.Constructor +scopeCheckConstructor d dx cxt co t0 a@(C.Constructor n tel mt) = do + let ki = ConK $ A.coToConK co + checkConsInSig a d dx ki n $ \ x -> do + + let finish t mcxt = local (addContext $ maybe cxt id mcxt) $ do + t <- setDefaultPolarity A.Param $ scopeCheckExpr $ C.teleToType tel t + t <- adjustTopDecsM defaultToParam t + addAName ki (C.Qual d n) x + let dummyDom = A.Domain A.Irr A.NoKind $ A.Dec Param + mtel = fmap (map (\ (n,x) -> A.TBind x dummyDom)) mcxt + ps = [] -- patterns computed during type checking + return $ A.Constructor x (fmap ((,ps) . A.Telescope) mtel) t + + case mt of + + -- no target given, then add the data tel to the scope + Nothing -> finish t0 Nothing + + -- target given, then the target binds the parameter names + Just t -> do + -- get the final target + let (_, target) = C.typeToTele t + + fallback = finish t Nothing + continue d' es = do + -- unless (d == d') $ errorWrongTarget n d d' + if (d /= d') then fallback else do + -- get the parameters of target + let (pars, inds) = splitAt (length cxt) es + unless (length pars == length cxt) $ errorNotEnoughParameters n target + -- if parameters are just data parameters, do it old style + if and (zipWith isTelPar cxt pars) then fallback else do + -- scopeCheck the parameters as patterns + finish t . Just =<< parameterVariables pars + + case target of + C.Ident (C.QName d') -> continue d' [] + C.App (C.Ident (C.QName d')) es -> continue d' es + _ -> fallback -- errorTargetMustBeAppliedName n target + +{- OLD CODE +scopeCheckConstructor :: C.Telescope -> A.Telescope -> Co -> C.Type -> C.Constructor -> ScopeCheck A.Constructor +scopeCheckConstructor ctel atel co t0 a@(C.Constructor n tel mt) = addTel ctel atel $ checkInSig a n $ \ x -> do + let t = maybe t0 id mt + t <- setDefaultPolarity A.Param $ scopeCheckExpr $ C.teleToType tel t + t <- adjustTopDecsM defaultToParam t + addAName (ConK $ A.coToConK co) n x + return $ A.TypeSig x t +-} + where isTelPar (c,_) (C.Ident (C.QName x)) = c == x + isTelPar _ _ = False + defaultToParam dec = case (A.polarity dec) of + A.Default -> return $ setPol A.Param dec + A.Param -> return dec + A.Const -> return dec + A.PVar{} -> return dec + _ -> throwErrorMsg $ "illegal polarity " ++ show (polarity dec) ++ " in type of constructor " ++ show a + +-- | Allow shadowing of previous locals. +-- Always if we enter a subexpression which is not the body +-- of a binder. +scopeCheckExprN :: C.Expr -> ScopeCheck A.Expr +scopeCheckExprN = newLevel . scopeCheckExpr + +scopeCheckExpr :: C.Expr -> ScopeCheck A.Expr +scopeCheckExpr e = setConstraintAllowed False $ scopeCheckExpr' e + +scopeCheckExpr' :: C.Expr -> ScopeCheck A.Expr +scopeCheckExpr' e = + case e of + -- replace underscore by next meta-variable + C.Unknown -> nextMVar (return . A.Meta) + C.Set e -> A.Sort . A.Set <$> scopeCheckExprN e + C.CoSet e -> A.Sort . A.CoSet <$> scopeCheckExprN e + C.Size -> return $ A.Sort (A.SortC A.Size) + C.Succ e1 -> A.Succ <$> scopeCheckExprN e1 + C.Zero -> return A.Zero + C.Infty -> return A.Infty + C.Plus e1 e2 -> do + e1 <- scopeCheckExprN e1 + e2 <- scopeCheckExprN e2 + return $ A.Plus [e1, e2] + C.Pair e1 e2 -> A.Pair <$> scopeCheckExprN e1 <*> scopeCheckExprN e2 + C.Sing e1 et -> A.Sing <$> scopeCheckExprN e1 <*> scopeCheckExprN et + C.App C.Max el -> do + el' <- mapM scopeCheckExprN el + when (length el' < 2) $ throwErrorMsg "max expects at least 2 arguments" + return $ A.Max el' + C.App e1 el -> foldl A.App <$> scopeCheckExprN e1 <*> mapM scopeCheckExprN el + C.Case e mt cl -> do + e' <- scopeCheckExprN e + mt' <- mapM scopeCheckExprN mt + cl' <- mapM (scopeCheckClause Nothing) cl + return $ A.Case e' mt' cl' + + -- measure & bound + -- measures can only appear in fun sigs! + C.Quant pisig [C.TMeasure mu] e1 -> do + throwErrorMsg $ "measure not allowed in expression " ++ show e + + -- measure bound mu < mu' + C.Quant A.Pi [C.TBound beta] e1 -> do + unlessM (asks constraintAllowed) $ errorConstraintNotAllowed beta + beta' <- scopeCheckBound beta + e1' <- scopeCheckExpr' e1 + return $ A.pi (A.TBound beta') e1' + + C.Quant A.Sigma [C.TBound beta] e1 -> throwErrorMsg $ + "measure bound not allowed in expression " ++ show e + + C.Quant pisig tel e -> do + tel <- generalizeTel tel + pol <- asks defaultPolarity + (A.Telescope tel, e) <- setDefaultPolarity A.Rec $ setConstraintAllowed False $ scopeCheckTele tel $ + setDefaultPolarity pol $ scopeCheckExpr' e + return $ quant pisig tel e where +-- quant A.Sigma [tb] = A.Quant A.Sigma tb + quant A.Sigma tel e = foldr (A.Quant A.Sigma) e tel + quant A.Pi tel e = A.teleToType (A.Telescope tel) e + + C.Lam n e1 -> do + (n, e1') <- addBind e n $ scopeCheckExpr e1 + return $ A.Lam A.defaultDec n e1' -- dec. in Lam is ignored in t.c. + + C.LLet letdef e2 -> do + let dec = C.letDefDec letdef + (tel, mt, e1) <- scopeCheckLetDef letdef + (x, e2) <- addBind e (C.letDefName letdef) $ scopeCheckExpr e2 + return $ A.LLet (A.TBind x $ A.Domain mt A.defaultKind dec) tel e1 e2 + + C.Record rs -> do + let fields = map fst rs + if (hasDuplicate fields) then (errorDuplicateField e) else do + rs <- mapM scopeCheckRecordLine rs + return $ A.Record A.AnonRec rs + + C.Proj n -> A.Proj Post <$> scopeCheckProj n + + C.Ident n@C.Qual{} -> scopeCheckGlobalVar n + + C.Ident n@C.QName{} -> do + res <- lookupLocal (C.name n) + case res of + Just x -> return $ A.Var x + Nothing -> scopeCheckGlobalVar n + + _ -> throwErrorMsg $ "NYI: scopeCheckExpr " ++ show e + +scopeCheckGlobalVar :: C.QName -> ScopeCheck A.Expr +scopeCheckGlobalVar n = do + res <- lookupGlobal n + case res of + Just (DefI k x) -> case k of + (ConK co) -> return $ A.con co x + LetK -> return $ A.letdef (A.unqual x) + -- references to recursive functions are coded differently + -- outside the mutual block + FunK True -> return $ A.fun x -- A.letdef x -- A.mkExtRef x + FunK False -> return $ A.fun x + DataK -> return $ A.dat x + ProjK -> return $ A.Proj A.Pre (A.unqual x) -- errorProjectionUsedAsExpression n + Nothing -> errorIdentifierUndefined n + +scopeCheckLocalVar :: C.Name -> ScopeCheck A.Name +scopeCheckLocalVar n = maybe (errorIdentifierUndefined n) return =<< do + lookupLocal n + +scopeCheckRecordLine :: ([C.Name], C.Expr) -> ScopeCheck (A.Name, A.Expr) +scopeCheckRecordLine (n : ns, e) = do + x <- scopeCheckProj n + (x,) <$> scopeCheckExprN (foldr C.Lam e ns) + +scopeCheckProj :: C.Name -> ScopeCheck A.Name +scopeCheckProj n = do + sig <- getSig + case lookupSigU n sig of + Just (DefI ProjK x) -> return $ A.unqual x + _ -> errorNotAField n + + +-- | @isProjIdent n = n@ if defined and the name of a projection. +isProjIdent :: C.QName -> ScopeCheck (Maybe A.Name) +isProjIdent n = do + sig <- getSig + return $ + case lookupSig n sig of + Just (DefI ProjK x) -> Just $ A.unqual x + _ -> Nothing + +isProjection :: C.Expr -> ScopeCheck (Maybe A.Name) +isProjection (C.Ident n) = isProjIdent n +isProjection _ = return Nothing + +scopeCheckMeasure :: A.Measure C.Expr -> ScopeCheck (A.Measure A.Expr) +scopeCheckMeasure (A.Measure es) = do + es' <- mapM scopeCheckExprN es + return $ A.Measure es' + +scopeCheckBound :: A.Bound C.Expr -> ScopeCheck (A.Bound A.Expr) +scopeCheckBound (A.Bound ltle e1 e2) = do + [e1',e2'] <- mapM scopeCheckMeasure [e1,e2] + return $ A.Bound ltle e1' e2' + +checkPatternLength :: [C.Clause] -> Maybe Int +checkPatternLength [] = Just 0 -- arity 0 +checkPatternLength (C.Clause _ pl _:cl) = cpl (length pl) cl + where + cpl k [] = Just k + cpl k (C.Clause _ pl _ : cl) = if (length pl == k) then (cpl k cl) else Nothing + +scopeCheckClause :: Maybe C.Name -> C.Clause -> ScopeCheck A.Clause +scopeCheckClause mname' (C.Clause mname pl mrhs) = do + when (mname /= mname') $ errorClauseIdentifier mname mname' + (pl, delta) <- runStateT (mapM scopeCheckPattern pl) emptyCtx + local (addContext delta) $ do + pl <- mapM scopeCheckDotPattern pl + case mrhs of + Nothing -> return $ A.clause pl Nothing + Just rhs -> A.clause pl . Just <$> scopeCheckExprN rhs + + +type PatCtx = Context +type SPS = StateT PatCtx ScopeCheck + +scopeCheckPatVar :: C.QName -> SPS (A.Pat C.Expr) +scopeCheckPatVar n = do + sig <- lift $ getSig + case lookupSig n sig of + Just (DefI (ConK co) n) -> return $ A.ConP (A.PatternInfo co False False) n [] + -- a nullary constructor + Just _ -> errorPatternNotConstructor n + Nothing -> A.VarP <$> addUnique (C.unqual n) + +scopeCheckPattern :: C.Pattern -> SPS (A.Pat C.Expr) +scopeCheckPattern p = + case p of + + -- case n + C.IdentP n -> scopeCheckPatVar n + C.ConP False n [] -> scopeCheckPatVar n + + -- case (i > j): + C.SizeP m n -> do + -- m <- lift $ scopeCheckLocalVar m + A.SizeP m <$> addUnique n + + -- case $p + C.SuccP p2 -> A.SuccP <$> scopeCheckPattern p2 + + -- case (p1,p2) + C.PairP p1 p2 -> A.PairP <$> scopeCheckPattern p1 <*> scopeCheckPattern p2 + + -- case .n + C.ConP True n [] -> do + -- try projection + ifJustM (lift $ isProjIdent n) (return . A.ProjP) $ do + -- try constructor + sig <- lift $ getSig + case lookupSig n sig of + Just (DefI (ConK co) n) -> + return $ A.ConP (A.PatternInfo co False True) n [] + -- fallback: dot pattern + _ -> return $ A.DotP (C.Ident n) + + -- case [.]c ps + C.ConP dotted n pl -> do + sig <- lift $ getSig + case lookupSig n sig of + Just (DefI (ConK co) x) -> + A.ConP (A.PatternInfo co False dotted) x <$> mapM scopeCheckPattern pl + _ -> errorPatternNotConstructor n + + -- case .e + C.DotP e -> do + isProj <- lift $ isProjection e + case isProj of + Just n -> return $ A.ProjP n + Nothing -> return $ A.DotP e -- dot patterns checked later + + -- case () + C.AbsurdP -> return $ A.AbsurdP + +-- | Add pattern variable to pattern context, must not be present yet. +addUnique :: C.Name -> SPS A.Name +addUnique = addPatVar True + +addNonUnique :: C.Name -> SPS A.Name +addNonUnique = addPatVar False + +addPatVar :: Bool -> C.Name -> SPS A.Name +addPatVar linear n = do + delta <- get + case retrieve n delta of + Just x -> if linear then errorPatternNotLinear n else return x + Nothing -> do + let (x, delta') = newLocal n delta + put delta' + return x + +scopeCheckDotPattern :: A.Pat C.Expr -> ScopeCheck A.Pattern +scopeCheckDotPattern p = + case p of + A.DotP e -> A.DotP <$> scopeCheckExprN e + A.PairP p1 p2 -> A.PairP <$> scopeCheckDotPattern p1 <*> scopeCheckDotPattern p2 + A.SuccP p -> A.SuccP <$> scopeCheckDotPattern p + A.ConP co n pl -> A.ConP co n <$> mapM scopeCheckDotPattern pl +-- A.SizeP m n -> flip A.SizeP n <$> scopeCheckLocalVar m -- return $ A.SizeP m n + A.SizeP e n -> flip A.SizeP n <$> scopeCheckExprN e + A.VarP n -> return $ A.VarP n -- even though p = A.VarP n, it has wrong type!! + A.ProjP n -> return $ A.ProjP n + A.AbsurdP -> return $ A.AbsurdP + -- impossible cases: ErasedP, UnusableP + + +-- * Scope checking parameters + +parameterVariables :: [C.Expr] -> ScopeCheck Context +parameterVariables es = do + execStateT (mapM_ scopeCheckParameter es) emptyCtx + +-- | Extract variables bound by data parameters. +-- We consider a more liberal set of patterns, everything +-- that is injective and does not bind variables. +scopeCheckParameter :: C.Expr -> SPS () +scopeCheckParameter e = + case e of + C.Set e' -> scopeCheckParameter e' + C.CoSet e' -> scopeCheckParameter e' + C.Size -> return () + C.Succ e' -> scopeCheckParameter e' + C.Zero -> return () + C.Infty -> return () + C.Pair e1 e2 -> scopeCheckParameter e1 >> scopeCheckParameter e2 + C.Record fs -> mapM_ (scpField e) fs + C.Ident n -> scpApp e n [] + C.App (C.Ident n) es -> scpApp e n es + C.App C.App{} es -> throwErrorMsg $ "scopeCheckParameter " ++ show e ++ ": internal invariant violated" + _ -> errorInvalidParameter e + where + -- we can only treat a record expression as pattern + -- if it does not bind any variables + scpField :: C.Expr -> ([C.Name], C.Expr) -> SPS () + scpField e ([f], e') = scopeCheckParameter e' + scpField e _ = errorInvalidParameter e + + scpApp :: C.Expr -> C.QName -> [C.Expr] -> SPS () + scpApp e n es = do + sig <- lift $ getSig + case lookupSig n sig of + Just (DefI ConK{} n) -> mapM_ scopeCheckParameter es + Just (DefI DataK n) -> mapM_ scopeCheckParameter es + Just _ -> errorInvalidParameter e + Nothing -> void $ addNonUnique (C.unqual n) -- allow non-linearity + +-- * Scope checking errors + +errorAlreadyInSignature s n = throwErrorMsg $ show s ++ ": Identifier " ++ show n ++ " already in signature" + +errorAlreadyInContext s n = throwErrorMsg $ show s ++ ": Identifier " ++ show n ++ " already in context" + +-- errorPatternNotVariable n = throwErrorMsg $ "pattern " ++ n ++ ": Identifier expected" + +errorPatternNotConstructor n = throwErrorMsg $ "pattern " ++ show n ++ " is not a constructor" + +errorNotAField n = throwErrorMsg $ "record field " ++ show n ++ " unknown" +-- errorUnknownProjection n = throwErrorMsg $ "projection " ++ n ++ " unknown" + +errorDuplicateField r = throwErrorMsg $ show r ++ " assigns a field twice" + + +errorProjectionUsedAsExpression n = throwErrorMsg $ "projection " ++ show n ++ " used as expression" + +errorIdentifierUndefined n = throwErrorMsg $ "Identifier " ++ show n ++ " undefined" + +errorPatternNotLinear n = throwErrorMsg $ "pattern not linear: " ++ show n + +errorClauseIdentifier (Just n) (Just n') = throwErrorMsg $ "Expected identifier " ++ show n' ++ " as clause head, found " ++ show n + +errorOnlyOneMeasure = throwErrorMsg "only one measure allowed in a function type" + +errorConstraintNotAllowed beta = throwErrorMsg $ + show beta ++ ": constraints must follow a quantifier" + +errorTargetMustBeAppliedName n t = throwErrorMsg $ + "constructor " ++ show n ++ ": target must be data/record type applied to parameters and indices; however, I found " ++ show t + +errorWrongTarget c d d' = throwErrorMsg $ + "constructor " ++ show c ++ " should target data/record type " ++ show d ++ "; however, I found " ++ show d' + +errorNotEnoughParameters c t = throwErrorMsg $ + "constructor " ++ show c ++ ": target " ++ show t ++ " is missing parameters" + +errorInvalidParameter e = throwErrorMsg $ + "expression " ++ show e ++ " is not valid in a parameter" diff --git a/src/Semiring.hs b/src/Semiring.hs new file mode 100644 --- /dev/null +++ b/src/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/src/SparseMatrix.hs b/src/SparseMatrix.hs new file mode 100644 --- /dev/null +++ b/src/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/src/TCM.hs b/src/TCM.hs new file mode 100644 --- /dev/null +++ b/src/TCM.hs @@ -0,0 +1,1494 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, PatternGuards, FlexibleContexts, NamedFieldPuns, DeriveFunctor, DeriveFoldable, DeriveTraversable, TupleSections #-} + +module TCM where + +import Prelude hiding (null) + +import Control.Monad +import Control.Monad.Identity +import Control.Monad.State +import Control.Monad.Except +import Control.Monad.Reader + +import Control.Applicative +import Data.Foldable (Foldable) +import qualified Data.Foldable as Foldable +import Data.Traversable (Traversable) +import qualified Data.Traversable as Traversable +import Data.Monoid + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe + +import Debug.Trace + +import Abstract +import Polarity +import Value +import {-# SOURCE #-} Eval -- (up,whnf') +import PrettyTCM + +-- import CallStack +import TraceError + +import TreeShapedOrder (TSO) +import qualified TreeShapedOrder as TSO + +import Util + +import Warshall + +-- traceSig msg a = trace msg a +traceSig msg a = a + +traceRew msg a = a -- trace msg a +traceRewM msg = return () -- traceM msg +{- +traceRew msg a = trace msg a +traceRewM msg = traceM msg +-} + +-- metavariables and constraints + +traceMeta msg a = a -- trace msg a +traceMetaM msg = return () -- traceM msg +{- +traceMeta msg a = trace msg a +traceMetaM msg = traceM msg +-} + + +-- type checking monad ----------------------------------------------- + +class (MonadCxt m, MonadSig m, MonadMeta m, MonadError TraceError m) => + MonadTCM m where + + +-- lists of exactly one or two elements ------------------------------ + +-- this would have been better implemented by just lists and a view +-- type OneOrTwo a = [a] +-- data View12 a = One a | Two a a +-- fromList12 +-- then one could still get completeness of pattern matching! +-- now we have lots of boilerplate code + +data OneOrTwo a = One a | Two a a deriving (Eq, Ord, Functor, Foldable, Traversable) + +instance Show a => Show (OneOrTwo a) where + show (One a) = show a + show (Two a b) = show a ++ "||" ++ show b + +name12 :: OneOrTwo Name -> Name +name12 (One n) = n +name12 (Two n1 n2) + | null (suggestion n2) = n1 + | null (suggestion n1) = n2 + | suggestion n1 == suggestion n2 = n1 + | otherwise = fresh (suggestion n1 ++ "||" ++ suggestion n2) + +{- +instance Functor OneOrTwo where + fmap f (One a) = One (f a) + fmap f (Two a b) = Two (f a) (f b) + +instance Foldable OneOrTwo where + foldMap f (One a) = f a + foldMap f (Two a b) = f a `mappend` f b + +-- traverse :: Applicative f => (a -> f b) -> t a -> f (t b) +instance Traversable OneOrTwo where + traverse f (One a) = One <$> f a + traverse f (Two a b) = Two <$> f a <*> f b +-} + +-- eliminator +oneOrTwo :: (a -> b) -> (a -> a -> b) -> OneOrTwo a -> b +oneOrTwo f g (One a) = f a +oneOrTwo f g (Two a1 a2) = g a1 a2 + +fromOne :: OneOrTwo a -> a +fromOne (One a) = a + +toTwo :: OneOrTwo a -> OneOrTwo a +toTwo = oneOrTwo (\ a -> Two a a) Two + +first12 :: OneOrTwo a -> a +first12 (One a) = a +first12 (Two a1 a2) = a1 + +second12 :: OneOrTwo a -> a +second12 (One a) = a +second12 (Two a1 a2) = a2 + +mapSecond12 :: (a -> a) -> OneOrTwo a -> OneOrTwo a +mapSecond12 f (One a) = One (f a) +mapSecond12 f (Two a1 a2) = Two a1 (f a2) + +zipWith12 :: (a -> b -> c) -> OneOrTwo a -> OneOrTwo b -> OneOrTwo c +zipWith12 f (One a) (One b) = One (f a b) +zipWith12 f (Two a a') (Two b b') = Two (f a b) (f a' b') + +zipWith123 :: (a -> b -> c -> d) -> + OneOrTwo a -> OneOrTwo b -> OneOrTwo c -> OneOrTwo d +zipWith123 f (One a) (One b) (One c) = One (f a b c) +zipWith123 f (Two a a') (Two b b') (Two c c') = Two (f a b c) (f a' b' c') + +toList12 :: OneOrTwo a -> [a] +toList12 (One a) = [a] +toList12 (Two a1 a2) = [a1,a2] + +fromList12 :: Show a => [a] -> OneOrTwo a +fromList12 [a] = One a +fromList12 [a1,a2] = Two a1 a2 +fromList12 l = error $ "fromList12 " ++ show l + +toMaybe12 :: Show a => [a] -> Maybe (OneOrTwo a) +toMaybe12 [] = Nothing +toMaybe12 [a] = Just $ One a +toMaybe12 [a1,a2] = Just $ Two a1 a2 +toMaybe12 l = error $ "toMaybe12 " ++ show l + + +-- reader monad for local environment + +data TCContext = TCContext + { context :: SemCxt + , renaming :: Ren -- assigning de Bruijn Levels to names + , naming :: Map Int Name -- assigning names to de Bruijn levels +-- , nameVariants :: Map Name Int -- how many variants of the name + , environ :: Env2 + , rewrites :: Rewrites + , sizeRels :: TSO Int -- relations of universal (rigid) size variables + -- collected from size patterns (x > y) + , belowInfty:: [Int] -- list of size variables < # + , bounds :: [Bound Val] -- bound hyps that do not fit in sizeRels + , consistencyCheck :: Bool -- ^ Do we need to check that new size relations are consistent with every valuation of the current @sizeRels@? [See ICFP 2013 paper] + , checkingConType :: Bool -- different PTS rules for constructor types (parametric function space!) + , assertionHandling :: AssertionHandling -- recover from errors? + , impredicative :: Bool -- use impredicative PTS rules + -- checking measured functions + , funsTemplate :: Map Name (Kinded Fun) -- types of mutual funs with measures checking body + , mutualFuns :: Map Name SigDef -- types of mutual funs while checking body + , mutualCo :: Co -- mutual block (co)recursive ? + , mutualNames :: [Name] -- ^ The defined names of the current mutual block (and parents). + , checkingMutualName :: Maybe DefId -- which body of a mutual block am I checking? + , callStack :: [QName] -- ^ Used to avoid looping when going into recursive data definitions. + } + +instance Show TCContext where + show ce = show (environ ce) ++ "; " ++ show (context ce) + +emptyContext = TCContext + { context = cxtEmpty + , renaming = Map.empty + , naming = Map.empty + , environ = emptyEnv + , rewrites = emptyRewrites + , sizeRels = TSO.empty + , belowInfty = [] + , bounds = [] + , consistencyCheck = False -- initially, no consistency check, turned on when entering rhs + , checkingConType = False + , assertionHandling = Failure -- default is not to ignore any errors + , impredicative = False + , funsTemplate = Map.empty + , mutualFuns = Map.empty + , mutualCo = Ind + , mutualNames = [] + , checkingMutualName = Nothing + , callStack = [] + } + +-- state monad for global signature + +data TCState = TCState + { signature :: Signature + , metaVars :: MetaVars + , constraints :: Constraints + , positivityGraph :: PositivityGraph + -- , dots :: Dots -- UNUSED + } + +type MetaVars = Map MVar MetaVar +emptyMetaVars = Map.empty + +type MScope = [Name] -- ^ names of size variables which are in scope of mvar +data MetaVar = MetaVar + { mscope :: MScope + , solution :: Maybe Val + } + +type PosConstrnt = Constrnt PPoly DefId () +type PositivityGraph = [PosConstrnt] +emptyPosGraph = [] + +-- type TypeCheck = StateT TCState (ReaderT TCContext (CallStackT String IO)) +type TypeCheck = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) + +instance MonadAssert TypeCheck where + assert b s = do + h <- asks assertionHandling + assert' h b s + newAssertionHandling h = local ( \ ce -> ce { assertionHandling = h }) + +{- mtl-2 provides these instances +-- TypeCheck is applicative since every monad is. +-- I do not know why this ain't in the libraries... +instance Applicative TypeCheck where + pure = return + mf <*> ma = mf >>= \ f -> ma >>= \ a -> pure (f a) +-} + +{- NOT NEEDED + +-- | Dotted constructors (the top one in the pattern). +type Dots = [(Dotted,Pattern)] + +emptyDots = [] + +class LensDots a where + getDots :: a -> Dots + setDots :: Dots -> a -> a + setDots = mapDots . const + mapDots :: (Dots -> Dots) -> a -> a + mapDots f a = setDots (f (getDots a)) a + +instance LensDots TCState where + getDots = dots + setDots d st = st { dots = d } + +newDotted :: Pattern -> TypeCheck Dotted +newDotted p = do + d <- mkDotted True + modify $ mapDots $ ((d,p):) + return d + +clearDots :: TypeCheck () +clearDots = modify $ setDots emptyDots + +openDots :: TypeCheck [Pattern] +openDots = map snd . filter (isDotted . fst) <$> gets dots +-} + +-- rewriting rules ----------------------------------------------- + +data Rewrite = Rewrite { lhs :: Val, rhs :: Val } +type Rewrites = [Rewrite] + +emptyRewrites = [] + +instance Show Rewrite where + show rr = show (lhs rr) ++ " --> " ++ show (rhs rr) + +{- renaming ------------------------------------------------------ + + A renaming maps names to de Bruijn levels (= generic values). +-} + +type Ren = Map Name Int + +type Env2 = Environ (OneOrTwo Val) + +type Context a = Map Int a +type Context2 a = Context (OneOrTwo a) + +{- context ------------------------------------------------------- + +A context maps generic values to their type value. + +During type checking, named variables are mapped to +generic values via a renaming. Thus, looking up the type of a +name involves first looking up the generic value, and then its type. + +-} + +{- +-- data Domain = Domain { typ :: TVal, decor :: Dec } +data Domain = Domain { typ :: TVal, kind :: Class, decor :: Dec } + +mapTyp :: (TVal -> TVal) -> Domain -> Domain +mapTyp f dom = dom { typ = f (typ dom) } + +mapTypM :: Monad m => (TVal -> m TVal) -> Domain -> m Domain +mapTypM f dom = do + t' <- f (typ dom) + return $ dom { typ = t' } + +instance Show Domain where + show item = (if erased (decor item) then brackets else id) (show (typ item)) +-} + +-- During heterogeneous equality, a variable might have +-- two different types, one on the left and one on the right. +-- We implement this as Two tl tr. + +data CxtE a = CxtEntry { domain :: a, upperDec :: UDec } +type CxtEntry = CxtE (OneOrTwo Domain) +type CxtEntry1 = CxtE Domain + +data SemCxt = SemCxt + { len :: Int + , cxt :: Context2 Domain -- fixed part of context + , upperDecs :: Context UDec -- the "should be below" decoration for each var.; this is updated by resurrection + } +{- invariant: length (cxt delta) = length (upperDecs delta) = len + cxt(i) = Two ... iff upperDecs(i) = Two ... + -} + +instance Show SemCxt where + show delta = + show $ zip (Map.elems (cxt delta)) + (Map.elems (upperDecs delta)) +{- + show delta = show $ zip ( + zipWith3 (zipWith12 Domain) +-- zipWith (\ entry dec -> fmap ((flip Domain) dec) entry) + (Map.elems (cxt delta)) + (Map.elems (kinds delta)) + (Map.elems (decs delta)) + ) (Map.elems (upperDecs delta)) +-} +cxtEmpty = SemCxt + { len = 0 + , cxt = Map.empty +-- , kinds = Map.empty +-- , decs = Map.empty + , upperDecs = Map.empty + } + +-- push a new type declaration on context +cxtPush' :: OneOrTwo Domain -> SemCxt -> SemCxt +cxtPush' entry delta = + delta { len = k + 1 + , cxt = Map.insert k entry (cxt delta) +-- , cxt = Map.insert k (fmap typ entry) (cxt delta) +-- , decs = Map.insert k (fmap decor entry) (decs delta) + , upperDecs = Map.insert k defaultUpperDec (upperDecs delta) + } + where k = len delta +{- +cxtPush' (tv12, dec) delta = + delta { len = k + 1 + , cxt = Map.insert k tv12 (cxt delta) + , decs = Map.insert k dec (decs delta) } + where k = len delta +-} +{- +cxtPush :: Dec -> TVal -> SemCxt -> (Int, SemCxt) +cxtPush dec v delta = (len delta, cxtPush' (One (Domain v dec)) delta) +-- cxtPush dec v delta = (len delta, cxtPush' (One v, dec) delta) +-} + +cxtPushEntry :: OneOrTwo Domain -> SemCxt -> (Int, SemCxt) +cxtPushEntry ce delta = (len delta, cxtPush' ce delta) + +cxtPush :: Domain -> SemCxt -> (Int, SemCxt) +cxtPush dom delta = cxtPushEntry (One dom) delta +-- cxtPush dec v delta = (len delta, cxtPush' (One v, dec) delta) + +-- push a variable with a left and a right type +cxtPush2 :: Domain -> Domain -> SemCxt -> (Int, SemCxt) +cxtPush2 doml domr delta = cxtPushEntry (Two doml domr) delta +-- (len delta, cxtPush' (Two doml domr) delta) + +{- +-- push a variable with a left and a right type +cxtPush2 :: Dec -> TVal -> TVal -> SemCxt -> (Int, SemCxt) +cxtPush2 dec tvl tvr delta = + (len delta, cxtPush' (Two tvl tvr, dec) delta) +-} + +cxtPushGen :: Name -> SemCxt -> (Int, SemCxt) +cxtPushGen x delta = cxtPush bot delta + where bot = error $ "IMPOSSIBLE: name " ++ show x ++ " is not bound to any type" + +-- only defined for single bindings +cxtSetType :: Int -> Domain -> SemCxt -> SemCxt +cxtSetType k dom delta = + delta { cxt = Map.insert k (One dom) (cxt delta) + -- upperDecs need not be updated + } + +-- | Version of 'Map.lookup' that throws 'TraceError'. +lookupM :: (MonadError TraceError m, Show k, Ord k) => k -> Map k v -> m v +lookupM k m = maybe (throwErrorMsg $ "lookupM: unbound key " ++ show k) return $ Map.lookup k m + +cxtLookupGen :: MonadError TraceError m => SemCxt -> Int -> m CxtEntry +cxtLookupGen delta k = do + dom12 <- lookupM k (cxt delta) + udec <- lookupM k (upperDecs delta) + return $ CxtEntry dom12 udec + +cxtLookupName :: MonadError TraceError m => SemCxt -> Ren -> Name -> m CxtEntry +cxtLookupName delta ren x = do + i <- lookupM x ren + cxtLookupGen delta i + +-- apply decoration, possibly resurrecting (see Pfenning, LICS 2001) +-- and changing polarities (see Abel, MSCS 2008) +cxtApplyDec :: Dec -> SemCxt -> SemCxt +cxtApplyDec dec delta = delta { upperDecs = Map.map (compDec dec) (upperDecs delta) } +-- cxtApplyDec dec delta = delta { decs = Map.map (fmap $ invCompDec dec) (decs delta) } + +{- RETIRED, use cxtApplyDec instead +-- clear all "erased" flags (see Pfenning, LICS 2001) +-- UPDATE: resurrection sets "target" status to erased +-- (as opposed to setting "source" status to non-erased) +cxtResurrect :: SemCxt -> SemCxt +cxtResurrect delta = delta { upperDecs = Map.map (\ dec -> dec { erased = True}) (upperDecs delta) } +-- cxtResurrect delta = delta { decs = Map.map (fmap resurrectDec) (decs delta) } +-} + +-- manipulating the context ------------------------------------------ + +{- +-- | Size decrements in bounded quantification do not count for termination +data LamPi + = LamBind -- ^ add a lambda binding to the context + | PiBind -- ^ add a pi binding to the context +-} + +class Monad m => MonadCxt m where +-- bind :: Name -> Domain -> Val -> m a -> m a +-- new performs eta-expansion "up" of new gen + -- adding types (Two t1 t2) returns values (Two (Up t1 vi) (Up t2 vi)) + newVar :: Name -> OneOrTwo Domain -> (Int -> OneOrTwo Val -> m a) -> m a + newWithGen :: Name -> Domain -> (Int -> Val -> m a) -> m a + newWithGen x d k = newVar x (One d) + (\ i (One v) -> k i v) + new2WithGen:: Name -> (Domain, Domain) -> (Int -> (Val, Val) -> m a) -> m a + new2WithGen x (doml, domr) k = newVar x (Two doml domr) + (\ i (Two vl vr) -> k i (vl, vr)) + new :: Name -> Domain -> (Val -> m a) -> m a + new x d cont = newWithGen x d (\ _ -> cont) + new2 :: Name -> (Domain, Domain) -> ((Val, Val) -> m a) -> m a + new2 x d cont = new2WithGen x d (\ _ -> cont) +{- + new2 :: Name -> (TVal, TVal, Dec) -> ((Val, Val) -> m a) -> m a + new2 x d cont = new2WithGen x d (\ _ -> cont) +-} + new' :: Name -> Domain -> m a -> m a + new' x d cont = new x d (\ _ -> cont) + newIrr :: Name -> m a -> m a -- only add binding x = VIrr to env + addName :: Name -> (Val -> m a) -> m a +{- RETIRED + addTypeSigs :: [TySig TVal] -> m a -> m a + addTypeSigs [] k = k + addTypeSigs (TypeSig n tv : tss) k = + new' n (defaultDomain tv) $ addTypeSigs tss k +-} + addKindedTypeSigs :: [Kinded (TySig TVal)] -> m a -> m a + addKindedTypeSigs [] k = k + addKindedTypeSigs (Kinded ki (TypeSig n tv) : ktss) k = + new' n (Domain tv ki defaultDec) $ addKindedTypeSigs ktss k +-- addName x = new x dontCare + setType :: Int -> Domain -> m a -> m a + setTypeOfName :: Name -> Domain -> m a -> m a + genOfName :: Name -> m Int + nameOfGen :: Int -> m Name +-- nameTaken :: Name -> m Bool + uniqueName :: Name -> Int -> m Name + uniqueName x _ = return x -- $ freshen x -- TODO! now freshen causes problems in extraction +{- + uniqueName x k = ifM (nameTaken x) (return $ show x ++ "~" ++ show k) (return x) +-} + lookupGen :: Int -> m CxtEntry + lookupGenType2 :: Int -> m (TVal, TVal) + lookupGenType2 i = do + entry <- lookupGen i + case domain entry of + One d1 -> return (typ d1, typ d1) + Two d1 d2 -> return (typ d1, typ d2) + lookupName :: Name -> m CxtEntry + lookupName1 :: Name -> m CxtEntry1 + lookupName1 x = do + e <- lookupName x + return $ CxtEntry (fromOne (domain e)) (upperDec e) + + getContextTele :: m TeleVal -- return context as telescope of type values + getLen :: m Int -- return length of the context + getEnv :: m Env -- return current environment + getRen :: m Ren -- return current renaming + applyDec :: Dec -> m a -> m a -- resurrect/adjust polarities + resurrect :: m a -> m a -- resurrect all erased variables in context + resurrect = applyDec irrelevantDec + addRewrite :: Rewrite -> [Val] -> ([Val] -> m a) -> m a + addPattern :: TVal -> Pattern -> Env -> (TVal -> Val -> Env -> m a) -> m a -- step under pat + addPatterns:: TVal -> [Pattern] -> Env -> (TVal -> [Val] -> Env -> m a) -> m a + addSizeRel :: Int -> Int -> Int -> m a -> m a + addBelowInfty :: Int -> m a -> m a + addBoundHyp :: Bound Val -> m a -> m a + isBelowInfty :: Int -> m Bool + sizeVarBelow :: Int -> Int -> m (Maybe Int) +-- getSizeDiff :: Int -> Int -> m (Maybe Int) + getMinSize :: Int -> m (Maybe Int) + getSizeVarsInScope :: m [Name] + checkingCon :: Bool -> m a -> m a + checkingDom :: m a -> m a -- check domain A of Pi x:A.B (takes care of polarities) + setCo :: Co -> m a -> m a -- entering a recursive or corecursive function? + installFuns :: Co -> [Kinded Fun] -> m a -> m a + setMeasure :: Measure Val -> m a -> m a + activateFuns :: m a -> m a -- create instance of mutually recursive functions bounded by measure + goImpredicative :: m a -> m a + checkingMutual :: Maybe DefId -> m a -> m a + +dontCare = error "Internal error: tried to retrieve unassigned type of variable" + +instance MonadCxt TypeCheck where + + newIrr x = local (\ ce -> ce { environ = update (environ ce) x (One VIrr) }) + + -- UPDATE to 2? + addName x f = enter ("new " ++ show x ++ " : _") $ do + cxtenv <- ask + let (k, delta) = cxtPushGen x (context cxtenv) + let v = VGen k + let rho = update (environ cxtenv) x (One v) + x' <- uniqueName x k + local (\ cxt -> cxt { context = delta + , renaming = Map.insert x k (renaming cxtenv) + , naming = Map.insert k x' (naming cxt) + , environ = rho }) (f v) + + + newVar x dom12@(One (Domain (VBelow ltle v) ki dec)) f = do + enter ("new " ++ show x ++ " " ++ show ltle ++ " " ++ show v) $ do + cxtenv <- ask + let (k, delta) = cxtPushEntry (One (Domain vSize kSize dec)) (context cxtenv) + let xv = VGen k + let v12 = One xv + let rho = update (environ cxtenv) x v12 + let beta = Bound ltle (Measure [xv]) (Measure [v]) + x' <- uniqueName x k + local (\ cxt -> cxt { context = delta + , renaming = Map.insert x k (renaming cxtenv) + , naming = Map.insert k x' (naming cxtenv) + , environ = rho }) $ + addBoundHyp beta $ (f k v12) + + + newVar x dom12 f = do + let tv12 = fmap typ dom12 + enter ("new " ++ show x ++ " : " ++ show tv12) $ do + cxtenv <- ask + let (k, delta) = cxtPushEntry dom12 (context cxtenv) + v12 <- Traversable.mapM (up False (VGen k)) tv12 + let rho = update (environ cxtenv) x v12 + x' <- uniqueName x k + local (\ cxt -> cxt { context = delta + , renaming = Map.insert x k (renaming cxtenv) + , naming = Map.insert k x' (naming cxtenv) + , environ = rho }) (f k v12) +{- + newVar x (tv12, dec) f = enter ("new " ++ x ++ " : " ++ show tv12) $ do + cxtenv <- ask + let (k, delta) = cxtPushEntry (tv12, dec) (context cxtenv) + v12 <- Traversable.mapM (up (VGen k)) tv12 + let rho = update (environ cxtenv) x v12 + local (\ cxt -> cxt { context = delta + , renaming = Map.insert x k (renaming cxtenv) + , environ = rho }) (f k v12) +-} + setType k dom = + local (\ ce -> ce { context = cxtSetType k dom (context ce) }) + + setTypeOfName x dom cont = do + ce <- ask + let Just k = Map.lookup x (renaming ce) + setType k dom cont + + genOfName x = do + ce <- ask + case Map.lookup x (renaming ce) of + Nothing -> throwErrorMsg $ "internal error: variable not bound: " ++ show x + Just k -> return k + + nameOfGen k = do + ce <- ask + case Map.lookup k (naming ce) of + Nothing -> return $ fresh $ "error_unnamed_gen" ++ show k + -- throwErrorMsg $ "internal error: no name for variable " ++ show k + Just x -> return x + +{- + nameTaken "" = return True + nameTaken x = do + ce <- ask + st <- get + return (Map.member x (renaming ce) || Map.member x (signature st)) +-} + + lookupGen k = do + ce <- ask + cxtLookupGen (context ce) k + + lookupName x = do + ce <- ask + cxtLookupName (context ce) (renaming ce) x + + -- does not work with shadowing! + getContextTele = do + ce <- ask + let cxt = context ce + let ren = renaming ce + let env = envMap $ environ ce + let mkTBind (x,_) = (TBind x .fromOne . domain) <$> cxtLookupName cxt ren x + mapM mkTBind env + + getLen = do + ce <- ask + return $ len (context ce) + + getRen = do + ce <- ask + return $ renaming ce + + -- since we only use getEnv during type checking, no case for Two + -- (during equality/subtype checking, we have values) + getEnv = do + ce <- ask + let (Environ rho mmeas) = environ ce + return $ Environ (map (\ (x, One v) -> (x, v)) rho) mmeas + + applyDec dec = local (\ ce -> ce { context = cxtApplyDec dec (context ce) }) +-- applyDec dec = local (\ ce -> ce { upperDecs = Map.map (compDec dec) (upperDecs ce) }) + + -- resurrection sets "target" status to erased + -- (as opposed to setting "source" status to non-erased) +{- + resurrect = local (\ ce -> ce { upperDecs = + Map.map (\ dec -> dec { erased = True }) (upperDecs ce) }) +-} +{- + resurrect = local (\ ce -> ce { context = cxtResurrect (context ce) }) +-} + + + -- PROBABLY TOO INEFFICIENT + addRewrite rew vs cont = traceRew ("adding rewrite " ++ show rew) $ + -- add rewriting rule + local (\ cxt -> cxt { rewrites = rew : (rewrites cxt) }) $ do + ce <- ask + -- normalize all types in context + traceRewM "normalizing types in context" + cx' <- mapMapM (Traversable.mapM (Traversable.mapM reval)) (cxt (context ce)) -- LOOP! + -- normalize environment + traceRewM "normalizing environment" + let Environ rho mmeas = environ ce + rho' <- mapM (\ (x,v12) -> Traversable.mapM reval v12 >>= \ v12' -> return (x, v12')) rho + let en' = Environ rho' mmeas -- no need to rewrite in measure since only size expressions + -- normalize given values + vs' <- mapM reval vs + -- continue in updated context + local (\ ce -> ce { context = (context ce) { cxt = cx' } + , environ = en' }) $ cont vs' + + -- addPattern :: TVal -> Pattern -> (TVal -> Val -> Env -> m a) -> m a + addPattern tv@(VQuant Pi x dom fv) p rho cont = + case p of + VarP y -> underAbs y dom fv $ \ _ xv bv -> do + cont bv xv (update rho y xv) + + SizeP e y -> underAbs y dom fv $ \ j xv bv -> do + ve <- whnf' e + addBoundHyp (Bound Lt (Measure [xv]) (Measure [ve])) $ + cont bv xv (update rho y xv) +{- + SizeP z y -> newWithGen y dom $ \ j xv -> do + bv <- whnf (update env x xv) b + VGen k <- whnf' (Var z) + addSizeRel j 1 k $ + cont bv xv (update rho y xv) +-} + ConP pi n pl -> do + sige <- lookupSymbQ n + vc <- conLType n (typ dom) + addPatterns vc pl rho $ \ vc' vpl rho -> do -- apply dom to pl? + pv0 <- mkConVal notDotted (coPat pi) n vpl vc + pv <- up False pv0 (typ dom) + vb <- app fv pv + cont vb pv rho +{- + ConP pi n pl -> do + sige <- lookupSymb n + let vc = symbTyp sige + addPatterns vc pl rho $ \ vc' vpl rho -> do -- apply dom to pl? + pv0 <- foldM app (vCon (coPat pi) n) vpl + pv <- up False pv0 (typ dom) + vb <- whnf (update env x pv) b + cont vb pv rho +-} + SuccP p2 -> do + addPattern (vSize `arrow` vSize) p2 rho $ \ _ vp2 rho -> do + let pv = succSize vp2 + vb <- app fv pv + cont vb pv rho + + ErasedP p -> addPattern tv p rho cont + +-- for dot patterns, we have to do something smart, because they might +-- contain identifiers which are not yet in scope, only after adding +-- other patterns +-- the following trivial solution only works for trivial dot patterns, i.e., +-- such that do not use yet undeclared identifiers + + DotP e -> do + v <- whnf rho e + vb <- app fv v + cont vb v rho -- [(x,v)] + + + addPatterns tv [] rho cont = cont tv [] rho + addPatterns tv (p:ps) rho cont = + addPattern tv p rho $ \ tv' v env -> + addPatterns tv' ps env $ \ tv'' vs env' -> + cont tv'' (v:vs) env' -- (env' ++ env) + + addSizeRel son dist father k = do + let s = "v" ++ show son ++ " + " ++ show dist ++ " <= v" ++ show father + enter -- enterTrace + ("adding size rel. " ++ s) $ do + let modBI belowInfty = if father `elem` belowInfty || dist > 0 then son : belowInfty else belowInfty + whenM (asks consistencyCheck `andLazy` do + TSO.increasesHeight son (dist, father) <$> asks sizeRels) $ do + recoverFail $ "cannot add hypothesis " ++ s ++ " because it is not satisfyable under all possible valuations of the current hypotheses" + -- if the new son is an ancestor of the father, we are cyclic + whenJustM (TSO.isAncestor father son <$> asks sizeRels) $ \ n -> -- n steps from father up to son + when (dist > - n) $ -- still ok if dist == n == 0, otherwise fail + recoverFail$ "cannot add hypothesis " ++ s ++ " because it makes the set of hyptheses unsatisfiable" + local (\ cxt -> cxt + { sizeRels = TSO.insert son (dist, father) (sizeRels cxt) + , belowInfty = modBI (belowInfty cxt) + }) k + + addBelowInfty i = local $ \ cxt -> cxt { belowInfty = i : belowInfty cxt } + + addBoundHyp beta@(Bound ltle (Measure mu) (Measure mu')) cont = + case (ltle, mu, mu') of + (Le, _, [VInfty]) -> cont +-- (Lt, _, [VInfty]) -> failure -- handle j < # + (ltle, [v], [v']) -> loop (if ltle==Lt then 1 else 0) v v' + _ -> failure + where failure = do +-- recoverFail $ "adding hypothetical constraint " ++ show beta ++ " not supported" + assertDoc' Warning False (text "hypothetical constraint" <+> prettyTCM beta <+> text "ignored") + cont + + loop n (VGen i) VInfty = addBelowInfty i cont + loop n (VGen i) (VGen j) | n >= 0 = addSizeRel i n j cont + | otherwise = addIrregularBound i j (-n) cont + loop n (VSucc v) v' = loop (n + 1) v v' + loop n v (VSucc v') = loop (n - 1) v v' + loop _ _ _ = failure + + addIrregularBound i j n = local (\ ce -> ce { bounds = beta : bounds ce }) where + v' = iterate VSucc (VGen j) !! n + beta = Bound Le (Measure [VGen i]) (Measure [v']) + + isBelowInfty i = (i `elem`) <$> asks belowInfty + +{- + isBelowInfty i = do + belowInfty <- asks belowInfty + if (i `elem` belowInfty) then return True else do + tso <- asks sizeRels + loop $ parents i tso where + loop [] = return False + loop [(_,j)] = return $ j `elem` belowInfty + loop (x:xs) = loop xs +-} + + sizeVarBelow son ancestor = do + cxt <- ask + return $ TSO.isAncestor son ancestor (sizeRels cxt) +{- + getSizeDiff son ancestor = do + cxt <- ask + return $ TSO.diff son ancestor (sizeRels cxt) +-} + getMinSize parent = do + cxt <- ask + return $ TSO.height parent (sizeRels cxt) + + getSizeVarsInScope = do + TCContext { context = delta, naming = nam } <- ask + -- get all the size variables with positive or mixed polarity + let fSize (i, tv12) = + case tv12 of + One dom -> isVSize $ typ dom + _ -> -- trace ("not a size variable " ++ show i ++ " : " ++ show tv12) $ + False + -- create a list of key (gen) and Domain pairs for the size variables + let idl = filter fSize $ Map.toAscList (cxt delta) + let udecs = upperDecs delta + let fPos (i, One dom) = + case fromPProd (polarity (Maybe.fromJust (Map.lookup i udecs))) of + Just p -> leqPol (polarity (decor dom)) p + Nothing -> False + let fName (i, _) = Maybe.fromJust $ Map.lookup i nam + return $ map fName $ filter fPos idl + + + checkingCon b = local (\ cxt -> cxt { checkingConType = b}) + +{- + checkingDom = local $ \ cxt -> + if checkingConType cxt then cxt + else cxt { context = cxtApplyDec (Dec False Neg) (context cxt) } +-} + -- check domain A of (x : A) -> B + checkingDom k = do + b <- asks checkingConType + if b then k else applyDec (Dec Neg) k + + setCo co = local (\ cxt -> cxt { mutualCo = co }) + + -- install functions for checking function clauses + -- ==> use internal names + installFuns co kfuns k = do + let funt = foldl (\ m fun@(Kinded _ (Fun (TypeSig n _) n' _ _)) -> Map.insert n fun m) + Map.empty + kfuns + local (\ cxt -> cxt { mutualCo = co, funsTemplate = funt }) k + + setMeasure mu k = do + rho0 <- getEnv + let rho = rho0 { envBound = Just mu } + local (\ cxt -> cxt + { environ = (environ cxt) { envBound = Just mu } + }) k + + activateFuns k = do + rho <- getEnv + case (envBound rho) of + Nothing -> k + Just mu -> + local (\ cxt -> cxt + { mutualFuns = + Map.map (boundFun rho (mutualCo cxt)) (funsTemplate cxt) + }) k + where boundFun :: Env -> Co -> Kinded Fun -> SigDef + boundFun rho co (Kinded ki (Fun (TypeSig n t) n' ar cls)) = + FunSig co (VClos rho t) ki ar cls False undefined + +{- + activateFuns mu k = do + rho0 <- getEnv + let rho = rho0 { envBound = Just mu } + local (\ cxt -> cxt + { environ = (environ cxt) { envBound = Just mu } + , mutualFuns = + Map.map (boundFun rho (mutualCo cxt)) (funsTemplate cxt) + }) k + where boundFun :: Env -> Co -> Fun -> SigDef + boundFun rho co (TypeSig n t, (ar, cls)) = + FunSig co (VClos rho t) ar cls False + -} + + goImpredicative = local (\ cxt -> cxt { impredicative = True }) + + checkingMutual mn = local (\ cxt -> cxt { checkingMutualName = mn }) + +-- | Go into the codomain of a Pi-type or open an abstraction. +underAbs :: Name -> Domain -> FVal -> (Int -> Val -> Val -> TypeCheck a) -> TypeCheck a +underAbs x dom fv cont = newWithGen x dom $ \ i xv -> cont i xv =<< app fv xv + +-- | Do not check consistency preservation of context. +underAbs_ :: Name -> Domain -> FVal -> (Int -> Val -> Val -> TypeCheck a) -> TypeCheck a +underAbs_ x dom fv cont = noConsistencyChecking $ underAbs x dom fv cont + +noConsistencyChecking = local $ \ cxt -> cxt { consistencyCheck = False } + +-- | No eta, no hypotheses. First returned val is a @VGen i@. +underAbs' :: Name -> FVal -> (Val -> Val -> TypeCheck a) -> TypeCheck a +underAbs' x fv cont = addName x $ \ xv -> cont xv =<< app fv xv + +-- addBind :: MonadTCM m => TBind -> m a -> m a +addBind :: TBind -> TypeCheck a -> TypeCheck a +addBind (TBind x dom) cont = do + dom' <- (Traversable.mapM whnf' dom) + new' x dom' cont + +addBinds :: Telescope -> TypeCheck a -> TypeCheck a +addBinds tel k0 = foldr addBind k0 $ telescope tel + +-- introduce patterns into context and environment ------------------- +-- DOES NOT ETA-EXPAND VARIABLES!! ----------------------------------- + +introPatterns :: [Pattern] -> TVal -> ([(Pattern,Val)] -> TVal -> TypeCheck a) -> TypeCheck a +introPatterns ps tv cont = -- Problem: NO ETA EXPANSION! + introPatVars ps $ do -- first bind pattern variables + vs <- mapM (whnf' . patternToExpr) ps -- now we can evaluate patterns + let pvs = zip ps vs + introPatTypes pvs tv (cont pvs) -- now we can assign types to pvars + +-- introduce variables bound in pattern into the environment +-- extend delta by generic values but do not introduce their types +-- this is to deal with dot patterns +introPatVar :: Pattern -> TypeCheck a -> TypeCheck a +introPatVar p cont = + case p of + VarP n -> addName n $ \ _ -> cont + SizeP m n -> addName n $ \ _ -> cont + ConP co n pl -> introPatVars pl cont + PairP p1 p2 -> introPatVars [p1,p2] cont + SuccP p -> introPatVar p cont + ProjP{} -> cont + DotP e -> cont + AbsurdP -> cont + ErasedP p -> introPatVar p cont + +introPatVars :: [Pattern] -> TypeCheck a -> TypeCheck a +introPatVars [] cont = cont +introPatVars (p:ps) cont = introPatVar p $ introPatVars ps $ cont + +-- if the bindings name->gen are already in the environment +-- we can now bind the gen to their types +introPatType :: (Pattern,Val) -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a +introPatType (p,v) tv cont = do + case tv of + VGuard beta bv -> addBoundHyp beta $ introPatType (p,v) bv cont + VApp (VDef (DefId DatK d)) vl -> + case p of + ProjP n -> cont =<< projectType tv n VIrr -- no record value here + _ -> throwErrorMsg $ "introPatType: internal error, expected projection pattern, found " ++ show p ++ " at type " ++ show tv + VQuant Pi x dom fv -> do + v <- whnfClos v + matchPatType (p,v) dom . cont =<< app fv v + _ -> throwErrorMsg $ "introPatType: internal error, expected Pi-type, found " ++ show tv + +introPatTypes :: [(Pattern,Val)] -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a +introPatTypes pvs tv f = do + case pvs of + [] -> f tv + (pv:pvs') -> introPatType pv tv $ \ tv' -> introPatTypes pvs' tv' f + +matchPatType :: (Pattern, Val) -> Domain -> TypeCheck a -> TypeCheck a +matchPatType (p,v) dom cont = + case (p,v) of + -- erasure does not matter! + (VarP y, VGen k) -> setType k dom $ cont + + (SizeP z y, VGen k) -> setType k dom $ cont + + (ConP co n [], _) -> cont + + (ConP co n pl, VApp (VDef (DefId ConK{} _)) vl) -> do +{- + sige <- lookupSymb n + let vc = symbTyp sige +-} + vc <- conType n =<< force (typ dom) + introPatTypes (zip pl vl) vc $ \ _ -> cont + + (SuccP p2, VSucc v2) -> matchPatType (p2, v2) (defaultDomain vSize) $ cont + + (PairP p1 p2, VPair v1 v2) -> do + av <- force (typ dom) + case av of + VQuant Sigma x dom1@(Domain av1 ki dec) fv -> do + matchPatType (p1,v1) dom1 $ do + bv <- app fv v1 + matchPatType (p2,v2) (Domain bv ki dec) cont + _ -> throwErrorMsg $ "matchPatType: IMPOSSIBLE " ++ show p ++ " : " ++ show dom + + (DotP e, _) -> cont + (AbsurdP, _) -> cont + (ErasedP p,_) -> matchPatType (p,v) dom cont + _ -> throwErrorMsg $ "matchPatType: IMPOSSIBLE " ++ show (p,v) + + +-- Signature ----------------------------------------------------- + +-- input to and output of the type-checker + +type Signature = Map QName SigDef + +-- a signature entry is either +-- * a fun/cofun, +-- * a defined constant, +-- * a constructor, or +-- * a data type id with its kind +-- they share "symbTyp", the type signature of the definition +data SigDef + = FunSig { isCo :: Co + , symbTyp :: TVal + , symbolKind :: Kind + , arity :: Arity + , clauses :: [Clause] + , isTypeChecked :: Bool + , extrTyp :: Expr -- ^ Fomega type. + } + | LetSig { symbTyp :: TVal + , symbolKind :: Kind + , definingVal :: Val +-- , definingExpr :: Expr + , extrTyp :: Expr -- ^ Fomega type. + } + | PatSig { patVars :: [Name] + , definingPat :: Pattern + , definingVal :: Val + } + | ConSig { conPars :: ConPars + -- ^ Parameter patterns and no. of variable they bind. + -- @Nothing@ if old-style parameters. + , lhsTyp :: LHSType + -- ^ LHS type of constructor for pattern matching, e.g. + -- rhs @cons : [A : Set] [i : Size] -> A -> List A i -> List A $i@ + -- lhs @cons : [A : Set] [i : Size] [j < i] -> A -> List A j -> List A i@ + -- @Name@ is the name of the size parameter. + , recOccs :: [Bool] + -- ^ @True@ if argument contains rec.occs.of the (co)data type? + , symbTyp :: TVal -- ^ (RHS) type, includs parameter tel. + , dataName :: Name -- ^ Its datatype. + , dataPars :: Int -- ^ No. of parameters of its datatype. + , extrTyp :: Expr -- ^ Fomega type. + } + | DataSig { numPars :: Int + , positivity :: [Pol] + , isSized :: Sized + , isCo :: Co + , symbTyp :: TVal + , symbolKind :: Kind + -- the following information is only needed for eta-expansion + -- hence it is only provided for suitable ind.fams. + , constructors :: [ConstructorInfo] + , etaExpand :: Bool -- non-overlapping pattern inductive family + -- with at least one eta-expandable constructor + , isTuple :: Bool -- each constructor is irrefutable + -- must be (NEW: non-overlapping) pattern inductive family + -- qualifies for target of corecursive fun + -- NO LONGER: exactly one constructor + -- NOW: at least one constructor + -- can be recursive + , extrTyp :: Expr -- Fomega kind +{- + , destructors :: Maybe [Name] -- Nothing if not a record + , isFamily :: Bool +-} + } -- # parameters, positivity of parameters , sized , co , type + deriving (Show) + +-- | Parameter patterns and no. of variables they bind. +type ConPars = Maybe ([Name], [Pattern]) + +-- | LHS type plus name of size index. +type LHSType = Maybe (Name, TVal) + +isEmptyData :: QName -> TypeCheck Bool +isEmptyData n = do + sig <- lookupSymbQ n + case sig of + DataSig { constructors } -> return $ null constructors + _ -> throwErrorMsg $ "internal error: isEmptyData " ++ show n ++ ": name of data type expected" + +isUnitData :: QName -> TypeCheck Bool +isUnitData n = do + sig <- lookupSymbQ n + case sig of + DataSig { constructors = [c], isTuple } -> return $ + isTuple && null (cFields c) && cPatFam c == (LinearPatterns, []) + DataSig { constructors } -> return False + _ -> throwErrorMsg $ "internal error: isUnitData " ++ show n ++ ": name of data type expected" + + +undefinedFType :: QName -> Expr +undefinedFType n = Irr +-- undefinedFType n = error $ "no extracted type for " ++ show n + +symbKind :: SigDef -> Kind +symbKind ConSig{} = kTerm -- constructors are always terms +symbKind d = symbolKind d -- else: lookup +{- Data types can be big!! +symbKind DataSig{} = kType -- data types are never universes +-} + +emptySig = Map.empty + +-- Handling constructor types ------------------------------------------ + +data DataView + = Data Name [Clos] + | NoData + +-- | Check if type @tv@ is a datatype @D vs@. +dataView :: TVal -> TypeCheck DataView +dataView tv = do + tv <- force tv + case tv of +{- 2012-01-31 EVIL, LEADS TO UNBOUND VARS: + VQuant Pi x dom env b -> do + new x dom $ \ xv -> dataView =<< whnf (update env x xv) b +-} + VApp (VDef (DefId DatK n)) vs -> return $ Data (unqual n) vs + VSing v dv -> dataView =<< whnfClos dv + _ -> return $ NoData + +-- | Disambiguate possibly overloaded constructor @c@ at given type @tv@. +disambigCon :: QName -> TVal -> TypeCheck QName +disambigCon c tv = + case c of + Qual{} -> return c + QName n -> do + dv <- dataView tv + case dv of + Data d _ -> return $ Qual d n + _ -> throwErrorMsg $ "cannot resolve constructor " ++ show n + +-- | @conType c tv@ returns the type of constructor @c@ at datatype @tv@ +-- with parameters instantiated. +conType :: QName -> TVal -> TypeCheck TVal +conType c tv = do + c <- disambigCon c tv + ConSig { conPars, symbTyp, dataName, dataPars } <- lookupSymbQ c + instConType c conPars symbTyp dataName dataPars tv + +-- | Get LHS type of constructor. +-- +-- Constructors or sized data types internally have a lhs type +-- that differs from its rhs type. E.g., +-- rhs @suc : [i : Size] -> Nat i -> Nat $i@ +-- lhs @suc : [i : Size] [j < i] -> Nat j -> Nat i@. +-- In the lhs type, @i@ turns into an additional parameter. +conLType :: QName -> TVal -> TypeCheck TVal +conLType c tv = do + c <- disambigCon c tv + ConSig { conPars, lhsTyp, symbTyp, dataName, dataPars } <- lookupSymbQ c + case lhsTyp of + Nothing -> instConType c conPars symbTyp dataName dataPars tv + Just (x, lTyp) -> instConType c (fmap (inc x) conPars) lTyp dataName (dataPars+1) tv + where inc x (xs, ps) = (xs ++ [x], ps ++ [VarP x]) + +-- | Instantiate type of constructor to parameters obtained from +-- the data type. +-- +-- @instConType c n symbTyp dataName tv@ +-- instantiates type @symbTyp@ of constructor @c@ with first @n@ arguments +-- that @dataName@ is applied to in @tv@. +-- @@ +-- instConType c n ((x1:A1..xn:An) -> B) d (d v1..vn ws) = B[vs/xs] +-- @@ +instConType :: QName -> ConPars -> TVal -> Name -> Int -> TVal -> TypeCheck TVal +instConType c conPars symbTyp dataName dataPars tv = + instConLType' c conPars symbTyp Nothing (Just dataName) dataPars tv +{- +instConType c numPars symbTyp dataName tv = do + dv <- dataView tv + case dv of + NoData -> failDoc (text ("conType " ++ show c ++ ": expected") + <+> prettyTCM tv <+> text "to be a data type") + Data d vs -> do + unless (d == dataName) $ throwErrorMsg $ "expected constructor of datatype " ++ show d ++ ", but found one of datatype " ++ show dataName + let (pars, inds) = splitAt numPars vs + unless (length pars == numPars) $ + failDoc (text ("conType " ++ show c ++ ": expected") + <+> prettyTCM tv + <+> text ("to be a data type applied to all of its " ++ + show numPars ++ " parameters")) + piApps symbTyp pars +-} + +-- | Get correct lhs type for constructor pattern. +-- +-- @instConLType c numPars symbTyp Nothing isFlex tv@ behaves like +-- @instConLType c numPars symbType _ tv@. +-- +-- But if the data types is sized and the constructor has a lhs type, +-- @instConLType c numPars symbTyp (Just ltv) isFlex tv@ +-- uses the lhs type @ltv@ unless the variable instantiated for +-- the size argument is flexible (because then it wants to be +-- unified with the successor pattern of the rhs type. +instConLType :: QName -> ConPars -> TVal -> LHSType -> (Val -> Bool) -> Int -> TVal -> TypeCheck TVal +instConLType c conPars rhsTyp lhsTyp isFlex dataPars dataTyp = + instConLType' c conPars rhsTyp (fmap (,isFlex) lhsTyp) Nothing dataPars dataTyp + +-- | The common pattern behind @instConType@ and @instConLType@. +instConLType' :: QName -> ConPars -> TVal -> Maybe ((Name, TVal), Val -> Bool) -> Maybe Name -> Int -> TVal -> TypeCheck TVal +instConLType' c conPars symbTyp isSized md dataPars tv = + enter ("instConLType'") $ do + let failure = failDoc (text ("conType " ++ show c ++ ": expected") + <+> prettyTCM tv + <+> text ("to be a data type applied to all of its " ++ + show dataPars ++ " parameters")) + dv <- dataView tv + case dv of + NoData -> failDoc (text ("conType " ++ show c ++ ": expected") + <+> prettyTCM tv <+> text "to be a data type") + Data d vs -> do + whenJust md $ \ d' -> + unless (d == d') $ throwErrorMsg $ "expected constructor of datatype " ++ show d ++ ", but found one of datatype " ++ show d' + -- whenJust conPars $ throwErrorMsg $ "NYI: constructor with pattern parameters" + let (pars, inds) = splitAt dataPars vs + unless (length pars == dataPars) failure + case (isSized, inds) of + (Just _, []) -> failure + -- if size index not flexible, use lhs type + (Just ((x,ltv), isFlex), sizeInd:_) | not (isFlex sizeInd) -> + continue d [x] ltv (pars ++ [sizeInd]) + -- otherwise, use rhs type + _ -> continue d [] symbTyp pars + where + continue d ys tv pars = case conPars of + Nothing -> piApps tv pars + Just (xs, ps) -> do + let failure = failDoc $ sep + [ text "instConType:" + , text "cannot match parameters" <+> prettyList (map prettyTCM pars) + , text "against patterns" <+> prettyList (map prettyTCM ps) + , text "when instantiating type" <+> prettyTCM tv + , text ("of constructor " ++ show c) + ] + -- clear dots here: + mst <- nonLinMatchList' True True (emptyEnv, []) ps pars =<< lookupSymbTyp d + case mst of + Nothing -> failure + Just (Environ{ envMap = env0 }, psub) -> do + let env = env0 ++ [ (x, VGen i) | (i, VarP x) <- psub ] + -- if length env /= length xs then failure else do + vs <- forM (xs ++ ys) $ \ x -> maybe failure return $ lookup x env + piApps tv vs +{- + menv <- matchList emptyEnv ps pars + case menv of + Nothing -> failure + Just Environ{ envMap = env } -> if length env /= length xs then failure else do + vs <- forM (xs ++ ys) $ \ x -> maybe failure return $ lookup x env + piApps tv vs +-} + +{- + case isSized of + Nothing -> piApps symbTyp pars + Just ltv -> do + when (null inds) failure + let sizeInd = head inds + if isFlex sizeInd then piApps symbTyp pars else piApps ltv (pars ++ [sizeInd]) +-} + +-- Signature specification ------------------------------------------- + +class MonadCxt m => MonadSig m where + lookupSymbTypQ :: QName -> m TVal + lookupSymbQ :: QName -> m SigDef + addSigQ :: QName -> SigDef -> m () + modifySigQ :: QName -> (SigDef -> SigDef) -> m () + setExtrTypQ :: QName -> Expr -> m () + + lookupSymbTyp :: Name -> m TVal + lookupSymbTyp = lookupSymbTypQ . QName + + lookupSymb :: Name -> m SigDef + lookupSymb = lookupSymbQ . QName + + addSig :: Name -> SigDef -> m () + addSig = addSigQ . QName + + modifySig :: Name -> (SigDef -> SigDef) -> m () + modifySig = modifySigQ . QName + + setExtrTyp :: Name -> Expr -> m () + setExtrTyp = setExtrTypQ . QName + +-- Signature implementation ------------------------------------------ + +instance MonadSig TypeCheck where + + -- first in context, then in signature + -- lookupSymbTyp :: Name -> TypeCheck TVal + lookupSymbTyp n = do + mdom <- errorToMaybe $ lookupName1 n + case mdom of + Just (CxtEntry dom udec) -> return (typ dom) + Nothing -> symbTyp <$> lookupSymb n + + lookupSymbTypQ (QName n) = lookupSymbTyp n + lookupSymbTypQ n@Qual{} = symbTyp <$> lookupSymbQ n + + -- lookupSymb :: Name -> TypeCheck SigDef + lookupSymb n = do + cxt <- ask + case Map.lookup n (mutualFuns cxt) of + Just k -> return $ k + Nothing -> lookupSymbInSig (QName n) + + lookupSymbQ (QName n) = lookupSymb n + lookupSymbQ n@Qual{} = lookupSymbInSig n + + -- addSig :: Name -> SigDef -> TypeCheck () + addSigQ n def = traceSig ("addSig: " ++ show n ++ " is bound to " ++ show def) $do + st <- get + put $ st { signature = Map.insert n def $ signature st } + + -- modifySig :: Name -> (SigDef -> SigDef) -> TypeCheck () + modifySigQ n f = do + st <- get + put $ st { signature = Map.adjust f n $ signature st } + + -- setExtrTyp :: Name -> Expr -> TypeCheck () + setExtrTypQ n t = modifySigQ n (\ d -> d { extrTyp = t }) + +lookupSymbInSig :: QName -> TypeCheck SigDef +lookupSymbInSig n = lookupSig n =<< gets signature + where + -- lookupSig :: Name -> Signature -> TypeCheck SigDef + lookupSig n sig = + case (Map.lookup n sig) of + Nothing -> throwErrorMsg $ "identifier " ++ show n ++ " not in signature " ++ show (Map.keys sig) + Just k -> return k + + +-- more on the type checking monad ------------------------------- + +initSt :: TCState +initSt = TCState emptySig emptyMetaVars emptyConstraints emptyPosGraph -- emptyDots + +initWithSig :: Signature -> TCState +initWithSig sig = initSt { signature = sig } + +-- Meta-variable and constraint handling specification --------------- + +class Monad m => MonadMeta m where + resetConstraints :: m () + mkConstraint :: Val -> Val -> m (Maybe Constraint) + addMeta :: Ren -> MVar -> m () + addLeq :: Val -> Val -> m () + + addLe :: LtLe -> Val -> Val -> m () + addLe Le v1 v2 = addLeq v1 v2 + addLe Lt v1 v2 = addLeq (succSize v1) v2 -- broken for # + + solveConstraints :: m Solution + + -- solve constraints and substitute solution into the analyzed expressions + solveAndModify :: [Expr] -> Env -> m [Expr] + solveAndModify es rho = do + sol <- solveConstraints + let es' = map (subst (solToSubst sol rho)) es + resetConstraints + return es' + +-- Constraints implementation ---------------------------------------- + +instance MonadMeta TypeCheck where + + --resetConstraints :: TypeCheck () + resetConstraints = do + st <- get + put $ st { constraints = emptyConstraints } + + -- mkConstraint :: Val -> Val -> TypeCheck (Maybe Constraint) + mkConstraint v (VMax vs) = do + bs <- mapM (errorToBool . leqSize' v) vs + if any id bs then return Nothing else + throwErrorMsg $ "cannot handle constraint " ++ show v ++ " <= " ++ show (VMax vs) + mkConstraint w@(VMax vs) v = throwErrorMsg $ "cannot handle constraint " ++ show w ++ " <= " ++ show v + mkConstraint (VMeta i rho n) (VMeta j rho' m) = retret $ arc (Flex i) (m-n) (Flex j) + mkConstraint (VMeta i rho n) VInfty = retret $ arc (Flex i) 0 (Rigid (RConst Infinite)) + mkConstraint (VMeta i rho n) v = retret $ arc (Flex i) (m-n) (Rigid (RVar j)) + where (j,m) = vGenSuccs v 0 + mkConstraint VInfty (VMeta i rho n) = retret $ arc (Rigid (RConst Infinite)) 0 (Flex i) + mkConstraint v (VMeta j rho m) = retret $ arc (Rigid (RVar i)) (m-n) (Flex j) + where (i,n) = vGenSuccs v 0 + mkConstraint v1 v2 = throwErrorMsg $ "mkConstraint undefined for " ++ show (v1,v2) + + -- addMeta k x adds a metavariable which can refer to VGens < k + -- addMeta :: Ren -> MVar -> TypeCheck () + addMeta ren i = do + scope <- getSizeVarsInScope + traceMetaM ("addMeta " ++ show i ++ " scope " ++ show scope) + st <- get + put $ st { metaVars = Map.insert i (MetaVar scope Nothing) (metaVars st) + , constraints = NewFlex i (\ k' -> True) -- k' < k) + -- DO NOT ADD constraints of form <= infty !! + -- : arc (Flex i) 0 (Rigid (RConst Infinite)) + : constraints st } + + -- addLeq :: Val -> Val -> TypeCheck () + addLeq v1 v2 = traceMeta ("Constraint: " ++ show v1 ++ " <= " ++ show v2) $ + do mc <- mkConstraint v1 v2 + case mc of + Nothing -> return () + Just c -> do + st <- get + put $ st { constraints = c : constraints st } + + -- solveConstraints :: TypeCheck Solution + solveConstraints = do + cs <- gets constraints + if null cs then return emptySolution + else case solve cs of + Just subst -> traceMeta ("solution" ++ show subst) $ + return subst + Nothing -> throwErrorMsg $ "size constraints " ++ show cs ++ " unsolvable" + + +nameOf :: EnvMap -> Int -> Maybe Name +nameOf [] j = Nothing +nameOf ((x,VGen i):rho) j | i == j = Just x +nameOf (_:rho) j = nameOf rho j + +vGenSuccs (VGen k) m = (k,m) +vGenSuccs (VSucc v) m = vGenSuccs v (m+1) +vGenSuccs v m = error $ "vGenSuccs fails on " ++ Util.parens (show v) ++ " " ++ show m + +retret = return . return + +sizeExprToExpr :: Env -> SizeExpr -> Expr +sizeExprToExpr rho (SizeConst Infinite) = Infty +sizeExprToExpr rho (SizeVar i n) | Just x <- nameOf (envMap rho) i = add (Var x) n + where add e n | n <= 0 = e + | otherwise = add (Succ e) (n-1) +sizeExprToExpr rho e@(SizeVar i n) | Nothing <- nameOf (envMap rho) i = error $ "panic: sizeExprToExpr " ++ Util.parens (show e) ++ ": variable v" ++ show i ++ " not in scope " ++ show (envMap rho) + + +maxExpr :: [Expr] -> Expr +maxExpr [] = Infty +maxExpr [e] = e +maxExpr l = if Infty `elem` l then Infty else Max l + +solToSubst :: Solution -> Env -> Subst +solToSubst sol rho = Map.map (maxExpr . map (sizeExprToExpr rho)) sol + + +{- +solToSubst :: Solution -> Env -> Subst +solToSubst sol rho = Map.foldWithKey step Map.empty sol + where step k (SizeVar i n) sub | Just x <- nameOf rho i = + Map.insert k (add (Var x) n) sub + step k (SizeConst Infinite) sub = Map.insert k Infty sub + step _ _ sub = sub + + add e n | n <= 0 = e + | otherwise = add (Succ e) (n-1) +-} + +-- pattern to Value ---------------------------------------------- + +{- RETIRED +patternToVal :: Pattern -> TypeCheck Val +patternToVal p = do + k <- getLen + return $ fst (p2v k p) + +-- turn a pattern into a value +-- dot patterns get variables corresponding to their flexible generic value +p2v :: Int -> Pattern -> (Val,Int) +p2v k p = + case p of + VarP n -> (VGen k,k+1) + ConP co n [] -> (VCon co n,k) + ConP co n pl -> let (vl,k') = ps2vs k pl + in (VApp (VCon co n) vl,k') + SuccP p -> let (v,k') = p2v k p + in (VSucc v,k') + DotP e -> (VGen k,k+1) + +ps2vs :: Int -> [Pattern] -> ([Val],Int) +ps2vs k [] = ([],k) +ps2vs k (p:pl) = let (v,k') = p2v k p + (vl,k'') = ps2vs k' pl + in + (v:vl,k'') +-} diff --git a/src/TCM.hs-boot b/src/TCM.hs-boot new file mode 100644 --- /dev/null +++ b/src/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.Except +import Control.Monad.Reader + +data OneOrTwo a = One a | Two a a + +data TCContext +data TCState + +-- type TypeCheck = StateT TCState (ReaderT TCContext (CallStackT String IO)) +type TypeCheck = StateT TCState (ReaderT TCContext (ExceptT TraceError IO)) diff --git a/src/Termination.hs b/src/Termination.hs new file mode 100644 --- /dev/null +++ b/src/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/src/ToHaskell.hs b/src/ToHaskell.hs new file mode 100644 --- /dev/null +++ b/src/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.Except +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Traversable as Trav + +import qualified Language.Haskell.Exts.Syntax as H +import Text.PrettyPrint + +import Polarity +import Abstract +import Extract +import qualified HsSyntax as H +import TraceError +import Util + +-- translation monad + +type Translate = StateT TState (ReaderT TContext (ExceptT TraceError IO)) + +{- no longer needed with mtl-2 +instance Applicative Translate where + pure = return + mf <*> ma = do { f <- mf; a <- ma; return (f a) } +-} + +data TState = TState + +initSt :: TState +initSt = TState + +data TContext = TContext + +initCxt :: TContext +initCxt = TContext + +runTranslate :: Translate a -> IO (Either TraceError a) +runTranslate t = runExceptT (runReaderT (evalStateT t initSt) initCxt) + +-- translation + +translateModule :: [EDeclaration] -> Translate (H.Module) +translateModule ds = do + hs <- translateDecls ds + return $ H.mkModule hs + +translateDecls :: [EDeclaration] -> Translate [H.Decl] +translateDecls ds = concat <$> mapM translateDecl ds + +translateDecl :: EDeclaration -> Translate [H.Decl] +translateDecl d = + case d of + MutualDecl _ ds -> translateDecls ds + OverrideDecl{} -> throwErrorMsg $ "translateDecls internal error: overrides impossible" + MutualFunDecl _ _ funs -> translateFuns funs + FunDecl _ fun -> translateFun fun + LetDecl _ x tel (Just t) e | null tel -> translateLet x t e + DataDecl n _ _ _ tel fkind cs _ -> translateDataDecl n tel fkind cs + +translateFuns :: [Fun] -> Translate [H.Decl] +translateFuns funs = concat <$> mapM translateFun funs + +translateFun :: Fun -> Translate [H.Decl] +translateFun (Fun ts@(TypeSig n t) n' ar cls) = do + ts@(H.TypeSig _ [n] t) <- translateTypeSig ts + cls <- concat <$> mapM (translateClause n) cls + return [ts, H.FunBind cls] + +translateLet :: Name -> Type -> FExpr -> Translate [H.Decl] +translateLet n t e + | isEtaAlias n = return [] -- skip internal decls + | otherwise = do + ts <- translateTypeSig $ TypeSig n t + e <- translateExpr e + n <- hsName (DefId LetK $ QName n) + return [ ts, H.mkLet n e ] + +translateTypeSig :: TypeSig -> Translate H.Decl +translateTypeSig (TypeSig n t) = do + n <- hsName (DefId LetK $ QName n) + t <- translateType t + return $ H.mkTypeSig n t + +translateDataDecl :: Name -> FTelescope -> FKind -> [FConstructor] -> Translate [H.Decl] +translateDataDecl n tel k cs = do + n <- hsName (DefId DatK $ QName n) + tel <- translateTelescope tel + let k' = translateKind k + cs <- mapM translateConstructor cs + return [H.mkDataDecl n tel k' cs] + +translateConstructor :: FConstructor -> Translate H.GadtDecl +translateConstructor (Constructor n pars t) = do + n <- hsName (DefId (ConK Cons) n) + t' <- translateType t + return $ H.mkConDecl n t' + +translateClause :: H.Name -> Clause -> Translate [H.Match] +translateClause n (Clause _ ps (Just rhs)) = do + ps <- mapM translatePattern ps + rhs <- translateExpr rhs + return [H.mkClause n ps rhs] + +translateTelescope :: FTelescope -> Translate [H.TyVarBind] +translateTelescope (Telescope tel) = mapM translateTBind tel' + -- throw away erasure marks + where tel' = filter (\ tb -> not $ erased $ decor $ boundDom tb) tel + +translateTBind :: TBind -> Translate H.TyVarBind +translateTBind (TBind x dom) = do + x <- hsVarName x + return $ H.KindedVar x $ translateKind (typ dom) + +translateKind :: FKind -> H.Kind +translateKind k = + case k of + k | k == star -> H.KindStar + Quant Pi (TBind _ dom) k' | erased (decor dom) -> translateKind k' + Quant Pi (TBind _ dom) k' -> + translateKind (typ dom) `H.mkKindFun` translateKind k' + +translateType :: FType -> Translate H.Type +translateType t = + case t of + + Irr -> return $ H.unit_tycon + + Quant piSig (TBind _ dom) b | not (erased (decor dom)) -> + H.mkTyPiSig piSig <$> translateType (typ dom) <*> translateType b + + Quant Pi (TBind _ dom) b | typ dom == Irr -> translateType b + + Quant Pi (TBind x dom) b -> do + x <- hsVarName x + let k = translateKind (typ dom) + -- todo: add x to context + t <- translateType b + return $ H.mkForall x k t + + App f a -> H.mkTyApp <$> translateType f <*> translateType a + + Def d@(DefId DatK n) -> (H.TyCon . H.UnQual) <$> hsName d + + Var x -> H.TyVar <$> hsVarName x + + _ -> return H.unit_tycon + +{- TODO: + _ -> throwErrorMsg $ "no Haskell representation for type " ++ show t + -} + +translateExpr :: FExpr -> Translate H.Exp +translateExpr e = + case e of + + Var x -> H.mkVar <$> hsVarName x + + -- constructors + Def f@(DefId (ConK{}) n) -> H.mkCon <$> hsName f + + -- function identifiers + Def f@(DefId _ n) -> H.mkVar <$> hsName f + + -- discard type arguments + App f e0 -> do + f <- translateExpr f + let (er, e) = isErasedExpr e0 + if er then return f else H.mkApp f <$> translateExpr e + + -- discard type lambdas + Lam dec y e -> do + y <- hsVarName y + e <- translateExpr e + return $ if erased dec then e else H.mkLam y e + + LLet (TBind x dom) tel e1 e2 | null tel-> do + x <- hsVarName x + e2 <- translateExpr e2 + if erased (decor dom) then return e2 else do + t <- Trav.mapM translateType (typ dom) + e1 <- translateExpr e1 + return $ H.mkLLet x t e1 e2 + + Pair e1 e2 -> H.mkPair <$> translateExpr e1 <*> translateExpr e2 + + -- TODO + + Ann (Tagged [Cast] e) -> H.mkCast <$> translateExpr e + + _ -> return $ H.unit_con + +translatePattern :: Pattern -> Translate H.Pat +translatePattern p = + case p of + VarP y -> H.PVar <$> hsVarName y + PairP p1 p2 -> H.PTuple H.Boxed <$> mapM translatePattern [p1,p2] + ConP pi n ps -> + H.PApp <$> (H.UnQual <$> hsName (DefId (ConK $ coPat pi) n)) + <*> mapM translatePattern ps + +{- +Name translation + + data names : check capitalization, identity translation + constructor names : prefix with Dataname_ + destructor names : ditto + type-valued lets : check capitalization, identity + type-valued funs : reject! + lets : check lowercase + funs/cofuns : check lowercase +-} + +hsVarName :: Name -> Translate H.Name +hsVarName x = return $ H.Ident $ show x + +hsName :: DefId -> Translate H.Name +hsName id = enter ("error translating identifier " ++ show id) $ + case id of + (DefId DatK (QName x)) -> do + let n = suggestion x + unless (isUpper $ head n) $ + throwErrorMsg $ "data names need to be capitalized" + return $ H.Ident n + (DefId (ConK co) (Qual d x)) -> do + let n = suggestion x + m = suggestion d + return $ H.Ident $ m ++ "_" ++ n + -- dataName <- getDataName x + -- return $ H.Ident $ dataName ++ "_" ++ n + -- lets, funs, cofuns. TODO: type-valued funs! +-- (DefId Let ('_':n)) | -> return $ H.Ident n + (DefId _ x) -> do + let n = suggestion $ unqual x +{- ignore for now + unless (isLower $ head n) $ + throwErrorMsg $ "function names need to start with a lowercase letter" + -} + return $ H.Ident n + +-- getDataName constructorName = return dataNamec +getDataName :: Name -> Translate String +getDataName n = return "DATA" diff --git a/src/Tokens.hs b/src/Tokens.hs new file mode 100644 --- /dev/null +++ b/src/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/src/TraceError.hs b/src/TraceError.hs new file mode 100644 --- /dev/null +++ b/src/TraceError.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} + +module TraceError where + +import Control.Monad.Except +import Debug.Trace + +import Util +import Text.PrettyPrint + +data TraceError = Err String | TrErr String TraceError + +-- instance Error TraceError where +-- noMsg = Err "no message" +-- strMsg s = Err s + +instance Show TraceError where + show (Err str) = str + show (TrErr str err) = str ++ "\n/// " ++ show err + +throwErrorMsg m = throwError (Err m) + +-- newErrorMsg :: (MonadError TraceError m) => m a -> String -> m a +newErrorMsg c s = c `catchError` (\ _ -> throwErrorMsg s) +-- addErrorMsg c s = c `catchError` (\ s' -> throwErrorMsg (s' ++ "\n" ++ s)) + +-- extend the current error message by n +throwTrace x n = x `catchError` ( \e -> throwError $ TrErr n e) +enter n x = throwTrace x n +enterTrace n x = trace n $ throwTrace x n +enterShow n = enter (show n) + +enterDoc :: (MonadError TraceError m, Pretty d) => m d -> m a -> m a +enterDoc md cont = do + d <- md + enter (render (pretty d)) cont + +failDoc :: (MonadError TraceError m) => m Doc -> m a +failDoc d = throwErrorMsg . render =<< d + +newErrorDoc :: (MonadError TraceError m) => m a -> m Doc -> m a +newErrorDoc c d = c `catchError` (\ _ -> failDoc d) + +errorToMaybe :: (MonadError e m) => m a -> m (Maybe a) +errorToMaybe m = (m >>= return . Just) `catchError` (const $ return Nothing) + +errorToBool :: (MonadError e m) => m () -> m Bool +errorToBool m = (m >> return True) `catchError` (\ _ -> return False) + +boolToErrorDoc :: (MonadError TraceError m) => m Doc -> Bool -> m () +boolToErrorDoc d True = return () +boolToErrorDoc d False = failDoc d + +boolToError :: (MonadError TraceError m) => String -> Bool -> m () +boolToError msg True = return () +boolToError msg False = throwErrorMsg msg + +instance MonadError () Maybe where + catchError Nothing k = k () + catchError (Just a) k = Just a + throwError () = Nothing + +orM :: (MonadError e m) => m a -> m a -> m a +orM m1 m2 = m1 `catchError` (const m2) + +-- recoverable errors + +data AssertionHandling = Failure | Warning | Ignore + deriving (Eq,Ord,Show) + +assert' :: (MonadError TraceError m, MonadIO m) => AssertionHandling -> Bool -> String -> m () +assert' Ignore b s = return () +assert' h True s = return () +assert' Warning False s = liftIO $ putStrLn $ "warning: ignoring error: " ++ s +assert' Failure False s = throwErrorMsg s + +assertDoc' :: (MonadError TraceError m, MonadIO m) => AssertionHandling -> Bool -> m Doc -> m () +assertDoc' h b md = assert' h b . render =<< md + +class Monad m => MonadAssert m where + assert :: Bool -> String -> m () + assertDoc :: Bool -> m Doc -> m () + assertDoc b md = assert b . render =<< md + newAssertionHandling :: AssertionHandling -> m a -> m a + recoverFail :: String -> m () + recoverFail = assert False + recoverFailDoc :: m Doc -> m () + recoverFailDoc = assertDoc False + +{- +assert' :: (MonadIO m) => AssertionHandling -> Bool -> String -> m a -> m a +assert' Ignore b s k = k +assert' h True s k = k +assert' Warning False s k = do + liftIO $ putStrLn s + k +assert' Failure False s k = fail s + +class Monad m => MonadAssert m where + assert :: Bool -> String -> m a -> m a + newAssertionHandling :: AssertionHandling -> m a -> m a +-} diff --git a/src/TreeShapedOrder.hs b/src/TreeShapedOrder.hs new file mode 100644 --- /dev/null +++ b/src/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 = headMaybe $ parents a t + +-- | @isAncestor a b o = Just n@ if there are n steps up from a to b. +isAncestor :: (Ord a, Eq a) => a -> a -> TSO a -> Maybe Int +isAncestor a b o = loop 0 ((0,a) : parents a o) + where loop acc [] = Nothing + loop acc ((n,a) : ps) | a == b = Just (acc + n) + | otherwise = loop (acc + n) ps + +-- | @diff a b o = Just k@ if there are k steps up from a to b +-- or (-k) steps down from b to a. +diff :: (Ord a, Eq a) => a -> a -> TSO a -> Maybe Int +diff a b o = maybe (fmap (\ k -> -k) $ isAncestor b a o) Just $ isAncestor a b o + +-- | create a map from parents to list of sons, leaves have an empty list +invert :: (Ord a, Eq a) => TSO a -> Map a [(Int,a)] +invert (TSO o) = Map.foldrWithKey step Map.empty o where + step son (dist, parent) m = Map.insertWith (++) son [] $ + Map.insertWith (++) parent [(dist, son)] m + +-- | @height a t = Just k@ if $k$ is the length of the +-- longest path from @a@ to a leaf. @Nothing@ if @a@ not in @t@. +height :: (Ord a, Eq a) => a -> TSO a -> Maybe Int +height a t = do + let m = invert t + let loop parent = do + sons <- Map.lookup parent m + return $ if null sons then 0 else + maximum $ map (\ (n,son) -> maybe 0 (n +) $ loop son) sons + loop a + +-- | @increasesHeight a (n,b) t = True@ if @n > height b t@, i.e., if +-- the insertion of a with parent b will destroy an existing +-- minimal valuation of @t@ +increasesHeight :: (Ord a, Eq a) => a -> (Int, a) -> TSO a -> Bool +increasesHeight a (n,b) t = n > maybe 0 id (height b t) + +-- | get the leaves of the TSO forest +leaves :: (Ord a, Eq a) => TSO a -> [a] +leaves o = map fst $ filter (\ (parent,sons) -> null sons) $ Map.toList (invert o) + +{- FLAWED BOTTOM-UP-ATTEMPT, DOES NOT WORK +{- How to invert a TSO? + +1. Create a Map from parents to their list of children. + +2. Keep a working set of nodes. + Find the leafs in this working set (nodes that do not have children). + Cluster them by their parents. + Turn their parents into trees, + Continue with the parents. +-} +-- | invert a tree shaped order into a forest. This can be used for printing +toForest :: (Ord a, Eq a) => TSO a -> Forest a +toForest o = loop (step initialTrees) where + initialTrees = map (flip Node []) $ leaves o + -- step :: (Ord a, Eq a) => Forest a -> [(Maybe a, Forest a)] + step ts = map (\ l -> (fst (head l), map snd l)) $ + groupBy (\ (p,t) (p',t') -> p == p') $ + sortBy (\ (p,t) (p',t') -> compare p p') $ + map (\ t -> (parent (rootLabel t) o, t)) ts + -- loop :: (Ord a, Eq a) => [(Maybe a, Forest a)] -> Forest a + loop [] = [] + -- the trees whose roots have no parents are parts of the final forest + loop ((Nothing, roots) : nonroots) = roots ++ loop nonroots + -- the trees whose roots have a parent are iterated + loop nonroots = loop $ step $ map (\ (Just p, ts) -> Node p ts) nonroots +-} + +-- take a lexicographically sorted list of pathes +-- and turn it into a forest by +-- gathering the lists by common prefixes +pathesToForest :: (Ord a, Eq a) => [[(Int,a)]] -> Forest (Int, a) +pathesToForest [] = [] +pathesToForest ll = + map (\ l -> Node (head (head l)) + (pathesToForest $ filter (not . null) $ map tail l)) $ + groupBy (\ l l' -> head l == head l') ll + +-- | invert a tree shaped order into a forest. This can be used for printing. +toForest :: (Ord a, Eq a) => TSO a -> Forest (Int,a) +toForest o = pathesToForest $ sort $ map (\ a -> reverse ((0,a) : parents a o)) $ leaves o -- lex. sort + +instance (Ord a, Eq a, Show a) => Show (TSO a) where + show o = Tree.drawForest $ map (fmap show) $ toForest o + +{- +draw :: (Ord a, Eq a, Show a) => TSO a -> String +draw o = Tree.drawForest $ map (fmap show) $ toForest o +-} + +-- test + +l1 = map (\ (k,l) -> ("i" ++ show k, (1, "i" ++ show l))) [(0,1),(1,2),(2,3),(3,4)] + ++ [("j2",(1,"i3"))] +o1 = fromList l1 +t1 = diff "i2" "i1" o1 +t2 = diff "i2" "j2" o1 +t3 = height "i2" o1 +t4 = height "i4" o1 +t5 = height "k" o1 diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs new file mode 100644 --- /dev/null +++ b/src/TypeChecker.hs @@ -0,0 +1,3301 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, + PatternGuards, TupleSections, NamedFieldPuns #-} + +module TypeChecker where + +import Prelude hiding (null) + +import Control.Applicative hiding (Const) -- ((<$>)) +import Control.Monad +import Control.Monad.Identity +import Control.Monad.State +import Control.Monad.Except +import Control.Monad.Reader + +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Foldable as Foldable +import qualified Data.Traversable as Traversable + +import Debug.Trace + +import qualified Text.PrettyPrint as PP + +import Util +import qualified Util as Util + +import Abstract hiding (Substitute) +import Polarity as Pol +import Value +import TCM +import Eval +import Extract +-- import SPos (nocc) -- RETIRED +-- import CallStack +import PrettyTCM +import TraceError + +import Warshall hiding (Flex) -- size constraint checking + +import Termination + +-- import Completness + + +traceCheck msg a = a -- trace msg a +traceCheckM msg = return () -- traceM msg +{- +traceCheck msg a = trace msg a +traceCheckM msg = traceM msg +-} + +traceSing msg a = a -- trace msg a +traceSingM msg = return () -- traceM msg +{- +traceSing msg a = trace msg a +traceSingM msg = traceM msg +-} + +traceAdm msg a = a -- trace msg a +traceAdmM msg = return () -- traceM msg +{- +traceAdm msg a = trace msg a +traceAdmM msg = traceM msg +-} + +{- DEAD CODE +runWhnf :: Signature -> TypeCheck a -> IO (Either TraceError (a,Signature)) +runWhnf sig tc = (runExceptT (runStateT tc sig)) +-} + +doNf sig e = runExceptT (runReaderT (runStateT (whnf emptyEnv e >>= reify) (initWithSig sig)) emptyContext) +doWhnf sig e = runExceptT (runReaderT (runStateT (whnf emptyEnv e >>= whnfClos) (initWithSig sig)) emptyContext) + + +-- top-level functions ------------------------------------------- + +runTypeCheck :: TCState -> TypeCheck a -> IO (Either TraceError (a,TCState)) +runTypeCheck st tc = runExceptT (runReaderT (runStateT tc st) emptyContext) +-- runTypeCheck st tc = runCallStackT (runReaderT (runStateT tc st) emptyContext) [] + +typeCheck dl = runTypeCheck initSt (typeCheckDecls dl) + +-- checking top-level declarations ------------------------------- + +echo :: MonadIO m => String -> m () +echo = liftIO . putStrLn + +echoR = echo +-- echoR s = echo $ "R> " ++ s + +echoTySig :: (Show n, MonadIO m) => n -> Expr -> m () +echoTySig n t = return () -- echo $ "I> " ++ n ++ " : " ++ show t + +echoKindedTySig :: (Show n, MonadIO m) => Kind -> n -> Expr -> m () +echoKindedTySig ki n t = echo $ prettyKind ki ++ " " ++ show n ++ " : " ++ show t + +echoKindedDef :: (Show n, MonadIO m) => Kind -> n -> Expr -> m () +echoKindedDef ki n t = echo $ prettyKind ki ++ " " ++ show n ++ " = " ++ show t + +echoEPrefix = "E> " + +echoTySigE :: (Show n, MonadIO m) => n -> Expr -> m () +echoTySigE n t = echo $ echoEPrefix ++ show n ++ " : " ++ show t + +echoDefE :: (Show n, MonadIO m) => n -> Expr -> m () +echoDefE n t = echo $ echoEPrefix ++ show n ++ " = " ++ show t + +-- the type checker returns pruned (extracted) terms +-- with irrelevant subterms replaced by Irr +typeCheckDecls :: [Declaration] -> TypeCheck [EDeclaration] +typeCheckDecls [] = return [] +typeCheckDecls (d:ds) = do + de <- typeCheckDeclaration d + dse <- typeCheckDecls ds + return (de ++ dse) + +-- since a data declaration generates destructor declarations +-- we need to return a list here +typeCheckDeclaration :: Declaration -> TypeCheck [EDeclaration] +typeCheckDeclaration (OverrideDecl Check ds) = do + st <- get + typeCheckDecls ds + put st -- forget the effect of these decls + return [] +typeCheckDeclaration (OverrideDecl Fail ds) = do + st <- get + r <- (typeCheckDecls ds >> return True) `catchError` + (\ s -> do liftIO $ putStrLn ("block fails as expected, error message:\n" ++ show s) + return False) + if r then throwErrorMsg "unexpected success" else do + put st + return [] + +typeCheckDeclaration (OverrideDecl TrustMe ds) = + newAssertionHandling Warning $ typeCheckDecls ds + +typeCheckDeclaration (OverrideDecl Impredicative ds) = + goImpredicative $ typeCheckDecls ds + +typeCheckDeclaration (RecordDecl n tel t0 c fields) = + -- just one "mutual" declaration + checkingMutual (Just $ DefId DatK $ QName n) $ do + result <- typeCheckDataDecl n NotSized CoInd [] tel t0 [c] fields + checkPositivityGraph + return result + +typeCheckDeclaration (DataDecl n sz co pos0 tel t0 cs fields) = + -- just one "mutual" declaration + checkingMutual (Just $ DefId DatK $ QName n) $ do + result <- typeCheckDataDecl n sz co pos0 tel t0 cs fields + checkPositivityGraph + return result + +typeCheckDeclaration (LetDecl eval n tel mt e) = enter (show n) $ do +{- MOVED to checkLetDef + (tel, (vt, te, Kinded ki ee)) <- checkTele tel $ checkOrInfer neutralDec e mt + te <- return $ teleToType tel te + ee <- return $ teleLam tel ee + vt <- whnf' te +-} + (vt, te, Kinded ki ee) <- checkLetDef neutralDec tel mt e + rho <- getEnv -- is emptyEnv + -- TODO: solve size constraints + -- does not work with emptyEnv + -- [te, ee] <- solveAndModify [te, ee] rho -- solve size constraints + let v = mkClos rho ee -- delay whnf computation + -- v <- whnf' ee -- WAS: whnf' e' + addSig n (LetSig vt ki v $ undefinedFType $ QName n) -- late (var -> expr) binding, but ok since no shadowing +-- addSig n (LetSig vt e') -- late (var -> expr) binding, but ok since no shadowing + echoKindedTySig ki n te +-- echoTySigE n te +-- echoDefE n ee + echoKindedDef ki n ee + return [LetDecl eval n emptyTel (Just te) ee] + +typeCheckDeclaration d@(PatternDecl x xs p) = do +{- WHY DOES THIS NOT TYPECHECK? + let doc = (PP.text "pattern") <+> (PP.hsep (List.map Util.pretty (x:xs))) <+> PP.equals <+> Util.pretty p + echo $ PP.render $ doc +-} + echo $ "pattern " ++ Util.showList " " show (x:xs) ++ " = " ++ show p + v <- whnf' $ foldr (Lam defaultDec) (patternToExpr p) xs + addSig x (PatSig xs p v) + return [d] + +typeCheckDeclaration (MutualFunDecl False co funs) = + -- traceCheck ("type checking a function block") $ + do + funse <- typeCheckFuns co funs + return $ [MutualFunDecl False co funse] + +typeCheckDeclaration (MutualFunDecl True co funs) = + -- traceCheck ("type checking a block of measured function") $ + do + funse <- typeCheckMeasuredFuns co funs + return $ [MutualFunDecl False co funse] + +typeCheckDeclaration (MutualDecl measured ds) = do + -- first check type signatures + -- we add the typings into the context, not the signature + ktss <- typeCheckMutualSigs ds + -- register the mutually defined names + let ns = for ktss $ \ (Kinded _ (TypeSig n _)) -> n + addMutualNames = local $ \ e -> e { mutualNames = ns ++ mutualNames e } + -- then check bodies + -- we need to construct a positivity graph + edss <- addKindedTypeSigs ktss $ addMutualNames $ + zipWithM (typeCheckMutualBody measured) (map (predKind . kindOf) ktss) ds + -- check and reset positivity graph + checkPositivityGraph + return $ concat edss + + +-- check signatures of a flattened mutual block +typeCheckMutualSigs :: [Declaration] -> TypeCheck [Kinded (TySig TVal)] +typeCheckMutualSigs [] = return [] +typeCheckMutualSigs (d:ds) = do + kts@(Kinded ki (TypeSig n tv)) <- typeCheckMutualSig d + new' n (Domain tv ki defaultDec) $ do + ktss <- typeCheckMutualSigs ds + return $ kts : ktss + +typeCheckSignature :: TySig Type -> TypeCheck (Kinded (TySig TVal)) +typeCheckSignature (TypeSig n t) = do + echoTySig n t + Kinded ki te <- checkType t + tv <- whnf' te + return $ Kinded (predKind ki) $ TypeSig n tv + +typeCheckMutualSig :: Declaration -> TypeCheck (Kinded (TySig TVal)) +typeCheckMutualSig (LetDecl ev n tel (Just t) e) = + typeCheckSignature $ TypeSig n $ teleToType tel t +typeCheckMutualSig (DataDecl n sz co pos tel t cs fields) = do + Kinded ki ts <- typeCheckSignature (TypeSig n (teleToType tel t)) + return $ Kinded ki ts +typeCheckMutualSig (FunDecl co (Fun ts n' ar cls)) = + typeCheckSignature ts +typeCheckMutualSig (OverrideDecl TrustMe [d]) = + newAssertionHandling Warning $ typeCheckMutualSig d +typeCheckMutualSig (OverrideDecl Impredicative [d]) = + goImpredicative $ typeCheckMutualSig d +typeCheckMutualSig d = throwErrorMsg $ "typeCheckMutualSig: panic: unexpected declaration " ++ show d + +-- typeCheckMutualBody measured kindCandidate +typeCheckMutualBody :: Bool -> Kind -> Declaration -> TypeCheck [EDeclaration] +typeCheckMutualBody measured _ (DataDecl n sz co pos tel t cs fields) = do + -- set name of mutual thing whose body we are checking + checkingMutual (Just $ DefId DatK $ QName n) $ + -- + typeCheckDataDecl n sz co pos tel t cs fields +typeCheckMutualBody measured@False ki (FunDecl co fun@(Fun ts@(TypeSig n t) n' ar cls)) = do + checkingMutual (Just $ DefId FunK $ QName n) $ do + fun' <- typeCheckFunBody co ki fun + return $ [FunDecl co fun'] + +typeCheckDataDecl :: Name -> Sized -> Co -> [Pol] -> Telescope -> Type -> [Constructor] -> [Name] -> TypeCheck [EDeclaration] +typeCheckDataDecl n sz co pos0 tel0 t0 cs0 fields = enter (show n) $ + (do -- sig <- gets signature + let params = size tel0 + -- in case we are dealing with a sized type, check that + -- the polarity annotation (if present) at the size arg. is correct. + (p', pos, t) <- do + case sz of + Sized -> do + let polsz = if co==Ind then Pos else Neg + t <- case t0 of + Quant Pi (TBind x (Domain domt ki dec)) b | isSize domt -> + case (polarity dec) of + -- insert correct polarity annotation if none was there + pol | pol `elem` [Param,Rec] -> return $ Quant Pi (TBind x $ Domain tSize kSize $ setPol polsz dec) b + pol | pol == polsz -> return t0 + pol -> throwErrorMsg $ "sized type " ++ show n ++ " has wrong polarity annotation " ++ show pol ++ " at Size argument, it should be " ++ show polsz + t0 -> return t0 + return (params + 1, pos0 ++ [polsz], t) + NotSized -> return (params, pos0, t0) + -- compute full type signature (including parameter telescope) + let dt = (teleToType tel0 t) + echoTySig n dt + {- mmh, this does not work, e.g. data Id (A : Set)(a : A) : A -> Set + then A -> Set is not distinguishable from Set -> Set (GADT) + unclear what to do... + dte <- checkTele tel $ \ tele -> do + te <- checkSmallType t + return (teleToType tele te) + -} + -- get the target sort ds of the datatype + Kinded ki0 (ds, dte) <- checkDataType p' dt -- TODO?: use above code? + let ki = dataKind ki0 + echoKindedTySig ki n dte +-- echoTySigE n dte + v <- whnf emptyEnv dte + Just fkind <- extractKind v + -- get the updated telescope which contains the kinds + let (tel, dtcore) = typeToTele' params dte + -- compute the constructor telescopes + cs0 <- mapM (insertConstructorTele tel dtcore) cs0 + let cis = analyzeConstructors co n tel cs0 + let cs = map reassembleConstructor cis + addSig n (DataSig { numPars = params + , positivity = pos + , isSized = sz + , isCo = co + , symbTyp = v + , symbolKind = ki + , constructors = cis + , etaExpand = False + , isTuple = False +-- if cs==[] then Just [] else Nothing +{- OLD CODE + , constructors = map namePart cs + -- at first, do not add destructors, get them out later + , destructors = Nothing + , isFamily = t /= Set -- currently UNUSED + -} + , extrTyp = fkind + }) + when (sz == Sized) $ + szType co params v + + (isRecList, kcse) <- liftM unzip $ + mapM (typeCheckConstructor n dte sz co pos tel) cs + + -- compute the kind of the data type from the kinds of the + -- constructor arguments (mmh, DOES NOT WORK FOR MUTUAL DATA!) + let newki = case (foldl unionKind NoKind (map kindOf kcse)) of + NoKind -> kType -- no non-rec constructor arguments + AnyKind -> AnyKind + Kind s s' -> Kind (Set Zero) s' -- a data type is always also a type + -- echoKindedTySig newki n dte -- 2012-01-26 disabled (repetitive) + + -- solve for size variables + sol <- solveConstraints + -- TODO: substitute + resetConstraints + + -- add destructors only for the constructors that are non-overlapping + let decls = concat $ map mkDestrs cis + -- cEtaExp = True means that all field names are present + -- and constructor is not overlapping with others + mkDestrs ci | cEtaExp ci = concat $ map mkDestr (cFields ci) + | otherwise = [] + mkDestr fi = + case (fClass fi) of + Field (Just (ty, arity, cl)) | not (erased $ fDec fi) && not (emptyName $ fName fi) -> + let n' = fName fi + n = internal n' + in + [MutualFunDecl False Ind [Fun (TypeSig n ty) n' arity [cl]]] + _ -> [] + + when (not (null decls)) $ + traceCheckM $ "generated destructors: " ++ show decls + declse <- mapM (\ d@(MutualFunDecl False co [Fun (TypeSig n t) n' ar cls]) -> do + -- echo $ "G> " ++ showFun co ++ " " ++ show n ++ " : " ++ show t + -- echo $ "G> " ++ PP.render (prettyFun n cls) + checkingMutual Nothing $ typeCheckDeclaration d) + decls + + -- decide whether to eta-expand at this type + -- all patterns need to be proper and non-overlapping + -- at least one constructor needs to be eta-expandable + let isPatIndFam = all (\ ci -> fst (cPatFam ci) /= NotPatterns && cEtaExp ci) cis +-- && not (or overlapList) + -- do not eta-expand recursive constructors (might not terminate) + let disableRec ci {-ov-} rec' = ci + { cRec = rec' + , cEtaExp = cEtaExp ci -- all destructors present + && fst (cPatFam ci) /= NotPatterns -- proper pattern to compute indices +-- && not ov -- non-overlapping + && not (co==Ind && rec') } -- non-recursive + let cis' = zipWith disableRec cis {-overlapList-} isRecList + let typeEtaExpandable = isPatIndFam && (null cis || any cEtaExp cis') + traceEtaM $ "data " ++ show n ++ " eta-expandable " ++ show typeEtaExpandable ++ " constructors " ++ show cis' + modifySig n (\ dataSig -> + dataSig { symbolKind = newki + , etaExpand = typeEtaExpandable + , constructors = cis' + , isTuple = length cis' >= 1 && isPatIndFam + }) + -- compute extracted data decl + let (tele, te) = typeToTele' (size tel) dte + return $ (DataDecl n sz co pos tele te (map valueOf kcse) fields) : concat declse + + ) -- `throwTrace` n -- in case of an error, add name n to the trace + + +insertConstructorTele :: Telescope -> Type -> Constructor -> TypeCheck Constructor +insertConstructorTele dtel dt c@(Constructor n Nothing t) = return c +insertConstructorTele dtel dt c@(Constructor n Just{} t) = do + res <- computeConstructorTele dtel dt t + return $ Constructor n (Just res) t + +-- | @computeConstructorTele dtel t = return ctel@ +-- Computes the constructor telescope from the target. +computeConstructorTele :: Telescope -> Type -> Type -> TypeCheck (Telescope, [Pattern]) +computeConstructorTele dtel dt t = do + -- target is data name applied to parameters and indices + let (_, target) = typeToTele t + (_, es) = spineView target + pars = take (size dtel) es + (cxt, ps) <- checkConstructorParams pars =<< whnf' (teleToType dtel dt) + (,ps) . setDec (Dec Param) <$> do local (const cxt) $ contextToTele cxt + +-- | @checkConstructorParams pars tv = return cxt@ +-- Checks that parameters @pars@ are patterns elimating the datatype @tv@. +-- Returns a context @cxt@ that binds the pattern variables in +-- left-to-right order. +checkConstructorParams :: [Expr] -> TVal -> TypeCheck (TCContext, [Pattern]) +checkConstructorParams es tv = do + -- for now, we only allow patterns in parameters + -- could be extended to unifyable expressions in general + ps <- mapM (\ e -> maybe (errorParamNotPattern e) return $ exprToPattern e) es + -- no goals from dot patterns, no absurd pattern + ([],_,cxt,_,_,_,False) <- checkPatterns defaultDec [] emptySub tv ps + return (cxt, ps) + + where + errorParamNotPattern e = throwErrorMsg $ + "expected parameter to be a pattern, but I found " ++ show es + +-- | +-- Precondition: @ce@ is included in the current context. +contextToTele :: TCContext -> TypeCheck Telescope +contextToTele ce = do + let n :: Int + n = len (context ce) -- context length + delta :: Map Int (OneOrTwo Domain) + delta = cxt (context ce) -- types for dB levels + names :: Map Int Name + names = naming ce -- names for dB levels + -- traverse the context from left to right + Telescope <$> do + forM [0..n-1] $ \ k -> do + x <- lookupM k names + One dom <- lookupM k delta + TBind x <$> Traversable.traverse toExpr dom + +-- | @typeCheckConstructor d dt sz co pols tel (TypeSig c t)@ +-- +-- returns True if constructor has recursive argument +typeCheckConstructor :: Name -> Type -> Sized -> Co -> [Pol] -> Telescope -> Constructor -> TypeCheck (Bool, Kinded EConstructor) +typeCheckConstructor d dt sz co pos dtel (Constructor n mctel t) = enter ("constructor " ++ show n) $ do + let tel = maybe dtel fst mctel +{- + tel <- case cpars of + -- old style data parameters + Nothing -> return dtel + -- new style pattern parameters + Just{} -> computeConstructorTele dtel dt t +-} + sig <- gets signature + let telE = setDec irrelevantDec tel -- need kinded tel!! + -- parameters are erased in types of constructors + let tt = teleToType telE t + echoTySig n tt + let params = size tel + -- when checking constructor types, do NOT resurrect telescope + -- data T [A : Set] : Set { inn : A -> T A } + -- should be rejected, since A ~= T A, and T A = T B means A ~=B for arb. A, B! + -- add data name as spos var, to check positivity + -- and as NoKind, to compute the true kind from the constructors + let telWithD = Telescope $ (TBind d $ Domain dt NoKind $ Dec SPos) : telescope tel + Kinded ki te <- addBinds telWithD $ + checkConType sz t -- do NOT resurrect telescope!! + + -- Check target of constructor. + dv <- whnf' dt + let (Telescope argts,target) = typeToTele te + whenNothing mctel $ -- only for old-style parameters + addBinds telWithD $ addBinds (Telescope argts) $ checkTarget d dv tel target + + -- Make type of a constructor a singleton type. + let mkName i n | emptyName n = fresh $ "y" ++ show i + | otherwise = n + fields = map boundName argts + argns = zipWith mkName [0..] $ fields + argtbs = zipWith (\ n tb -> tb { boundName = n }) argns argts +-- core = (foldl App (con (coToConK co) n) $ map Var argns) + core = Record (NamedRec (coToConK co) n False notDotted) $ zip fields $ map Var argns + tsing = teleToType (Telescope argtbs) $ Sing core target + + let tte = teleToType telE tsing -- te -- DO resurrect here! + vt <- whnf' tte + + -- Now, compute the remaining information concerning the constructor. + + {- old code was more accurate, since it evaluated before checking + for recursive occurrence. + recOccs <- sposConstructor d 0 pos vt -- get recursive occurrences + -} + mutualNames <- asks mutualNames + let mutOcc tb = not $ null $ List.intersect (d:mutualNames) $ usedDefs $ boundType tb + recOccs = map mutOcc argts + isRec = or recOccs + -- fType <- extractType vt -- moved to Extract + let fType = undefinedFType n + isSz <- if sz /= Sized then return Nothing else do + szConstructor d co params vt -- check correct use of sizes + if co == CoInd then return $ Just $ error "impossible lhs type of coconstructor" else do + let (x, lte) = mapSnd (teleToType telE) $ mkConLType params te + echoKindedTySig kTerm n lte + ltv <- whnf' lte + return $ Just (x, ltv) + + -- Add the type constructor to the signature. + let cpars = fmap (mapFst (map boundName . telescope)) mctel -- deletes types, keeps names + addSigQ n (ConSig cpars isSz recOccs vt d (size dtel) fType) +-- let (tele, te) = typeToTele (length tel) tte -- NOT NECESSARY + echoKindedTySig kTerm n tte + -- traceM ("kind of " ++ n ++ "'s args: " ++ show ki) +-- echoTySigE n tte + return (isRec, Kinded ki $ Constructor n (fmap (mapFst (const telE)) mctel) te) + +typeCheckMeasuredFuns :: Co -> [Fun] -> TypeCheck [EFun] +typeCheckMeasuredFuns co funs0 = do + -- echo $ show funs + kfse <- mapM typeCheckFunSig funs0 -- NO LONGER erases measure + -- use erased type signatures with retaines measure + let funs = zipWith (\ (Kinded ki ts) f -> f { funTypeSig = ts }) kfse funs0 + + -- type check and solve size constraints + -- return clauses with meta vars resolved + kcle <- installFuns co (zipWith Kinded (map kindOf kfse) funs) $ + mapM typeCheckFunClauses funs + let kis = map kindOf kcle + let clse = map valueOf kcle +{- + -- replace old clauses by new ones in funs + let funs' = zipWith (\(tysig,(ar,cls)) cls' -> (tysig,(ar,cls'))) funs clss +-} + -- get the list of mutually defined function names + let funse = List.zipWith4 Fun + (map (fmap eraseMeasure . valueOf) kfse) + (map funExtName funs) + (map funArity funs) + clse + -- print reconstructed clauses + mapM_ (\ (Fun (TypeSig n t) n' ar cls) -> do + -- echoR $ n ++ " : " ++ show t + echoR $ (PP.render $ prettyFun n cls)) + funse + -- replace in signature by erased clauses + zipWithM (enableSig co) (zipWith intersectKind kis $ map kindOf kfse) funse + return $ funse + + where + enableSig :: Co -> Kind -> Fun -> TypeCheck () + enableSig co ki (Fun (TypeSig n t) n' ar' cl') = do + vt <- whnf' t + addSig n (FunSig co vt ki ar' cl' True $ undefinedFType $ QName n) + -- add a let binding for external use + v <- up False (vFun n) vt + addSig n' (LetSig vt ki v $ undefinedFType $ QName n') + + + +-- type check the body of one function in a mutual block +-- type signature is already checked and added to local context +typeCheckFunBody :: Co -> Kind -> Fun -> TypeCheck EFun +typeCheckFunBody co ki0 fun@(Fun ts@(TypeSig n t) n' ar cls0) = do + -- echo $ show fun + addFunSig co $ Kinded ki0 fun + -- type check and solve size constraints + -- return clauses with meta vars resolved + Kinded ki clse <- setCo co $ typeCheckFunClauses fun + + -- check new clauses for admissibility, inserting "unusuable" flags in the patterns where necessary + -- TODO: proper cleanup, proper removal of admissibility check! + -- clse <- admCheckFunSig co names ts clse + + -- print reconstructed clauses + -- echoR $ n ++ " : " ++ show t + echoR $ (PP.render $ prettyFun n clse) + -- replace in signature by erased clauses + let fune = Fun ts n' ar clse + enableSig ki fune + return fune + + +typeCheckFuns :: Co -> [Fun] -> TypeCheck [EFun] +typeCheckFuns co funs0 = do + -- echo $ show funs + kfse <- mapM typeCheckFunSig funs0 + let kfuns = zipWith (\ (Kinded ki ts) (Fun ts0 n' ar cls) -> Kinded ki (Fun ts n' ar cls)) kfse funs0 + -- zipWithM (addFunSig co) (map kindOf kfse) funs + mapM (addFunSig co) kfuns + let funs = map valueOf kfuns + -- type check and solve size constraints + -- return clauses with meta vars resolved + kce <- setCo co $ mapM typeCheckFunClauses funs + let kis = map kindOf kce + let clse = map valueOf kce + -- get the list of mutually defined function names + let names = map (\ (Fun (TypeSig n t) n' ar cls) -> n) funs + -- check new clauses for admissibility, inserting "unusuable" flags in the patterns where necessary + -- TODO: proper cleanup, proper removal of admissibility check! + clse <- zipWithM (\ (Fun tysig _ _ _) cls' -> admCheckFunSig co names tysig cls') funs clse + -- replace old clauses by new ones in funs + let funse = List.zipWith4 Fun + (map valueOf kfse) + (map funExtName funs) + (map funArity funs) + clse +-- let funse = zipWith (\(tysig,(ar,cls)) cls' -> (tysig,(ar,cls'))) funs clse + -- print reconstructed clauses + mapM_ (\ (Fun (TypeSig n t) n' ar cls) -> do + -- echoR $ n ++ " : " ++ show t + echoR $ (PP.render $ prettyFun n cls)) + funse + terminationCheck funse + -- replace in signature by erased clauses + zipWithM enableSig kis funse + return $ funse + +addFunSig :: Co -> Kinded Fun -> TypeCheck () +addFunSig co (Kinded ki (Fun (TypeSig n t) n' ar cl)) = do + sig <- gets signature + vt <- whnf' t -- TODO: PROBLEM for internal extraction (would need te here) + addSig n (FunSig co vt ki ar cl False $ undefinedFType $ QName n) --not yet type checked / termination checked + +-- ADMCHECK FOR COFUN is not taking place in checking the lhs +-- TODO: proper analysis for size patterns! +-- admCheckFunSig mutualNames (TypeSig thisName thisType, clauses) +admCheckFunSig :: Co -> [Name] -> TypeSig -> [Clause] -> TypeCheck [Clause] +admCheckFunSig CoInd mutualNames (TypeSig n t) cls = return cls +admCheckFunSig co@Ind mutualNames (TypeSig n t) cls = traceAdm ("admCheckFunSig: checking admissibility of " ++ show n ++ " : " ++ show t) $ + ( + do -- a function is not recursive if did does not mention any of the + -- mutually defined function names + let usedNames = rhsDefs cls + let notRecursive = all (\ n -> not (n `elem` usedNames)) mutualNames + -- for non-recursive functions, we can skip the admissibility check + if notRecursive then + -- trace ("function " ++ n ++ " is not recursive") $ + return cls + else -- trace ("function " ++ n ++ " is recursive ") $ + do vt <- whnf' t + admFunDef co cls vt + ) `throwTrace` ("checking type of " ++ show n ++ " for admissibility") + + +enableSig :: Kind -> Fun -> TypeCheck () +enableSig ki (Fun (TypeSig n _) n' ar' cl') = do + (FunSig co vt ki0 ar cl _ ftyp) <- lookupSymb n + addSig n (FunSig co vt (intersectKind ki ki0) ar cl' True ftyp) + -- add a let binding for external use + v <- up False (vFun n) vt + addSig n' (LetSig vt ki v ftyp) + + +-- typeCheckFunSig (TypeSig thisName thisType, clauses) +typeCheckFunSig :: Fun -> TypeCheck (Kinded ETypeSig) +typeCheckFunSig (Fun (TypeSig n t) n' ar cls) = enter ("type of " ++ show n) $ do + echoTySig n t + Kinded ki0 te <- checkType t + -- let te = eraseMeasure te0 + let ki = predKind ki0 + echoKindedTySig ki n (eraseMeasure te) +-- echoTySigE n te + return $ Kinded ki $ TypeSig n te + +typeCheckFunClauses :: Fun -> TypeCheck (Kinded [EClause]) +typeCheckFunClauses (Fun (TypeSig n t) n' ar cl) = enter (show n) $ + do result@(Kinded _ cle) <- checkFun t cl + -- traceCheck (show (TypeSig n t)) $ + -- traceCheck (show cl') $ + -- echo $ PP.render $ prettyFun n cle + return result + +-- checkConType sz t = Kinded ki te +-- the returned kind is the kind of the constructor arguments +-- check that result is a universe +-- ( params were already checked by checkDataType and are not included in t ) +-- called initially in the context consisting of the parameter telescope +checkConType :: Sized -> Expr -> TypeCheck (Kinded Extr) +checkConType NotSized t = checkConType' t +checkConType Sized t = + case t of + Quant Pi tb@(TBind _ (Domain t1 _ _)) t2 | isSize t1 -> do + addBind (mapDec (const paramDec) tb) $ do -- size is parametric in constructor type + Kinded ki t2e <- checkConType' t2 + return $ Kinded ki $ Quant Pi (mapDec (const irrelevantDec) tb) t2e -- size is irrelevant in constructor + _ -> throwErrorMsg $ "checkConType: expecting size quantification, found " ++ show t + +checkConType' :: Expr -> TypeCheck (Kinded Extr) +checkConType' t = do + (s, kte) <- checkingCon True $ inferType t + case s of + Set{} -> return kte + CoSet{} -> return kte + _ -> throwErrorMsg $ "checkConType: type " ++ show t ++ " of constructor not a universe" + +-- check that the data type and the parameter arguments (written down like declared in telescope) +-- precondition: target tg type checks in current context +checkTarget :: Name -> TVal -> Telescope -> Type -> TypeCheck () +checkTarget d dv tel tg = do + tv <- whnf' tg + case tv of + VApp (VDef (DefId DatK (QName n))) vs | n == d -> do + telvs <- mapM (\ tb -> whnf' (Var (boundName tb))) $ telescope tel + enter ("checking datatype parameters in constructor target") $ + leqVals' N mixed (One dv) (take (size tel) vs) telvs + return () + _ -> throwErrorMsg $ "constructor should produce something in data type " ++ show d + +{- RETIRED (syntactic check) +checkTarget :: Name -> Telescope -> Type -> TypeCheck () +checkTarget d tel tg = + case spineView tg of + (Def (DefId Dat n), args) | n == d -> checkParams tel (take (length tel) args) + _ -> throwErrorMsg $ "target mismatch" ++ show tg + + where checkParams :: Telescope -> [Expr] -> TypeCheck () + checkParams [] [] = return () + checkParams (tb : tl) ((Var n') : el) | boundName tb == n' + = checkParams tl el + checkParams tl al = throwErrorMsg $ "target param mismatch " ++ + d ++ " " ++ show tel ++ " != " ++ show tg ++ "\ncheckParams " ++ show tl ++ " " ++ show al ++ " failed" +-} + +-- check that params are types +-- check that arguments are stypes +-- check that target is set +checkDataType :: Int -> Expr -> TypeCheck (Kinded (Sort Expr, Extr)) +checkDataType p e = do + traceCheckM ("checkDataType " ++ show e ++ " p=" ++ show p) + case e of + Quant Pi tb@(TBind x (Domain t1 _ dec)) t2 -> do + k <- getLen + traceCheckM ("length of context = " ++ show k) + -- t1e <- checkingDom $ if k <= p then checkType t1 else checkSmallType t1 + (s1, Kinded ki0 t1e) <- checkingDom $ inferType t1 + let ki1 = predKind ki0 + addBind (TBind x (Domain t1 ki1 defaultDec)) $ do + Kinded ki2 (s, t2e) <- checkDataType p t2 + -- when k <= p $ ltSort s1 s -- check size of indices (disabled) + return $ Kinded ki2 (s, Quant Pi (TBind x (Domain t1e ki1 dec)) t2e) + Sort s@(Set e1) -> do + (_, e1e) <- checkLevel e1 + return $ Kinded (kUniv e1e) (s, Sort $ Set e1e) + Sort s@(CoSet e1) -> do + e1e <- checkSize e1 + return $ Kinded (kUniv Zero) (s, Sort $ CoSet e1e) + _ -> throwErrorMsg "doesn't target Set or CoSet" + +{- +checkSize :: Expr -> TypeCheck Extr +checkSize Infty = return Infty +checkSize e = valueOf <$> checkExpr e vSize +-} + +checkSize :: Expr -> TypeCheck Extr +checkSize e = + case e of + Meta i -> do + ren <- asks renaming + addMeta ren i + return e + e -> inferSize e + +inferSize :: Expr -> TypeCheck Extr +inferSize e = + case e of + Zero -> return e + Infty -> return e + Succ e -> Succ <$> checkSize e + Plus es -> Plus <$> mapM checkSize es + Max es -> maxE <$> mapM checkSize es + e -> do + (v, Kinded ki e) <- inferExpr e + subtype v vSize + return e + +checkBelow :: Expr -> LtLe -> Val -> TypeCheck Extr +checkBelow e Le VInfty = checkSize e +checkBelow e ltle v = do + e' <- checkSize e + v' <- whnf' e + leSize ltle Pos v' v + return e' + + +-- checkLevel e = (value of e, ee) +-- if e : Size and value of e != Infty +checkLevel :: Expr -> TypeCheck (Val, Extr) +checkLevel e = do + Kinded _ ee <- checkExpr e vSize + v <- whnf' e + when (v == VInfty) $ recoverFail $ "# is not a valid universe level" + return (v, ee) + +{- Kind inference + + i : Size : Type + t : Nat : Set : Set1 : ... : Type = Set\omega + p : P : Prop : Set : ... + +Functional, cumulative PTS (s,s',s') written (s,s') + + (Size,s) s != Size size-dependency + (s,Prop) impredicative Prop + (Set_i,Set_j) i <= j predicativity + +Kind can be used to construct Kinds +term t terms, types, universes, proofs, propositions +type T types, universes, propositions +size i types, universes, propositions +prf p proofs +pred P types, universes, propositions + +We like to infer kinds of expressions + + Tm < Set < Set1 < Set2 < ... + +For t : A if kind(A) = Tm then t is a term, + = Set then t is a type, + = Set1 then t is a type1 (e.g, a universe) ... + +Then, if t : (x : A) -> B + and kind(A) `irrelevantFor` kind(B) [ with irrelevantFor := > ] + +we can change the type signature to + + t : [x : A] -> B + +This is because you cannot eliminate a type to produce a term. + + kind(Set) = Set + kind(Size) = Size -- this means that we treat sizes as types, they cannot + kind(s) = s -- if s is a sort + kind((x : A) -> B) = kind(B) + kind(A : Set0) = Tm + kind(A : Prop) = Prf + kind(A : Size) = <> + kind(A : Setk) = k-1 + +irrFor Tm _ = False +irrFor Ty Tm = True +irrFor Ty Prf = True +irrFor Ty _ = False +irrFor Size Tm = True +irrFor Size Prf = True + +One problem is that we cannot infer exact kinds, e.g. + + fun T : Bool -> Set 1 -- T is a type + { T true = Bool -- T true is a type + ; T false = Set 0 -- T false is a universe + } + +T is either a type or a universe. So we can only assign intervals. +This is like in Augustsson's Cayenne [not in his paper, though]. + +A datatype is always a type. A size is a type. +A constructor is always a term. + +-} + + +-- type checking + +-- checkExpr e tv = (e', ki) +-- e' is the version of e with erasure marker at irrelevant positions +-- ki is the kind of e (Tm, Ty, Set ...) +-- ki is at most the predecessor of the sort of tv +-- +-- this is *internal* extraction in the style of Barras and Bernardo +-- e.g., does not prune t : Id A a b +-- thus, we can use the pruned version for evaluation! +checkExpr :: Expr -> TVal -> TypeCheck (Kinded Extr) +checkExpr e v = do + l <- getLen + enterDoc (text ("checkExpr " ++ show l ++ " |-") <+> prettyTCM e <+> colon <+> prettyTCM v) $ do + + ce <- ask + traceCheck ("checkExpr: " ++ show (renaming ce) ++ ";" ++ show (context ce) ++ " |- " ++ show e ++ " : " ++ show v ++ " in env" ++ show (environ ce)) $ do + + (case (e, v) of + +{- In the presence of full bracket types, + we could implement the following "resurrecting version of let" + + Gamma |- s : [A] + Gamma, x:A |- t : C Gamma, x:A, y:A |- t = t[y/x] : C + ------------------------------------------------------- + Gamma |- let x:[A] = s in t : C + + -} + + (App (Lam dec x f) e, v) | inferable e -> checkLet dec x emptyTel Nothing e f v + +{- + (LLet (TBind x (Domain Nothing _ dec)) e1 e2, v) -> checkUntypedLet x dec e1 e2 v + (LLet (TBind x (Domain (Just t1) _ dec)) e1 e2, v) -> checkTypedLet x t1 dec e1 e2 v +-} + (LLet (TBind x (Domain mt _ dec)) tel e1 e2, v) -> checkLet dec x tel mt e1 e2 v + + (Case (Var x) Nothing [Clause _ [SuccP (VarP y)] (Just rhs)], v) -> do + (tv, _) <- resurrect $ inferExpr (Var x) + subtype tv vSize + vx@(VGen i) <- whnf' (Var x) + endsInSizedCo i v + let dom = Domain vSize kSize defaultDec + newWithGen y dom $ \ j vy -> do + let vp = VSucc vy + addSizeRel j 1 i $ + addRewrite (Rewrite vx vp) [v] $ \ [v'] -> do + Kinded ki2 rhse <- checkRHS emptySub rhs v' + return $ Kinded ki2 $ Case (Var x) (Just tSize) [Clause [TBind y dom] [SuccP (VarP y)] (Just rhse)] + + + (Case e mt cs, v) -> do + (tv, t, Kinded ki1 ee) <- checkOrInfer neutralDec e mt + ve <- whnf' ee + -- tv' <- sing' ee tv -- DOES NOT WORK + Kinded ki2 cle <- checkCases ve (arrow tv v) cs + return $ Kinded ki2 $ Case ee (Just t) cle +{- + (Case e Nothing cs, _) -> do + (tv, Kinded ki1 ee) <- inferExpr e + ve <- whnf' ee + -- tv' <- sing' ee tv -- DOES NOT WORK + Kinded ki2 cle <- checkCases ve (arrow tv v) cs + t <- toExpr tv + return $ Kinded ki2 $ Case ee (Just t) cle +-} + (_, VGuard beta bv) -> + addBoundHyp beta $ checkExpr e bv + + (e,v) | inferable e -> do + (v2, Kinded ki1 ee) <- inferExpr e + checkSubtype ee v2 v + return $ Kinded ki1 ee + + _ -> checkForced e v + + ) -- >> (trace ("checkExpr successful: " ++ show e ++ ":" ++ show v) $ return ()) + +-- | checkLet @let .x tel : t = e1 in e2@ +checkLet :: Dec -> Name -> Telescope -> Maybe Type -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr) +checkLet dec x tel mt1 e1 e2 v = do + (v_t1, t1e, Kinded ki1 e1e) <- checkLetDef dec tel mt1 e1 +-- (v_t1, t1e, Kinded ki1 e1e) <- checkOrInfer dec e1 mt1 + checkLetBody x t1e v_t1 ki1 dec e1e e2 v + +-- | checkLetDef @.x tel : t = e@ becomes @.x : tel -> t = \ tel -> e@ +checkLetDef :: Dec -> Telescope -> Maybe Type -> Expr -> TypeCheck (TVal, EType, Kinded Extr) +checkLetDef dec tel mt e = local (\ cxt -> cxt {consistencyCheck = True}) $ do + -- 2013-04-01 + -- since a let telescope is treated like a lambda abstraction + -- and the let-defined symbol reduces by itself, we need to + -- do the context consistency check at each introduction. + (tel, (vt, te, Kinded ki ee)) <- checkTele tel $ checkOrInfer dec e mt + te <- return $ teleToType tel te + ee <- return $ teleLam tel ee + vt <- whnf' te + return (vt, te, Kinded ki ee) + +{- +checkTypedLet :: Name -> Type -> Dec -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr) +checkTypedLet x t1 dec e1 e2 v = do + Kinded kit t1e <- checkType t1 + v_t1 <- whnf' t1 + Kinded ki0 e1e <- applyDec dec $ checkExpr e1 v_t1 + let ki1 = intersectKind ki0 (predKind kit) + checkLetBody x t1e v_t1 ki1 dec e1e e2 v +{- + v_e1 <- whnf' e1 + new x (Domain v_t1 ki1 dec) $ \ vx -> do + addRewrite (Rewrite vx v_e1) [v] $ \ [v'] -> do + Kinded ki2 e2e <- checkExpr e2 v' + return $ Kinded ki2 $ LLet (TBind x (Domain t1e ki1 dec)) e1e e2e -- if e2e==Irr then Irr else LLet n t1e e1e e2e +-} + +checkUntypedLet :: Name -> Dec -> Expr -> Expr -> TVal -> TypeCheck (Kinded Extr) +checkUntypedLet x dec e1 e2 v = do + (v_t1, Kinded ki1 e1e) <- applyDec dec $ inferExpr e1 + v_e1 <- whnf' e1 + t1e <- toExpr v_t1 + checkLetBody x t1e v_t1 ki1 dec e1e e2 v +-} + +checkLetBody :: Name -> EType -> TVal -> Kind -> Dec -> Extr -> Expr -> TVal -> TypeCheck (Kinded Extr) +checkLetBody x t1e v_t1 ki1 dec e1e e2 v = do + v_e1 <- whnf' e1e + new x (Domain v_t1 ki1 dec) $ \ vx -> do + addRewrite (Rewrite vx v_e1) [v] $ \ [v'] -> do + Kinded ki2 e2e <- checkExpr e2 v' + return $ Kinded ki2 $ LLet (TBind x (Domain (Just t1e) ki1 dec)) emptyTel e1e e2e +{- +-- Dependent let: not checkable in rho;Delta style +-- v_e1 <- whnf rho e1 +-- checkExpr (update rho n v_e1) (v_t1 : delta) e2 v +-} + +-- | @checkPair e1 e2 y dom env b@ checks @Pair e1 e2@ against +-- @VQuant Sigma y dom env b@. +checkPair :: Expr -> Expr -> Name -> Domain -> FVal -> TypeCheck (Kinded Expr) +checkPair e1 e2 y dom@(Domain av ki dec) fv = do + case av of + VBelow Lt VInfty -> do + lowerSemi <- underAbs y dom fv $ \ i _ bv -> lowerSemiCont i bv + continue $ if lowerSemi then VBelow Le VInfty else av + _ -> continue av + where + continue av = do + Kinded k1 e1 <- applyDec dec $ checkExpr e1 av + v1 <- whnf' e1 + bv <- app fv v1 + Kinded k2 e2 <- checkExpr e2 bv + return $ Kinded (unionKind k1 k2) $ Pair (maybeErase dec e1) e2 + +-- check expression after forcing the type +checkForced :: Expr -> TVal -> TypeCheck (Kinded Expr) +checkForced e v = do + ren <- asks renaming + v <- force v +-- enter ("checkForced " ++ show ren ++ " |- " ++ show e ++ " : " ++ show v) $ do + enterDoc (text ("checkForced " ++ show ren ++ " |-") <+> prettyTCM e <+> colon <+> prettyTCM v) $ do + case (e,v) of +{- + (_, VGuard (Bound (Measure [VGen i]) (Measure [VGen j])) bv) -> + addSizeRel i j $ checkForced e bv +-} + (_, VGuard beta bv) -> + addBoundHyp beta $ checkForced e bv + + (Pair e1 e2, VQuant Sigma y dom@(Domain av ki dec) fv) -> + checkPair e1 e2 y dom fv + + (Record ri rs, t@(VApp (VDef (DefId DatK d)) vl)) -> do + let fail1 = failDoc (text "expected" <+> prettyTCM t <+> text "to be a record type") +-- DataSig { numPars, isTuple } <- lookupSymb d +-- unless isTuple $ fail1 + mfs <- getFieldsAtType d vl + case mfs of + Nothing -> fail1 + Just ptv -> do + let checkField :: (Name, Expr) -> TypeCheck (Kinded [(Name,Expr)]) -> TypeCheck (Kinded [(Name,Expr)]) + checkField (p,e) cont = + case lookup p ptv of + Nothing -> failDoc (prettyTCM p <+> text "is not a field of record" <+> prettyTCM t) + Just tv -> do + tv <- piApp tv VIrr -- remove record argument (cannot be dependent!) + Kinded k e <- checkExpr e tv + Kinded k' es <- cont + return $ Kinded (unionKind k k') ((p,e) : es) + Kinded k rs <- foldr checkField (return $ Kinded NoKind []) rs + return $ Kinded k $ Record ri rs + + +{- OLD: +Following Awodey/Bauer 2001, the following rule is valid + + Gamma, x:A |- t : B Gamma, x:A, y:A |- t = t[y/x] : B + -------------------------------------------------------- + Gamma |- \xt : Pi x:[A]. B + + (Lam _ y e1, VPi dec x va env t1) -> do + rho <- getEnv -- get the environment corresponding to Gamma + new y (Domain va (resurrectDec dec)) $ \ vy -> do + v_t1 <- whnf (update env x vy) t1 + -- traceCheckM $ "checking " ++ show e1 ++ " : " ++ show v_t1 + e1e <- checkExpr e1 v_t1 + when (erased dec) $ do -- now check invariance of the e1 + new y (Domain va (resurrectDec dec)) $ \ vy' -> do + ve <- whnf (update rho y vy) e1e + ve' <- whnf (update rho y vy') e1e + eqVal v_t1 ve ve' -- BUT: ve' does not have type v_t1 !? + -- prune the lambda if body has been pruned + return $ if e1e==Irr then Irr else Lam y e1e + -} + +-- NOW just my rule (LICS 2010 draft) a la Barras/Bernardo + + (Lam _ y e1, VQuant Pi x dom fv) -> do + -- rho <- getEnv -- get the environment corresponding to Gamma + underAbs y dom fv $ \ _ vy bv -> do + -- traceCheckM $ "checking " ++ show e1 ++ " : " ++ show v_t1 + Kinded ki1 e1e <- checkExpr e1 bv + -- the kind of a lambda is the kind of its body + return $ Kinded ki1 $ Lam (decor dom) y e1e + + -- lone projection: eta-expand! + (Proj Pre p, VQuant Pi x dom fv) -> do + let y = nonEmptyName x "y" + checkForced (Lam (decor dom) y $ App e (Var y)) v +{- + -- should be subsumed by checkBelow: + (e, v) | isVSize v -> Kinded kSize <$> checkSize e +-} +{- MOVED to checkSize + + -- metavariables must have type size + (Meta i, _) | isVSize v -> do + addMeta ren i + return $ Kinded kSize $ Meta i + + (Infty, v) | isVSize v -> return $ Kinded kSize $ Infty + (Zero, v) | isVSize v -> return $ Kinded kSize $ Zero + + (Plus es, v) | isVSize v -> do + ese <- mapM checkSize es + return $ Kinded kSize $ Plus ese + + (Max es, v) | isVSize v -> do + ese <- mapM checkSize es + return $ Kinded kSize $ Max ese + + (Succ e2, v) | isVSize v -> do + e2e <- checkSize e2 + return $ Kinded kSize $ Succ e2e +-} + + (e, VBelow ltle v) -> Kinded kSize <$> checkBelow e ltle v +{- + -- prune sizes + return $ if e2e==Irr then Irr else Succ e2e +-} + (e,v) -> do + case spineView e of + + -- unfold defined patterns + (h@(Def (DefId (ConK DefPat) c)), es) -> do + PatSig xs pat _ <- lookupSymbQ c + let (xs1, xs2) = splitAt (length es) xs + phi x = maybe (Var x) id $ lookup x (zip xs1 es) + body = parSubst phi (patternToExpr pat) + e = foldr (Lam defaultDec) body xs2 + checkForced e v + + -- check constructor term + (h@(Def (DefId (ConK co) c)), es) -> checkConTerm co c es v +{- + (h@(Def (DefId (ConK co) c)), es) -> do + tv <- conType c v + (knes, dv) <- checkSpine es tv + let e = foldl App h $ map (snd . valueOf) knes + checkSubtype e dv v + e <- etaExpandPis e dv -- a bit similiar to checkSubtype, which computes a singleton + return $ Kinded kTerm $ e +-} + -- else infer + _ -> do + (v2,kee) <- inferExpr e + checkSubtype (valueOf kee) v2 v + return kee + +-- | Check (partially applied) constructor term, eta-expand it and turn it +-- into a named record. +checkConTerm :: ConK -> QName -> [Expr] -> TVal -> TypeCheck (Kinded Extr) +checkConTerm co c es v = do + case v of + VQuant Pi x dom fv -> do + let y = freshen $ nonEmptyName x "y" + underAbs y dom fv $ \ _ _ bv -> do + Kinded ki ee <- checkConTerm co c (es ++ [Var y]) bv + return $ Kinded ki $ Lam (decor dom) y ee + _ -> do + c <- disambigCon c v + tv <- conType c v + (knes, dv) <- checkSpine es tv + let ee = Record (NamedRec co c False notDotted) $ map valueOf knes + checkSubtype ee dv v + return $ Kinded kTerm ee + +{- +-- | Check (partially applied) constructor term, eta-expand it and turn it +-- into a named record. +checkConTerm :: ConK -> Name -> [Expr] -> TVal -> TypeCheck (Kinded Extr) +checkConTerm co c es v = do + tv <- conType c v + (knes, dv) <- checkSpine es tv + let e0 = foldl App (Def (DefId (ConK co) c)) $ map (snd . valueOf) knes + checkSubtype e0 dv v + (vTel, _) <- telView dv + let xs = map (boundName . snd) vTel + decs = map (decor . boundDom . snd) vTel + ys = map freshen xs + rs = map valueOf knes ++ (zip xs $ map Var ys) + e1 = Record (NamedRec co c False) rs + e = foldr (uncurry Lam) e1 (zip decs ys) + return $ Kinded kTerm e +-} + +{- +-- | Only eta-expand at function types, do not force. +etaExpandPis :: Expr -> TVal -> TypeCheck Expr +etaExpandPis e tv = do + case tv of + VQuant Pi x dom env b -> new x dom $ \ xv -> do + let y = freshen x + Lam (decor dom) y <$> do + etaExpandPis (App e (Var y)) =<< whnf (update env x xv) b + _ -> return e +-} + +checkSpine :: [Expr] -> TVal -> TypeCheck ([Kinded (Name, Extr)], TVal) +checkSpine [] tv = return ([], tv) +checkSpine (e : es) tv = do + (kne, tv) <- checkApp e tv + (knes, tv) <- checkSpine es tv + return (kne : knes, tv) + +maybeErase dec = if erased dec then erasedExpr else id + +-- | checking e against (x : A) -> B returns (x,e) and B[e/x] +checkApp :: Expr -> TVal -> TypeCheck (Kinded (Name, Extr), TVal) +checkApp e2 v = do + v <- force v -- if v is a corecursively defined type in Set, unfold! + enter ("checkApp " ++ show v ++ " eliminated by " ++ show e2) $ do + case v of + VQuant Pi x dom@(Domain av@(VBelow Lt VInfty) _ dec) fv -> do + upperSemi <- underAbs x dom fv $ \ i _ bv -> upperSemiCont i bv + continue $ if upperSemi then VQuant Pi x dom{ typ = VBelow Le VInfty} fv + else v + _ -> continue v + where + continue v = case v of + VQuant Pi x (Domain av _ dec) fv -> do + (ki, v2, e2e) <- do + if inferable e2 then do + -- if e2 has a singleton type, we should not take v2 = whnf e2 + -- but use the single value of e2 + -- this is against the spirit of bidir. checking + -- if checking a type we need to resurrect + (av', Kinded ki e2e) <- applyDec dec $ inferExpr e2 + case av' of + VSing v2 av'' -> do subtype av' av + return (ki, v2, e2e) + _ -> do checkSubtype e2e av' av + v2 <- whnf' e2e + return (ki, v2, e2e) + else do + Kinded ki e2e <- applyDec dec $ checkExpr e2 av + v2 <- whnf' e2e + return (ki, v2, e2e) + bv <- app fv v2 + -- the kind of the application is the kind of its head + return (Kinded ki $ (x,) $ maybeErase dec e2e, bv) + -- if e1e==Irr then Irr else if e2e==Irr then e1e else App e1e [e2e]) + _ -> throwErrorMsg $ "checking application to " ++ show e2 ++ ": expected function type, found " ++ show v + + +-- checkSubtype expr : infered_type <= ascribed_type +checkSubtype :: Expr -> TVal -> TVal -> TypeCheck () +checkSubtype e v2 v = do + rho <- getEnv + traceSingM $ "computing singleton <" ++ show e ++ " : " ++ show v2 ++ ">" -- ++ " in environment " ++ show rho + v2principal <- sing rho e v2 + traceSingM $ "subtype checking " ++ show v2principal ++ " ?<= " ++ show v ++ " in environment " ++ show rho + subtype v2principal v + + +-- ptsRule s1 s2 = s if (s1,s2,s) is a valid rule +-- precondition: s1,s2 are proper sorts, i.e., not Size or Tm +ptsRule :: Bool -> Sort Val -> Sort Val -> TypeCheck (Sort Val) +ptsRule er s1 s2 = do + cxt <- ask + let parametric = checkingConType cxt -- are we dealing with a parametric pi? + let err = "ptsRule " ++ show (s1,s2) ++ " " ++ (if parametric then "(in type of constructor)" else "") ++ ": " + case (s1,s2) of + (Set VInfty,_) -> throwErrorMsg $ err ++ "domain too big" + (Set v1, Set v2) -> + if parametric then do + unless er $ leqSize Pos v1 v2 -- when we are checking a constructor, to reject + {- data Bad : Set { bad : Set -> Bad } -} + return s2 + else return $ Set $ maxSize [v1,v2] + (CoSet v1, Set VZero) + | parametric -> return $ CoSet v1 + | v1 == VInfty -> return $ Set VZero + | otherwise -> throwErrorMsg $ err ++ "domain cannot be sized" + (CoSet v1, CoSet v2) + | parametric -> do + let v2' = maybe v2 id $ predSize v2 + case minSize v1 v2 of + Just v -> return $ CoSet v + Nothing -> throwErrorMsg $ err ++ "min" ++ show (v1,v2) ++ " does not exist" + | v1 == VInfty -> return $ CoSet $ succSize v2 + | otherwise -> throwErrorMsg $ err ++ "domain cannot be sized" + _ -> return s2 + +checkOrInfer :: Dec -> Expr -> Maybe Type -> TypeCheck (TVal, EType, Kinded Extr) +checkOrInfer dec e Nothing = do + (tv, ke) <- applyDec dec $ inferExpr e + te <- toExpr tv + return (tv, te, ke) +checkOrInfer dec e (Just t) = do + Kinded kt te <- checkType t + tv <- whnf' te + Kinded ke ee <- applyDec dec $ checkExpr e tv + let ki = intersectKind ke $ predKind kt + return $ (tv, te, Kinded ki ee) + +-- inferType t = (s, te) +inferType :: Expr -> TypeCheck (Sort Val, Kinded Extr) +inferType t = do + (sv, te) <- inferExpr t + case sv of + VSort s | not (s `elem` map SortC [Tm,Size]) -> return (s,te) + _ -> throwErrorMsg $ "inferExpr: expected " ++ show t ++ " to be a type!" + +-- inferExpr e = (tv, s, ee) +-- input : expr e | inferable e +-- output: type tv, kind s, and erased form ee of e +-- the kind tells whether e is a term, a size, a set, ... +inferExpr :: Expr -> TypeCheck (TVal, Kinded Extr) +inferExpr e = do + (tv, ee) <- inferExpr' e + case tv of + VGuard beta vb -> do + checkGuard beta + return (vb, ee) + _ -> return (tv, ee) + +inferProj :: Expr -> PrePost -> Name -> TypeCheck (TVal, Kinded Extr) +inferProj e1 fx p = checkingCon False $ do + (v, Kinded ki1 e1e) <- inferExpr e1 +{- + let fail1 = failDoc (text "expected" <+> prettyTCM e1 <+> text "to be of record type when taking the projection" <+> text p <> comma <+> text "but found type" <+> prettyTCM v) + let fail2 = failDoc (text "record" <+> prettyTCM e1 <+> text "of type" <+> prettyTCM v <+> text "does not have field" <+> text p) +-} + v <- force v -- if v is a corecursively defined type in Set, unfold! + tv <- projectType v p =<< whnf' e1e + return (tv, Kinded ki1 (proj e1e fx p)) +{- + case v of + VApp (VDef (DefId Dat d)) vl -> do + mfs <- getFieldsAtType d vl + case mfs of + Nothing -> fail1 + Just ptvs -> + case lookup p ptvs of + Nothing -> fail2 + Just tv -> do + tv <- piApp tv VIrr -- cut of record arg + return (tv, Kinded ki1 (App e1e (Proj p))) + _ -> fail1 +-} + + +-- inferExpr' might return a VGuard, this is removed in inferExpr +-- the returned kind for constructor type is computed as the union +-- of the kinds of the non-erased arguments +-- otherwise it is the kind of the target +inferExpr' :: Expr -> TypeCheck (TVal, Kinded Extr) +inferExpr' e = enter ("inferExpr' " ++ show e) $ + let returnSing (Kinded ki ee) tv = do + tv' <- sing' ee tv + return (tv', Kinded ki ee) + in + (case e of + + Var x -> do + traceCheckM ("infer variable " ++ show x) + item <- lookupName1 x + traceCheckM ("infer variable: retrieved item ") + let dom = domain item + av = typ dom + traceCheckM ("infer variable: " ++ show av) + enterDoc (text "inferExpr: variable" <+> prettyTCM x <+> colon <+> prettyTCM av <+> text "may not occur") $ do + let dec = decor dom + udec = upperDec item + pol = polarity dec + upol = polarity udec + when (erased dec && not (erased udec)) $ + recoverFail ", because it is marked as erased" + enter ", because of polarity" $ + leqPolM pol upol + traceCheckM ("infer variable returns") + traceCheckM ("infer variable " ++ show x ++ " : " ++ show av) + return $ (av, Kinded (kind dom) $ Var x) +{- + let err = "inferExpr: variable " ++ x ++ " : " ++ show (typ item) ++ + " may not occur" + let dec = decor item + let pol = polarity dec + if erased dec then + throwErrorMsg $ err ++ ", because it is marked as erased" + else if not (leqPol pol SPos) then + throwErrorMsg $ err ++ ", because it has polarity " ++ show pol + else do + -- traceCheckM ("infer variable " ++ x ++ " : " ++ show (typ item)) + return $ (typ item, Var x) -- TODO: (typ item, kind item, Var x) +-} + + -- for constants, the kind coincides with the type! + Sort (CoSet e) -> do + ee <- checkSize e + return (VSort (Set (VSucc VZero)), Kinded (kUniv Zero) $ Sort $ CoSet ee) + Sort (Set e) -> do + (v, ee) <- checkLevel e + return (VSort (Set (succSize v)), Kinded (kUniv ee) $ Sort $ Set ee) + Sort (SortC Size) -> return (vTSize, Kinded kTSize $ e) + Zero -> return (vSize, Kinded kSize Zero) + Infty -> return (vSize, Kinded kSize Infty) + Below ltle e -> do + ee <- checkSize e + return (vTSize, Kinded kTSize $ Below ltle ee) + + Quant pisig (TBind n (Domain t1 _ dec)) t2 -> do + -- make sure that in a constructor declaration the constructor args are + -- mixed-variant (there is no subtyping between constrs anyway) + checkCon <- asks checkingConType +{- TODO + when (checkCon && polarity dec /= Mixed) $ + throwErrorMsg $ "constructor arguments must be declared mixed-variant" +-} + (s1, Kinded ki0 t1e) <- (if pisig==Pi then checkingDom else id) $ + checkingCon False $ inferType t1 -- switch off parametric Pi + -- the kind of the bound variable is the precedessor of the kind of its type + let ki1 = predKind ki0 + addBind (TBind n (Domain t1e ki1 $ defaultDec)) $ do -- ignore erasure flag AND polarity in Pi! (except for irrelevant, only becomes parametric) + -- TODO: + -- addBind (TBind n (Domain t1e ki1 $ coDomainDec dec)) $ do -- ignore erasure flag AND polarity in Pi! (except for irrelevant, only becomes parametric) + (s2, Kinded ki2 t2e) <- inferType t2 + ce <- ask + let er = erased dec + s <- if impredicative ce && er && s2 == Set VZero then return s2 else ptsRule er s1 s2 -- Impredicativity! + -- improve erasure annotation: irrelevant arguments can be erased! + let (ki',dec') = if checkCon then + -- in case of constructor types the kind is the union + -- of the kinds of the constructor arguments + if ki0 == kTSize then (ki2, irrelevantDec) + else if erased dec then (ki2, dec) -- do not count erased args in + else (unionKind ki0 ki2, dec) + else (ki2, if argKind ki0 `irrelevantFor` (predKind ki2) + then irrelevantDec + else dec) + -- the kind of the Pi-type is the kind of its target (codomain) + return (VSort s, Kinded ki' $ Quant pisig (TBind n (Domain t1e ki1 dec')) t2e) + + Quant Pi (TMeasure (Measure mu)) t2 -> do + mue <- mapM checkSize mu + (s, Kinded ki2 t2e) <- inferType t2 + return (VSort s, Kinded ki2 $ Quant Pi (TMeasure (Measure mue)) t2e) + + Quant Pi (TBound (Bound ltle (Measure mu) (Measure mu'))) t2 -> do + (mue,mue') <- checkingDom $ do + mue <- checkingDom $ mapM checkSize mu + mue' <- mapM checkSize mu' + return (mue,mue') + (s, Kinded ki2 t2e) <- inferType t2 + return (VSort s, Kinded ki2 $ Quant Pi (TBound (Bound ltle (Measure mue) (Measure mue'))) t2e) + + Sing e1 t -> do + (s, Kinded ki te) <- inferType t + tv <- whnf' te + Kinded ki1 e1e <- checkExpr e1 tv + return (VSort $ s, Kinded (intersectKind ki $ succKind ki1) -- not sure how useful the intersection is, maybe just ki is good enough + $ Sing e1e te) + +{- Not safe to infer pairs because of irrelevance! + Pair e1 e2 -> do + (tv1, Kinded k1 e1) <- inferExpr e1 + (tv2, Kinded k2 e2) <- inferExpr e2 + let ki = unionKind k1 k2 + tv = prod tv1 tv2 + return (tv, Kinded ki $ Pair e1 e2) +-} + + App (Proj Pre p) e -> inferProj e Pre p + App e (Proj Post p) -> inferProj e Post p + + App e1 e2 -> checkingCon False $ do + (v, Kinded ki1 e1e) <- inferExpr e1 + (Kinded ki2 (_, e2e), bv) <- checkApp e2 v + -- the kind of the application is the kind of its head + return (bv, Kinded ki1 $ App e1e e2e) +{- + v <- force v -- if v is a corecursively defined type in Set, unfold! + case v of + VQuant Pi x (Domain av _ dec) env b -> do + (v2,e2e) <- + if inferable e2 then do + -- if e2 has a singleton type, we should not take v2 = whnf e2 + -- but use the single value of e2 + -- this is against the spirit of bidir. checking + -- if checking a type we need to resurrect + (av', Kinded _ e2e) <- applyDec dec $ inferExpr e2 + case av' of + VSing v2 av'' -> do subtype av' av + return (v2,e2e) + _ -> do checkSubtype e2e av' av + v2 <- whnf' e2e + return (v2, e2e) + else do + Kinded _ e2e <- applyDec dec $ checkExpr e2 av + v2 <- whnf' e2 + return (v2, e2e) + bv <- whnf (update env x v2) b + -- the kind of the application is the kind of its head + return (bv, Kinded ki1 $ App e1e (if erased dec then erasedExpr e2e else e2e)) +-- if e1e==Irr then Irr else if e2e==Irr then e1e else App e1e [e2e]) + _ -> throwErrorMsg $ "inferExpr : expected Pi with expression : " ++ show e1 ++ "," ++ show v +-} + +-- App e1 (e2:el) -> inferExpr $ (e1 `App` [e2]) `App` el + -- 2012-01-22 no longer infer constructors + (Def id@(DefId {idKind, idName = name})) | not (conKind idKind) -> do -- traceCheckM ("infer defined head " ++ show n) + mitem <- errorToMaybe $ lookupName1 $ unqual name + case mitem of -- first check if it is also a var name + Just item -> do -- we are inside a mutual declaration (not erased!) + let pol = (polarity $ decor $ domain item) + let upol = (polarity $ upperDec item) + mId <- asks checkingMutualName + case mId of + Just srcId -> + -- we are checking constructors or function bodies + addPosEdge srcId id upol + Nothing -> + -- we are checking signatures + enter ("recursive occurrence of " ++ show name ++ " not strictly positive") $ + leqPolM pol upol + return (typ $ domain item, Kinded (kind $ domain item) $ e) + Nothing -> -- otherwise, it is not the data type name just being defined + do sige <- lookupSymbQ name + case sige of + -- data types have always kind Set 0! + (DataSig { symbTyp = tv }) -> return (tv, Kinded (symbolKind sige) e) + (FunSig { symbTyp = tv }) -> return (tv, Kinded (symbolKind sige) e) + -- constructors are always terms + (ConSig { symbTyp = tv }) -> returnSing (Kinded kTerm e) tv -- constructors have sing.type! + (LetSig { symbTyp = tv }) -> return (tv, Kinded (symbolKind sige) e) -- return $ vSing v tv +{- + (Con _ n) -> do sig <- gets signature + case (lookupSig n sig) of + (Let n) -> do sig <- gets signature + case (lookupSig n sig) of +-} + _ -> throwErrorMsg $ "cannot infer type of " ++ show e + ) >>= \ tv -> ask >>= \ ce -> + traceCheck ("inferExpr: " ++ show (renaming ce) ++ ";" ++ show (context ce) ++ " |- " ++ show e ++ " :=> " ++ show tv ++ " in env" ++ show (environ ce)) $ +-- traceCheck ("inferExpr: " ++ show e ++ " :=> " ++ show tv) $ + return tv + + +{- BAD IDEA! +improveDec :: Dec -> TVal -> Dec +improveDec dec v = if v == VSet || v == VSize then erased else dec +-} + +{- +-- entry point 3: resurrects +checkType :: Expr -> TypeCheck Extr +checkType e = (resurrect $ checkType' e) `throwTrace` ("not a type: " ++ show e ) + +checkType' :: Expr -> TypeCheck Extr +checkType' e = case e of + Sort s -> return e + Pi dec x t1 t2 -> do + t1e <- checkType' t1 + -- ignore erasure flag in types! +-- t1v <- whnf' t1e +-- new' x (Domain (Dec False) t1v) $ do + addBind x (Dec False) t1e $ do + t2e <- checkType' t2 + return $ Pi dec x t1e t2e -- Pi (improveDec dec t1v) x t1e t2e + _ -> checkExpr' e $ VSort Set +-} + +checkType :: Expr -> TypeCheck (Kinded Extr) +checkType t = + enter ("not a type: " ++ show t) $ + resurrect $ do + (s, te) <- inferType t + leqSort Pos s (Set VInfty) + return te + +checkSmallType :: Expr -> TypeCheck (Kinded Extr) +checkSmallType t = + enter ("not a set: " ++ show t) $ + resurrect $ do + (s, te) <- inferType t + case s of + Set VZero -> return te + CoSet{} -> return te + _ -> throwErrorMsg $ "expected " ++ show s ++ " to be Set or CoSet _" + +{- +-- small type +checkSmallType :: Expr -> TypeCheck Extr +checkSmallType e = (resurrect $ checkExpr' e $ VSort Set) `throwTrace` ("not a set: " ++ show e ) +-} + +-- check telescope and add bindings to contexts +checkTele :: Telescope -> TypeCheck a -> TypeCheck (ETelescope, a) +checkTele (Telescope tel) k = loop tel where + loop tel = case tel of + [] -> (emptyTel,) <$> k + tb@(TBind x (Domain t _ dec)) : tel -> do + Kinded ki te <- checkType t + let tb = TBind x (Domain te (predKind ki) dec) + (tel, a) <- addBind tb $ loop tel + return (Telescope $ tb : telescope tel, a) + +-- the integer argument is the number of the clause, used just for user feedback +checkCases :: Val -> TVal -> [Clause] -> TypeCheck (Kinded [EClause]) +checkCases = checkCases' 1 + +checkCases' :: Int -> Val -> TVal -> [Clause] -> TypeCheck (Kinded [EClause]) +checkCases' i v tv [] = return $ Kinded NoKind [] +checkCases' i v tv (c : cl) = do + Kinded k1 ce <- checkCase i v tv c + Kinded k2 cle <- checkCases' (i + 1) v tv cl + return $ Kinded (unionKind k1 k2) $ ce : cle + +checkCase :: Int -> Val -> TVal -> Clause -> TypeCheck (Kinded EClause) +checkCase i v tv cl@(Clause _ [p] mrhs) = enter ("case " ++ show i) $ + -- traceCheck ("checking case " ++ show i) $ + do + -- clearDots -- NOT NEEDED + (flex,ins,cxt,vt,pe,pv,absp) <- checkPattern neutral [] emptySub tv p + local (\ _ -> cxt) $ do + mapM (checkGoal ins) flex + tel <- getContextTele -- TODO! + case (absp,mrhs) of + (True,Nothing) -> return $ Kinded NoKind (Clause tel [pe] Nothing) + (False,Nothing) -> throwErrorMsg ("missing right hand side in case " ++ showCase cl) + (True,Just rhs) -> throwErrorMsg ("absurd pattern requires no right hand side in case " ++ showCase cl) + (False,Just rhs) -> do + -- pv <- whnf' (patternToExpr p) -- DIFFICULT FOR DOT PATTERNS! + -- vp <- patternToVal p -- BUG: INTRODUCES FRESH GENS, BUT THEY HAVE ALREADY BEEN INTRODUCED IN checkPattern + addRewrite (Rewrite v pv) [vt] $ \ [vt'] -> do + Kinded ki rhse <- checkRHS ins rhs vt' + return $ Kinded ki (Clause tel [pe] (Just rhse)) + -- [rhs'] <- solveAndModify [rhs] (environ cxt) + -- return (Clause [p] rhs') + +-- type check a function + +checkFun :: Type -> [Clause] -> TypeCheck (Kinded [EClause]) +checkFun t cl = do + tv <- whnf' t + checkClauses tv cl + +-- the integer argument is the number of the clause, used just for user feedback +checkClauses :: TVal -> [Clause] -> TypeCheck (Kinded [EClause]) +checkClauses = checkClauses' 1 + +checkClauses' :: Int -> TVal -> [Clause] -> TypeCheck (Kinded [EClause]) +checkClauses' i tv [] = return $ Kinded NoKind ([]) +checkClauses' i tv (c:cl) = do + Kinded ki1 ce <- checkClause i tv c + Kinded ki2 cle <- checkClauses' (i + 1) tv cl + return $ Kinded (unionKind ki1 ki2) $ (ce : cle) + +-- checkClause i tv cl = (cl', cle) +-- checking one equation cl of a function at type tv +-- solve size constraints +-- substitute solution into clause, resulting in cl' +-- return also extracted clause cle +checkClause :: Int -> TVal -> Clause -> TypeCheck (Kinded EClause) +checkClause i tv cl@(Clause _ pl mrhs) = enter ("clause " ++ show i) $ do + -- traceCheck ("checking function clause " ++ show i) $ + -- clearDots -- NOT NEEDED + (flex,ins,cxt,tv0,ple,plv,absp) <- checkPatterns neutral [] emptySub tv pl + -- 2013-03-30 When checking the rhs, we only allow new size hypotheses + -- if they do not break any valuation of the existing hypotheses. + -- See ICFP 2013 paper. + -- We exclude cofuns here, for experimentation. + -- Note that cofuns need not be SN, so the strict consistency may be + -- not necessary. + local (\ _ -> cxt { consistencyCheck = (mutualCo cxt == Ind) }) $ do + mapM (checkGoal ins) flex +{- + dots <- openDots + unless (null dots) $ + recoverFailDoc $ text "the following dotted constructors could not be confirmed: " <+> prettyTCM dots +-} + -- TODO: insert meta var solution in dot patterns + tel <- getContextTele -- WRONG TELE, has VGens for DotPs + case (absp,mrhs) of + (True,Nothing) -> return $ Kinded NoKind (Clause tel ple Nothing) + (False,Nothing) -> throwErrorMsg ("missing right hand side in clause " ++ show cl) + (True,Just rhs) -> throwErrorMsg ("absurd pattern requires no right hand side in clause " ++ show cl) + (False,Just rhs) -> do + Kinded ki rhse <- checkRHS ins rhs tv0 + env <- getEnv + [rhse] <- solveAndModify [rhse] env + return $ Kinded ki (Clause tel ple (Just rhse)) + + +-- * Pattern checking ------------------------------------------------ + +type Substitution = Valuation -- [(Int,Val)] + +emptySub = emptyVal +sgSub = sgVal +lookupSub i = lookup i . valuation + +type DotFlex = (Int,(Expr,Domain)) + +-- left over goals +data Goal + = DotFlex Int (Maybe Expr) Domain + -- ^ @Just@ : Flexible variable from inaccessible pattern. + -- ^ @Nothing@ : Flexible variable from hidden function type. + | MaxMatches Int TVal + | DottedCons Dotted Pattern TVal + deriving Show + +-- checkPatterns is initially called with an empty local context +-- in the type checking monad +checkPatterns :: Dec -> [Goal] -> Substitution -> TVal -> [Pattern] -> TypeCheck ([Goal],Substitution,TCContext,TVal,[EPattern],[Val],Bool) +checkPatterns dec0 flex ins v pl = + case v of + VMeasured mu vb -> setMeasure mu $ checkPatterns dec0 flex ins vb pl + VGuard beta vb -> addBoundHyp beta $ checkPatterns dec0 flex ins vb pl +{- + VGuard beta vb -> throwErrorMsg $ "checkPattern at type " ++ show v ++ " --- introduction of constraints not supported" +-} + _ -> case pl of + [] -> do cxt <- ask + return (flex,ins,cxt,v,[],[],False) + (p:pl') -> do (flex',ins',cxt',v',pe,pv,absp) <- checkPattern dec0 flex ins v p + local (\ _ -> cxt') $ do + (flex'',ins'',cxt'',v'',ple,plv,absps) <- checkPatterns dec0 flex' ins' v' pl' + return (flex'',ins'',cxt'',v'', pe:ple, pv:plv, absp || absps) -- if pe==IrrP then ple else pe:ple) + +{- +checkPattern dec0 flex subst tv p = (flex', subst', cxt', tv', pe, pv, absp) + +Input : + dec0 : context in which pattern occurs (irrelevant, parametric, recursive) + are we checking an erased argument? (constr. pat. needs to be forced!) + flex : list of pairs (flexible variable, its dot pattern + supposed type) + subst : list of pairs (flexible variable, its valuation) + cxt : in monad, containing + rho : binding of variables to values + delta : binding of generic values to their types + tv : type of the expression \ p -> t + p : the pattern to check + +Output + tv' : type of t + pe : erased pattern + pv : value of pattern (this is in essence whnf' pe, + but we cannot evaluate because of dot patterns) + absp : did we encounter an absurd pattern +-} + +checkPattern :: Dec -> [Goal] -> Substitution -> TVal -> Pattern -> TypeCheck ([Goal],Substitution,TCContext,TVal,EPattern,Val,Bool) +checkPattern dec0 flex ins tv p = -- ask >>= \ TCContext { context = delta, environ = rho } -> trace ("checkPattern" ++ ("\n dot pats: " +?+ show flex) ++ ("\n substion: " +?+ show ins) ++ ("\n environ : " +?+ show rho) ++ ("\n context : " +?+ show delta) ++ "\n pattern : " ++ show p ++ "\n at type : " ++ show tv ++ "\t<>") $ + enter ("pattern " ++ show p) $ do + tv <- force tv + case tv of + -- record type can be eliminated + VApp (VDef (DefId DatK d)) vl -> + case p of + ProjP proj -> do + tv <- projectType tv proj VIrr -- do not have record value here + cxt <- ask + return (flex, ins, cxt, tv, p, VProj Post proj, False) +{- + mfs <- getFieldsAtType d vl + case mfs of + Nothing -> failDoc (text "cannot eliminate type" <+> prettyTCM tv <+> text "with projection pattern" <+> prettyTCM p) + Just ptvs -> + case lookup proj ptvs of + Nothing -> failDoc (text "record type" <+> prettyTCM tv <+> text "does not know projection" <+> text proj) + Just tv -> do + tv <- piApp tv VIrr -- cut of record arg + cxt <- ask + return (flex, ins, cxt, tv, p, VProj proj, False) +-} + _ -> failDoc (text "cannot eliminate type" <+> prettyTCM tv <+> text "with a non-projection pattern") + + -- intersection type + VQuant Pi x dom@(Domain av ki Hidden) fv -> do + -- introduce new flexible variable + newWithGen x dom $ \ i xv -> do + tv <- fv `app` xv + checkPattern dec0 (DotFlex i Nothing dom : flex) ins tv p + + -- function type can be eliminated + VQuant Pi x (Domain av ki dec) fv -> do +{- + let erased' = er || erased dec + let decEr = if erased' then irrelevantDec else dec -- dec {erased = erased'} +-} + let decEr = dec `compose` dec0 + let domEr = (Domain av ki decEr) + case p of + + -- treat successor pattern here, because of admissibility check + SuccP p2 -> do + when (av /= vSize) $ throwErrorMsg "checkPattern: expected type Size" + when (isSuccessorPattern p2) $ cannotMatchDeep p tv + + co <- asks mutualCo + when (co /= CoInd) $ + throwErrorMsg ("successor pattern only allowed in cofun") + + enterDoc (text ("checkPattern " ++ show p ++" : matching on size, checking that target") <+> prettyTCM tv <+> text "ends in correct coinductive sized type") $ + underAbs x domEr fv $ \ i _ bv -> endsInSizedCo i bv + + cxt <- ask + -- 2012-02-05 assume size variable in SuccP to be < # + let sucTy = (vFinSize `arrow` vFinSize) + (flex',ins',cxt',tv',p2e,p2v,absp) <- checkPattern decEr flex ins sucTy p2 + -- leqVal Mixed delta' VSet VSize av -- av = VSize + let pe = SuccP p2e + let pv = VSucc p2v +-- pv0 <- local (\ _ -> cxt') $ whnf' $ patternToExpr pe + -- pv0 <- patternToVal p -- RETIRE patternToVal + -- pv <- up False pv0 av -- STUPID what can be eta-exanded at type Size?? + vb <- app fv pv +{- + endsInCoind <- endsInSizedCo pv vb + when (not endsInCoind) $ throwErrorMsg $ "checkPattern " ++ show p ++" : cannot match on size since target " ++ show tv ++ " does not end in correct coinductive sized type" +-} + return (flex',ins',cxt',vb,pe,pv,absp) + + -- other patterns: no need to know about result type + _ -> do + (flex',ins',cxt',pe,pv,absp) <- checkPattern' flex ins domEr p + -- traceM ("checkPattern' returns " ++ show (flex',ins',cxt',pe,pv,absp)) + vb <- app fv pv + vb <- substitute ins' vb -- from ConP case -- ?? why not first subst and then whnf? + -- traceCheckM ("Returning type " ++ show vb) + return (flex',ins',cxt',vb,pe,pv,absp) + + _ -> throwErrorMsg $ "checkPattern: expected function type, found " ++ show tv + +-- TODO: refactor with monad transformers +-- put absp into writer monad + +turnIntoVarPatAtUnitType :: TVal -> Pattern -> TypeCheck Pattern +turnIntoVarPatAtUnitType (VApp (VDef (DefId DatK n)) _) p@(ConP pi c []) = + flip (ifM $ isUnitData n) (return p) $ do + let x = fresh "un!t" + return $ VarP x +turnIntoVarPatAtUnitType _ p = return p + +checkPattern' :: [Goal] -> Substitution -> Domain -> Pattern -> TypeCheck ([Goal],Substitution,TCContext,EPattern,Val,Bool) +checkPattern' flex ins domEr@(Domain av ki decEr) p = do + p <- turnIntoVarPatAtUnitType av p + case p of + SuccP{} -> failDoc (text "successor pattern" <+> prettyTCM p <+> text "not allowed here") + + PairP p1 p2 -> do + av <- force av + case av of + VQuant Sigma y dom1@(Domain av1 ki1 dec1) fv -> do + (flex, ins, cxt, pe1, pv1, absp1) <- + checkPattern' flex ins (Domain av1 ki1 $ dec1 `compose` decEr) p1 + av2 <- app fv pv1 + (flex, ins, cxt, pe2, pv2, absp2) <- + local (const cxt) $ + checkPattern' flex ins (Domain av2 ki decEr) p2 + return (flex, ins, cxt, PairP pe1 pe2, VPair pv1 pv2, absp1 || absp2) + _ -> failDoc (text "pair pattern" <+> prettyTCM p <+> text "could not be checked against type" <+> prettyTCM av) +{- + (x : Sigma y:A. B) -> C + =iso= (y : A) -> (x' : B) -> C[(y,x')/x] + + (x : Sigma y:V. ) -> + =iso= (y : V) -> <(x': B) -> C; ?? x=(y,x')> + -} +{- + case av of + VQuant Sigma y dom1@(Domain av1 ki1 dec1) env1 a2 -> do + let x' = x ++ "#2" + ep = Pair (Var y) (Var x') + tv = VQuant Pi y dom1 env1 $ + Quant x' (Domain a2 +-} + + ProjP proj -> failDoc (text "cannot eliminate type" <+> prettyTCM av <+> text "with projection pattern" <+> prettyTCM p) + + VarP y -> do + new y domEr $ \ xv -> do + cxt' <- ask + p' <- case av of + VBelow Lt v -> flip SizeP y <$> toExpr v + _ -> return p + return (flex, ins, cxt', maybeErase $ p', xv, False) + +{- checking bounded size patterns + + ex : [i : Size] -> [j : Below< i] -> ... + ex i (j < i) = ... + + type of pattern : Below< i needs to cover type of parameter Below< i + + zero : [j : Size] -> Nat $j -- need to hold a "sized con type" + zero : [j < i] -> Nat i + + ex : [i : Size] -> (n : Nat i) -> ... + ex i (zero (j < i) = ... + + type of size-pat : Below< i + +-} + SizeP e y -> do -- pattern (z > y), y is the bound variable, z the bound of z + e <- resurrect $ checkSize e -- (Var z) + newWithGen y domEr $ \ j xv -> do +{- + VGen k <- whnf' (Var z) + addSizeRel j 1 k $ do -- j < k +-} + ve <- whnf' e + addBoundHyp (Bound Lt (Measure [xv]) (Measure [ve])) $ do + subtype av (VBelow Lt ve) + cxt' <- ask + return (flex, ins, cxt', maybeErase $ SizeP e y, xv, False) + + AbsurdP -> do + when (isFunType av) $ throwErrorMsg ("absurd pattern " ++ show p ++ " does not match function types, like " ++ show av) + cxt' <- ask + return (MaxMatches 0 av : flex, ins, cxt', maybeErase $ AbsurdP, VIrr, True) +{- + cenvs <- matchingConstructors av -- TODO: av might be MVar + -- need to be postponed + case cenvs of + [] -> do bv <- whnf (update env x VIrr) b + cxt' <- ask + return (flex, ins, cxt', bv, maybeErase $ AbsurdP, True) + _ -> throwErrorMsg $ "type " ++ show av ++ " of absurd pattern not empty" +-} + + -- always expand defined patterns! + p@(ConP pi n ps) | coPat pi == DefPat -> do + checkPattern' flex ins domEr =<< expandDefPat p + +-- ConP pi n pl | not $ dottedPat pi -> do + ConP pi n pl -> do + + -- disambiguate constructor first + n <- disambigCon n av + + let co = coPat pi + dotted = dottedPat pi + + -- First check that we do not match against an irrelevant argument. + unless dotted $ nonDottedConstructorChecks n co pl +{- TODO + enter ("can only match non parametric arguments") $ + leqPolM (polarity dec) (pprod defaultPol) +-} + (vc,(flex',ins',cxt',vc',ple,pvs,absp)) <- checkConstructorPattern co n pl + + when (isFunType vc') $ throwErrorMsg ("higher-order matching of pattern " ++ show p ++ " of type " ++ show vc' ++ " not allowed") + let flexgen = concat $ map (\ g -> case g of + DotFlex i _ _ -> [i] + _ -> []) flex' + -- fst $ unzip flex' +-- av1 <- sing (environ cxt') (patternToExpr p) vc' +-- av2 <- sing (environ cxt') (patternToExpr p) av +-- subst <- local (\ _ -> cxt') $ inst flexgen VSet av1 av2 + + + -- need to evaluate the erased pattern! + let pe = ConP pi n ple -- erased pattern + -- dot <- if dottedPat pi then newDotted p else return notDotted + dot <- if dottedPat pi then mkDotted True else return notDotted + pv0 <- mkConVal dot co n pvs vc + -- OLD: let pv0 = VDef (DefId (ConK co) n) `VApp` pvs +{- + let epe = patternToExpr pe + pv0 <- local (\ _ -> cxt') $ whnf' epe +-- pv0 <- patternToVal p -- THIS USE should be ok, since the new GENs are not in the global context yet, only in cxt' -- NO LONGER ok with erasure! + -- traceM $ "sucessfully computed value " ++ show pv0 ++ " of pattern " ++ show epe +-} + + subst <- local (\ _ -> cxt') $ do + case av of -- TODO: need subtyping-unify instead of unify?? + VSing vav av0 -> do + vav <- whnfClos vav + inst Pos flexgen av0 pv0 vav + _ -> unifyIndices flexgen vc' av -- vc' <= av ?! + -- THIS IMPLEMENTATION RELIES HEAVILY ON INJECTIVITY OF DATAS + +{- moved to checkRHS + -- apply substitution to measures in environment + let mmu = (envBound . environ) cxt' + mmu' <- Traversable.mapM (substitute subst) mmu +-} +{- + ins'' <- compSubst ins' subst + vb <- substitute ins'' vb + delta' <- substitute ins'' delta' +-} + ins'' <- compSubst ins' subst -- 2010-07-27 not ok to switch! + delta'' <- substitute ins'' (context cxt') + traceCheckM $ "delta'' = " ++ show delta'' + av <- substitute ins'' av -- 2010-09-22: update av + pv <- up False pv0 av + + -- if the constructor was dotted, make sure it is the only match + let flex'' = fwhen dotted (DottedCons dot p av :) flex' + return (flex'', ins'', cxt' { context = delta'' }, + maybeErase pe, pv, absp) +{- DO NOT UPDATE measure here, its done in checkRHS + return (flex', ins'', cxt' { context = delta'', environ = (environ cxt') { envBound = mmu' } }, vb', + maybeErase pe, absp) +-} + + +{- UNUSED + -- If we encounter a dotted constructor, we simply + -- compute the pattern variable context + -- and then treat the pattern as dot pattern. + p@(ConP pi n ps) | dottedPat pi -> do + (vc,(flex',ins',cxt',vc',ple,pvs,absp)) <- + checkConstructorPattern (coPat pi) n ps + local (const cxt') $ + checkPattern' flex ins domEr $ DotP $ patternToExpr p +-} + + DotP e -> do + -- create an informative, but irrelevant identifier for dot pattern + let xp = fresh $ "." ++ case e of Var z -> suggestion z; _ -> Util.parens $ show e + newWithGen xp domEr $ \ k xv -> do + cxt' <- ask + -- traceCheck ("Returning type " ++ show vb) $ + return (DotFlex k (Just e) domEr : flex + ,ins + ,cxt' + ,maybeErase $ DotP e -- $ Var xp -- DotP $ Meta k -- e -- Meta k + -- ,maybeErase $ -- AbsurdP -- VarP $ show e + ,xv + ,False) -- TODO: Erase in e/ Meta subst! +{- original code + do let (k, delta') = cxtPush dec av delta + vb <- whnf (update env x (VGen k)) b + return ((k,(e,Domain av dec)):flex + ,ins + ,rho + ,delta' + ,vb) +-} + + where + maybeErase p = if erased decEr then ErasedP p else p + + checkConstructorPattern co n pl = do + when (isFunType av) $ throwErrorMsg ("higher-order matching of pattern " ++ show p ++ " at type " ++ show av ++ " not allowed") +-- TODO: ensure that matchings against erased arguments are forced +-- when (erased dec) $ throwErrorMsg $ "checkPattern: cannot match on erased argument " ++ show p ++ " : " ++ show av + + ConSig {conPars, lhsTyp = sz, recOccs, symbTyp = vc, dataName, dataPars} <- lookupSymbQ n + + -- the following is a hack to still support old-style + -- add .($ i) (zero i) ... + -- fun defs: if (zero i) is matched against (Nat flexvar$i) + -- we use the old constructor type [i : Size] -> Nat $i + -- else, the new one [j < i] -> Nat i + let flexK k (DotFlex k' _ _) = k == k' + flexK k _ = False + -- use lhs con type only if sizeindex is not a rigid var + isFlex (VGen k) = List.any (flexK k) flex + isFlex _ = True + isSz = if co == Cons then sz else Nothing + vc <- instConLType n conPars vc isSz isFlex dataPars =<< force av +{- + vc <- case sz of + Nothing -> instConType n nPars vc =<< force av + Just vc -> instConType n (nPars+1) vc =<< force av +-} + + -- (flex',ins',cxt',vc',ple,pvs,absp) <- + (vc,) <$> checkPatterns decEr flex ins vc pl + + + -- These checks are only relevant if a constructor is an actual match. + nonDottedConstructorChecks n co pl = do + ConSig {conPars, lhsTyp = sz, recOccs, symbTyp = vc, dataName, dataPars} <- lookupSymbQ n + + -- check that size argument of coconstr is dotted + when (co == CoCons && isJust sz) $ do + let sizep = head pl -- 2012-01-22: WAS (pl !! nPars) + unless (isDotPattern sizep) $ + throwErrorMsg $ "in pattern " ++ show p ++ ", coinductive size sub pattern " ++ show sizep ++ " must be dotted" + + when (not $ decEr `elem` map Dec [Const,Rec]) $ + recoverFail $ "cannot match pattern " ++ show p ++ " against non-computational argument" + -- check not to match non-trivially against erased stuff + when (decEr == Dec Const) $ do + let failNotForced = recoverFail $ "checkPattern: constructor " ++ show n ++ " of non-computational argument " ++ show p ++ " : " ++ show av ++ " not forced" + mcenvs <- matchingConstructors av + case mcenvs of + Nothing -> do -- now check whether dataName is a record type + DataSig { constructors } <- lookupSymb dataName + unless (length constructors == 1) $ failNotForced + return () + Just [] -> recoverFail $ "checkPattern: no constructor matches type " ++ show av + Just [(ci, _)] | cName ci == n -> return () + _ -> failNotForced + + + + +{- New treatment of size matching (see examples/Sized/Cody.ma) + +sized data O : Size -> Set +{ Z : [i : Size] -> O ($ i) +; S : [i : Size] -> O i -> O ($ i) +; L : [i : Size] -> (Nat -> O i) -> O ($ i) +; M : [i : Size] -> O i -> O i -> O ($ i) +} + +fun deep : [i : Size] -> O i -> Nat -> Nat +{ deep i4 (M i3 (L j2 f) (S i2 (S i1 (S i x)))) n + = deep _ (M _ (L _ (pre _ f)) (S _ (f n))) (succ (succ (succ n))) +; deep i x n = n +} + +Explicit form: Size variables and their constraints are noted explicitely, +to be able to do untyped call extraction in the termination module. + + deep i4 + (M (i4 > i3) + (L (i3 > j2) f) + (S (i3 > i2) + (S (i2 > i1) + (S (i1 > i) x)))) n + = deep _ (M _ (L _ (pre _ f)) (S _ (f n))) (succ (succ (succ n))) + +i4, i3, ... are all rigid variables with constraints between them. +There is a tree hierarchy, but I do not know whether I can exploit +this. + + i4 > i3 > i2 > i1 > i + > j3 + +This could be stored in a union-find-like data structure, or just in +the constraint matrix. + +How to pattern match? + + id : [i : Size] -> List i -> List i + id i (cons (i > j) x xs) = cons j x (id j xs) + +Only a size variable matches a size arguments + + match (cons (i > j) x xs) against List i + get cons : [j : Size] -> Nat -> List j -> List ($ j) + yield x : Nat, xs : List j, cons j x xs : List ($ j) + check List ($ j) <= List i + -} + +{- RETIRED +-- checkDot does not need to extract +checkDot :: Substitution -> DotFlex -> TypeCheck () +checkDot subst (i,(e,it)) = enter ("dot pattern " ++ show e) $ + case (lookup i subst) of + Nothing -> throwErrorMsg $ "not instantiated" + Just v -> do + tv <- substitute subst (typ it) + ask >>= \ ce -> traceCheckM ("checking dot pattern " ++ show ce ++ " |- " ++ show e ++ " : " ++ show (decor it) ++ " " ++ show tv) + applyDec (decor it) $ do + checkExpr e tv + v' <- whnf' e -- TODO: has subst erased terms? + enter ("inferred value " ++ show v ++ " does not match given dot pattern value " ++ show v') $ + eqVal Pos tv v v' +-} + +-- checkDot does not need to extract +-- 2012-01-25 now we do since "extraction" turns also con.terms into records +checkGoal :: Substitution -> Goal -> TypeCheck () +checkGoal subst (DotFlex i me it) = enter ("dot pattern " ++ show me) $ + case lookupSub i subst of + Nothing -> recoverFail $ "not instantiated" + Just v -> whenJust me $ \ e -> do + tv <- substitute subst (typ it) + ask >>= \ ce -> traceCheckM ("checking dot pattern " ++ show ce ++ " |- " ++ show e ++ " : " ++ show (decor it) ++ " " ++ show tv) +-- applyDec (decor it) $ do + resurrect $ do -- consider a DotP e always as irrelevant! + e <- valueOf <$> checkExpr e tv + v' <- whnf' e -- TODO: has subst erased terms? + enterDoc (text "inferred value" <+> prettyTCM v <+> text "does not match given dot pattern value" <+> prettyTCM v') $ + leqVal Pos tv v v' -- WAS: eqVal +checkGoal subst (MaxMatches n av) = do + traceCheckM ("checkGoal _ $ MaxMatches " ++ show n ++ " $ " ++ show av) + av' <- substitute subst av + traceCheckM ("checkGoal _ $ MaxMatches " ++ show n ++ " $ " ++ show av') + -- av' <- reval av' + -- traceCheckM ("checkGoal: reevalutated " ++ show av') + mcenvs <- matchingConstructors av' + traceCheckM ("checkGoal matching constructors = " ++ show mcenvs) + maybe (recoverFail $ "not a data type: " ++ show av') + (\ cenvs -> + if length cenvs > n then recoverFail $ + if n==0 then "absurd pattern does not match since type " ++ show av' ++ " is not empty" + else + "more than one constructor matches type " ++ show av' + else return ()) + mcenvs +checkGoal subst (DottedCons dot p av) + | isDotted dot = + enterDoc (text "confirming dotted constructor" <+> prettyTCM p) $ do + checkGoal subst (MaxMatches 1 av) + | otherwise = return () + +checkRHS :: Substitution -> Expr -> TVal -> TypeCheck (Kinded Extr) +checkRHS ins rhs v = do + traceCheckM ("checking rhs " ++ show rhs ++ " : " ++ show v) + enter "right hand side" $ do + -- first update measure according to substitution for dot variables + cxt <- ask + let rho = environ cxt + mmu' <- Traversable.mapM (substitute ins) (envBound rho) + local (\ _ -> cxt { environ = rho { envBound = mmu' }}) $ + activateFuns $ + checkExpr rhs v + + + +-- TODO type directed unification + +-- unifyIndices flex tv1 tv2 +-- tv1 = D pars inds is the type of the pattern +-- tv2 = D pars' inds' is the type matched against +-- Note that in this case we can unify without using the principle of +-- injective data type constructors, +-- we are only calling unifyIndices from the constructor pattern case +-- in Checkpattern +unifyIndices :: [Int] -> Val -> Val -> TypeCheck Substitution +unifyIndices flex v1 v2 = ask >>= \ cxt -> enterDoc (text ("unifyIndices " ++ show (context cxt) ++ " |-") <+> prettyTCM v1 <+> text ("?<=" ++ show Pos) <+> prettyTCM v2) $ do +-- {- + case (v1,v2) of + (VSing _ v1, VApp (VDef (DefId DatK d2)) vl2) -> + flip (unifyIndices flex) v2 =<< whnfClos v1 + (VApp (VDef (DefId DatK d1)) vl1, VApp (VDef (DefId DatK d2)) vl2) | d1 == d2 -> do + (DataSig { numPars = np, symbTyp = tv, positivity = posl}) <- lookupSymbQ d1 + instList posl flex tv vl1 vl2 -- unify also parameters to solve dot patterns + _ -> +-- -} + inst Pos flex vTopSort v1 v2 +-- throwErrorMsg ("unifyIndices " ++ show v1 ++ " =?= " ++ show v2 ++ " failed, not applied to data types") + +-- unify, but first produce whnf +instWh :: Pol -> [Int] -> TVal -> Val -> Val -> TypeCheck Substitution +instWh pos flex tv w1 w2 = do + v1 <- whnfClos w1 + v2 <- whnfClos w2 + inst pos flex tv v1 v2 + +-- | Check occurrence and return singleton substitution. +assignFlex :: Int -> Val -> TypeCheck Substitution +assignFlex k v = do + unlessM (nocc [k] v) $ + failDoc $ + text "variable " <+> prettyTCM (VGen k) <+> + text " may not occur in " <+> prettyTCM v + return $ sgSub k v + +-- match v1 against v2 by unification , yielding a substition +inst :: Pol -> [Int] -> TVal -> Val -> Val -> TypeCheck Substitution +inst pos flex tv v1 v2 = ask >>= \ cxt -> enterDoc (text ("inst " ++ show (context cxt) ++ " |-") <+> prettyTCM v1 <+> text ("?<=" ++ show pos) <+> prettyTCM v2 <+> colon <+> prettyTCM tv) $ do +-- case tv of +-- (VPi dec x av env b) -> + case (v1,v2) of + (VGen k, VGen j) | k == j -> return emptySub + (VGen k, _) | elem k flex -> assignFlex k v2 + (_, VGen k) | elem k flex -> assignFlex k v1 + + -- injectivity of data type constructors is unsound in general + (VApp (VDef (DefId DatK d1)) vl1, + VApp (VDef (DefId DatK d2)) vl2) | d1 == d2 -> do + (DataSig { numPars, symbTyp = tv, positivity = posl }) <- lookupSymbQ d1 + instList' numPars posl flex tv vl1 vl2 + -- ignore parameters (first numPars args) + -- this is sound because we have irrelevance for parameters + -- we assume injectivity for indices + + -- Constructor applications are represented as VRecord + (VRecord (NamedRec _ c1 _ dot1) rs1, + VRecord (NamedRec _ c2 _ dot2) rs2) | c1 == c2 -> do + alignDotted dot1 dot2 + sige <- lookupSymbQ c1 + instList [] flex (symbTyp sige) (map snd rs1) (map snd rs2) + + (VSucc v1', VSucc v2') -> instWh pos flex tv v1' v2' + (VSucc v, VInfty) -> instWh pos flex tv v VInfty + (VSing v1' tv1, VSing v2' tv2) -> do + subst <- inst pos flex tv tv1 tv2 + u1 <- substitute subst v1' + u2 <- substitute subst v2' + tv1' <- substitute subst tv1 + inst pos flex tv1' u1 u2 >>= compSubst subst + +-- HACK AHEAD + (VUp v1 _, _) -> inst pos flex tv v1 v2 + (_, VUp v2 _) -> inst pos flex tv v1 v2 +-- (VUp v1' a1, VUp v2' a2) -> instList flex [a1,v1'] [a2,v2'] +-- (VPi dec x1 av1 env1 b1, VPi dec x2 av2 env2 b2) -> + +{- TODO: REPAIR THIS + _ -> traceCheck ("inst: WARNING! assuming " ++ show (context cxt) ++ " |- " ++ show v1 ++ " == " ++ show v2) $ + return [] -- throwErrorMsg $ "inst: NYI" + -} + _ -> do leqVal pos tv v1 v2 `throwTrace` ("inst: leqVal " ++ show v1 ++ " ?<=" ++ show pos ++ " " ++ show v2 ++ " : " ++ show tv ++ " failed") + return emptySub + +instList :: [Pol] -> [Int] -> TVal -> [Val] -> [Val] -> TypeCheck Substitution +instList = instList' 0 + +-- unify lists, ignoring the first np items +instList' :: Int -> [Pol] -> [Int] -> TVal -> [Val] -> [Val] -> TypeCheck Substitution +instList' np posl flex tv [] [] = return emptySub +instList' np posl flex tv (v1:vl1) (v2:vl2) = do + v1 <- whnfClos v1 + v2 <- whnfClos v2 + if (np <= 0 || isMeta flex v1 || isMeta flex v2) then + case tv of + (VQuant Pi x dom fv) -> do + let pol = getPol dom -- WAS: (headPosl posl) + subst <- inst pol flex (typ dom) v1 v2 + vl1' <- mapM (substitute subst) vl1 + vl2' <- mapM (substitute subst) vl2 + v <- substitute subst v1 + fv <- substitute subst fv + vb <- app fv v + subst' <- instList' (np - 1) (tailPosl posl) flex vb vl1' vl2' + compSubst subst subst' + else + case tv of + (VQuant Pi x dom fv) -> do + vb <- app fv v2 + instList' (np - 1) (tailPosl posl) flex vb vl1 vl2 +instList' np pos flex tv vl1 vl2 = throwErrorMsg $ "internal error: instList' " ++ show (np,pos,flex,tv,vl1,vl2) ++ " not handled" + +headPosl :: [Pol] -> Pol +headPosl [] = mixed +headPosl (pos:_) = pos + +tailPosl :: [Pol] -> [Pol] +tailPosl [] = [] +tailPosl (_:posl) = posl + + +isMeta :: [Int] -> Val -> Bool +isMeta flex (VGen k) = k `elem` flex +isMeta _ _ = False + +---------------------------------------------------------------------- +-- * Substitution into values +---------------------------------------------------------------------- + +-- | Overloaded substitution of values for generic values (free variables). +class Substitute a where + substitute :: Substitution -> a -> TypeCheck a + +instance Substitute v => Substitute (x,v) where + substitute subst (x,v) = (x,) <$> substitute subst v + +instance Substitute v => Substitute [v] where + substitute = mapM . substitute + +instance Substitute v => Substitute (Maybe v) where + substitute = Traversable.mapM . substitute + +instance Substitute v => Substitute (Map k v) where + substitute = Traversable.mapM . substitute + +instance Substitute v => Substitute (OneOrTwo v) where + substitute = Traversable.mapM . substitute + +instance Substitute v => Substitute (Dom v) where + substitute = Traversable.mapM . substitute + +instance Substitute v => Substitute (Measure v) where + substitute = Traversable.mapM . substitute + +instance Substitute v => Substitute (Bound v) where + substitute = Traversable.mapM . substitute + +instance Substitute v => Substitute (Sort v) where + substitute = Traversable.mapM . substitute + +-- substitute generic variable in value +instance Substitute Val where + substitute subst v = do -- enterDoc (text "substitute" <$> prettyTCM v) $ do + let sub v = substitute subst v + case v of + VGen k -> return $ valuateGen k subst + VApp v1 vl -> foldM app ==<< (sub v1, sub vl) + VSing v1 vt -> vSing ==<< (sub v1, sub vt) -- TODO: Check reevaluation necessary? + + VSucc v1 -> succSize <$> substitute subst v1 + VMax vs -> maxSize <$> mapM (substitute subst) vs + VPlus vs -> plusSizes <$> mapM (substitute subst) vs + + VCase v1 tv1 env cl -> VCase <$> sub v1 <*> sub tv1 <*> sub env <*> return cl + VMeasured mu bv -> VMeasured <$> sub mu <*> sub bv + VGuard beta bv -> VGuard <$> sub beta <*> sub bv + + VBelow ltle v -> VBelow ltle <$> substitute subst v + + VQuant pisig x dom fv -> VQuant pisig x <$> sub dom <*> sub fv + VRecord ri rs -> VRecord ri <$> sub rs + VPair v1 v2 -> VPair <$> sub v1 <*> sub v2 + VProj{} -> return v + + VLam x env b -> flip (VLam x) b <$> sub env + VConst v -> VConst <$> sub v + VAbs x i v valu -> VAbs x i v <$> sub valu + VClos env e -> flip VClos e <$> sub env + VUp v1 vt -> up False ==<< (sub v1, sub vt) + VSort s -> VSort <$> sub s + VZero -> return $ v + VInfty -> return $ v + VIrr -> return $ v + VDef id -> return $ vDef id -- because empty list of apps will be rem. + VMeta x env n -> flip (VMeta x) n <$> sub env +{- REDUNDANT + _ -> error $ "substitute: internal error: not defined for " ++ show v +-} + +instance Substitute SemCxt where + substitute subst delta = do + cxt' <- substitute subst (cxt delta) + return $ delta { cxt = cxt' } + +-- | Substitute in environment. +instance Substitute Env where + substitute subst (Environ rho mmeas) = + Environ <$> substitute subst rho <*> substitute subst mmeas + +instance Substitute Substitution where + substitute subst2 subst1 = compSubst subst1 subst2 + +-- | "merge" substitutions by first applying the second to the first, then +-- appending them @t[sigma][tau] = t[sigma . tau]@ +compSubst :: Substitution -> Substitution -> TypeCheck Substitution +compSubst (Valuation subst1) subst2@(Valuation subst2') = + Valuation . (++ subst2') <$> substitute subst2 subst1 + +---------------------------------------------------------------------- +-- * Size checking +---------------------------------------------------------------------- + +{- TODO: From a sized data declaration + + sized data D pars : Size -> t + { c : [j : Size] -> args -> D pars $j ts + } + + with constructor type + + c : .pars -> [j : Size] -> args -> D pars $j ts + + extract new-style constructor type + + c : .pars -> [i : Size] -> [j < i : Size] -> args -> D pars i ts + + Then replace in ConSig filed isSized :: Sized by :: Maybe Expr + which stores the new-style constructor type + +-} + +mkConLType :: Int -> Expr -> (Name, Expr) +mkConLType npars t = + let (Telescope (sizetb : tel), t0) = typeToTele t + in case spineView t0 of + (d@(Def (DefId DatK _)), args) -> + let (pars, sizeindex : inds) = splitAt npars args + i = fresh "s!ze" + args' = pars ++ Var i : inds + core = foldl App d args' + tbi = TBind i $ sizeDomain irrelevantDec + tbj = sizetb { boundDom = belowDomain irrelevantDec Lt (Var i) } + tel' = Telescope $ tbi : tbj : tel + in (i, teleToType tel' core) + _ -> error $ "conLType " ++ show npars ++ " (" ++ show t ++ "): illformed constructor type" + + + +-- * check wether the data type is sized type + + +-- check data declaration type +-- called from typeCheckDeclaration (DataDecl{}) +-- parameters : number of params, type +szType :: Co -> Int -> TVal -> TypeCheck () +szType co p tv = doVParams p tv $ \ tv' -> do + let polsz = if co==Ind then Pos else Neg + case tv' of + VQuant Pi x (Domain av ki dec) fv | isVSize av && not (erased dec) && polarity dec == polsz -> return () + _ -> throwErrorMsg $ "not a sized type, target " ++ show tv' ++ " must have non-erased domain " ++ show Size ++ " with polarity " ++ show polsz + +-- * constructors of sized type + +-- check data constructors +-- called from typeCheckConstructor +szConstructor :: Name -> Co -> Int -> TVal -> TypeCheck () +szConstructor n co p tv = enterDoc (text ("szConstructor " ++ show n ++ " :") <+> prettyTCM tv) $ do + doVParams p tv $ \ tv' -> + case tv' of + VQuant Pi x dom fv | isVSize (typ dom) -> + underAbs x dom fv $ \ k xv bv -> do + szSizeVarUsage n co p k bv + _ -> throwErrorMsg $ "not a valid sized constructor: expected size quantification" + +szSizeVarUsage :: Name -> Co -> Int -> Int -> TVal -> TypeCheck () +szSizeVarUsage n co p i tv = enterDoc (text "szSizeVarUsage of" <+> prettyTCM (VGen i) <+> text "in" <+> prettyTCM tv) $ + case tv of + VQuant Pi x dom fv -> do + let av = typ dom + szSizeVarDataArgs n p i av -- recursive calls of for D..i.. + enterDoc (text "checking" <+> prettyTCM av <+> text (" to be " ++ + (if co == CoInd then "antitone" else "isotone") ++ " in variable") + <+> prettyTCM (VGen i)) $ + szMono co i av -- monotone in i + underAbs x dom fv $ \ _ xv bv -> do + szSizeVarUsage n co p i bv + + _ -> szSizeVarTarget p i tv + +-- check that Target is of form D ... (Succ i) ... +szSizeVarTarget :: Int -> Int -> TVal -> TypeCheck () +szSizeVarTarget p i tv = enterDoc (text "szSizeVarTarget, variable" <+> prettyTCM (VGen i) <+> text ("argument no. " ++ show p ++ " in") <+> prettyTCM tv) $ do + let err = text "expected target" <+> prettyTCM tv <+> text "of size" <+> prettyTCM (VSucc (VGen i)) + case tv of + VSing _ tv -> szSizeVarTarget p i =<< whnfClos tv + VApp d vl -> do + v0 <- whnfClos (vl !! p) + case v0 of + (VSucc (VGen i')) | i == i' -> return () + _ -> failDoc err + _ -> failDoc err + + +-- check that rec. arguments are of form D ... i .... +-- and size used nowhere else ?? -- Andreas, 2009-11-27 TOO STRICT! +{- accepts, for instance + + Nat -> Ord i as argument of a constructor of Ord ($ i) + List (Rose A i) as argument of a constructor of Rose A ($i) + -} +szSizeVarDataArgs :: Name -> Int -> Int -> TVal -> TypeCheck () +szSizeVarDataArgs n p i tv = enterDoc (text "sizeVarDataArgs" <+> prettyTCM (VGen i) <+> text "in" <+> prettyTCM tv) $ do + case tv of + + {- case D pars sizeArg args -} + VApp (VDef (DefId DatK (QName m))) vl | n == m -> do + let (pars, v0 : idxs) = splitAt p vl + v0 <- whnfClos v0 + case v0 of + VGen i' | i' == i -> do + forM_ (pars ++ idxs) $ \ v -> nocc [i] v >>= do + boolToErrorDoc $ + text "variable" <+> prettyTCM (VGen i) <+> + text "may not occur in" <+> prettyTCM v + _ -> failDoc $ + text "wrong size index" <+> prettyTCM v0 <+> + text "at recursive occurrence" <+> prettyTCM tv + +-- not necessary: check for monotonicity above +-- {- case D' pars sizeArg args -} +-- VApp (VDef m) vl | n /= m -> do + + VApp v1 vl -> mapM_ (\ v -> whnfClos v >>= szSizeVarDataArgs n p i) (v1:vl) + + VQuant Pi x dom fv -> do + szSizeVarDataArgs n p i (typ dom) + underAbs x dom fv $ \ _ xv bv -> do + szSizeVarDataArgs n p i bv + + fv | isFun fv -> + addName (absName fv) $ \ xv -> szSizeVarDataArgs n p i =<< app fv xv +{- + VLam x env b -> + addName x $ \ xv -> do + bv <- whnf (update env x xv) b + szSizeVarDataArgs n p i bv +-} + _ -> return () + +{- REMOVED, 2009-11-28, replaced by monotonicity check + VGen i' -> return $ i' /= i + VSucc tv' -> szSizeVarDataArgs n p i tv' + -} + +-- doVParams number_of_params constructor_or_datatype_signature +-- skip over parameters of type signature of a constructor/data type +doVParams :: Int -> TVal -> (TVal -> TypeCheck a) -> TypeCheck a +doVParams 0 tv k = k tv +doVParams p (VQuant Pi x dom fv) k = + underAbs x dom fv $ \ _ xv bv -> do + doVParams (p - 1) bv k + +-------------------------------------- +-- check for admissible type + +{- + + - admissibility needs to be check clausewise, because of Karl's example + + fun nonAdmissibleType : Unit -> Set + + fun diverge : (u : Unit) -> nonAdmissibleType u + { + diverge unit patterns = badRhs + } + + - the type must be admissible in the current position + only if the size pattern is a successor. + If the pattern is a variable, then there is no induction on that size + argument, so no limit case, so no upper semi-continuity necessary + for the type. + + - when checking + + ... (s i) ps admissible (j : Size) -> A + + we will check + + A admissible in j + + and continue with + + ... ps admissible A[s i / j] + + just to maintain type wellformedness. The (s i) in A does not + really matter, since there is no case distinction on ordinals. + + - a size pattern which is not inductive (meaning there is an + inductive type indexed by that size) nor coinductive (meaning that + the result type is coinductive and is indexed by that size) must + be flagged unusable for termination checking. + + - the fun/cofun distinction could be inferred by the termination checker + or be clausewise as in Agda 2 + +-} + + +admFunDef :: Co -> [Clause] -> TVal -> TypeCheck [Clause] +admFunDef co cls tv = do + (cls, inco) <- admClauses cls tv + when (co==CoInd && not (co `elem` inco)) $ + throwErrorMsg $ show tv ++ " is not a type of a cofun" -- ++ if co==Ind then "fun" else "cofun" + return cls + +admClauses :: [Clause] -> TVal -> TypeCheck ([Clause], [Co]) +admClauses [] tv = return ([], []) +admClauses (cl:cls) tv = do + (cl',inco) <- admClause cl tv + (cls',inco') <- admClauses cls tv + return (cl' : cls', inco ++ inco') + +admClause :: Clause -> TVal -> TypeCheck (Clause, [Co]) +admClause (Clause tel ps e) tv = traceAdm ("admClause: admissibility of patterns " ++ show ps) $ + introPatterns ps tv $ \ pvs _ -> do + (ps', inco) <- admPatterns pvs tv + return (Clause tel ps' e, inco) + +admPatterns :: [(Pattern,Val)] -> TVal -> TypeCheck ([Pattern], [Co]) +admPatterns [] tv = do + isCo <- endsInCo tv + return ([], if isCo then [CoInd] else []) +admPatterns ((p,v):pvs) tv = do + (p, inco1) <- admPattern p tv + bv <- piApp tv v + (ps, inco2) <- admPatterns pvs bv + return (p:ps, inco1 ++ inco2) + +{- +-- turn a pattern into a value +-- extend delta by generic values but do not introduce their types +evalPat :: Pattern -> (Val -> TypeCheck a) -> TypeCheck a +evalPat p f = + case p of + VarP n -> addName n f + ConP co n [] -> f (VCon co n) + ConP co n pl -> evalPats pl $ \ vl -> f (VApp (VCon co n) vl) + SuccP p -> evalPat p $ \ v -> f (VSucc v) +-- DOES NOT WORK SINCE e has unbound variables + DotP e -> do + v <- whnf' e + f v + +evalPats :: [Pattern] -> ([Val] -> TypeCheck a) -> TypeCheck a +evalPats [] f = f [] +evalPats (p:ps) f = evalPat p $ \ v -> evalPats ps $ \ vs -> f (v:vs) +-} + +{- +evalPat :: Pattern -> TypeCheck (State TCContext Val) +evalPat p = + case p of + VarP n -> return $ State $ \ ce -> + let (k, delta) = cxtPushGen (context ce) + rho = update n (VGen k) (environ ce) + in (VGen k, TCContext { context = delta, environ = rho }) + ConP co n [] -> return (VCon co n) + ConP co n pl -> do + vl <- mapM evalPat pl + return (VApp (VCon co n) vl) + SuccP p -> do + v <- evalPat p + return (VSucc v) +-- TODO: does not work! +-- DotP e -> return $ State $ \ ce -> +-} + + + + +{- 2013-03-31 On instantiation of quantifiers [i < #] - F i + +If F is upper semi-continuous then + + [i < #] -> F i is a sub"set" of F # + +so we can instantiate i to #. (Hughes et al., POPL 96; Abel, LMCS 08) + +1) Consider the special case + + F i = [j < i] -> G i + +Because # is a limit, thus, j < i < # iff j < #, we reason: + + F # = [j < #] -> G j + + [i < #] -> F i + = [i < #] -> [j < i] -> G j (since # is a limit) + = [j < #] -> G j + +2) Consider the special case + + F i = [j <= i] -> G j + +We have + + F # = [j <= #] -> G j + = G # /\ ([j < #] -> G j) + + [i < #] -> F i + = [i < #] -> [j <= i] -> G j + = [j < #] -> G j + +So if G is upper semi-continuous, so is F. + +-} + + +-- | Check whether a type is upper semi-continuous. +lowerSemiCont :: Int -> TVal -> TypeCheck Bool +lowerSemiCont i tv = errorToBool $ lowerSemiContinuous i tv + +docNotLowerSemi i av = text "type " <+> prettyTCM av <+> + text " not lower semi continuous in " <+> prettyTCM (VGen i) + +lowerSemiContinuous :: Int -> TVal -> TypeCheck () +lowerSemiContinuous i av = do + av <- force av + let fallback = szAntitone i av `newErrorDoc` docNotLowerSemi i av + + case av of + + -- [j < i] & F j is lower semi-cont in i + -- because [i < #] & [j < i] & F j is the same as [j < #] & F j + -- [but what if i in FV(F j)? should not matter!] 2013-04-01 + VQuant Sigma x dom@Domain{ typ = VBelow Lt (VGen i') } fv | i == i' -> return () + + -- [j <= i] & F j is lower semi-cont in i if F is + VQuant Sigma x dom@Domain{ typ = VBelow Le (VGen i') } fv | i == i' -> do + underAbs x dom fv $ \ j xv bv -> lowerSemiContinuous j bv + + -- Sigma-type general case + VQuant Sigma x dom@Domain{ typ = av } fv -> do + lowerSemiContinuous i av + underAbs x dom fv $ \ _ xv bv -> lowerSemiContinuous i bv + + VApp (VDef (DefId DatK n)) vl -> do + sige <- lookupSymbQ n + case sige of + + -- finite tuple type + DataSig { symbTyp = dv, constructors = cis, isTuple = True } -> do + -- match target of constructor against tv to instantiate + -- c : ... -> D ps -- ps = snd (cPatFam ci) + mrhoci <- Util.firstJustM $ map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis + case mrhoci of + Nothing -> fallback + Just (rho,ci) -> if (cRec ci) then fallback else do + -- infinite tuples (recursive constructor) are not lower semi cont + enter ("lowerSemiContinuous: detected tuple type, checking components") $ + allComponentTypes (cFields ci) rho (lowerSemiContinuous i) + + -- i-sized inductive types are lower semi-cont in i + DataSig { numPars, isSized = Sized, isCo = Ind } | length vl > numPars -> do + s <- whnfClos $ vl !! numPars -- the size argument is the first fgter the parameters + case s of + VGen i' | i == i' -> return () + _ -> fallback + + -- finite inductive type + DataSig { symbTyp = dv, constructors = cis, isCo = Ind } -> + -- if any cRec cis then fallback else do -- we loop on recursive data, so exclude + -- check that we do not loop on the same data names... + ifM ((n `elem`) <$> asks callStack) fallback $ do + local (\ ce -> ce { callStack = n : callStack ce }) $ do + -- match target of constructor against tv to instantiate + -- c : ... -> D ps -- ps = snd (cPatFam ci) + forM_ cis $ \ ci -> do + match <- nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv + Foldable.forM_ match $ \ rho -> do + enter ("lowerSemiContinuous: detected tuple type, checking components") $ + allComponentTypes (cFields ci) rho (lowerSemiContinuous i) + + _ -> fallback + _ -> fallback + +-- | Check whether a type is upper semi-continuous. +upperSemiCont :: Int -> TVal -> TypeCheck Bool +upperSemiCont i tv = errorToBool $ endsInSizedCo' False i tv + -- 2013-03-30 + -- endsInSizedCo needs tv[0/i] = Top + -- upperSemiCont does not need this, the target can also be constant in i + +-- | @endsInSizedCo i tv@ checks that @tv@ is lower semi-continuous in @i@ +-- and that @tv[0/i] = Top@. +endsInSizedCo :: Int -> TVal -> TypeCheck () +endsInSizedCo = endsInSizedCo' True + +-- | @endsInSizedCo' False i tv@ checks that @tv@ is lower semi-continuous in @i@. +-- @endsInSizedCo' True i tv@ additionally checks that @tv[0/i] = Top@. +endsInSizedCo' :: Bool -> Int -> TVal -> TypeCheck () +endsInSizedCo' endInCo i tv = enterDoc (text "endsInSizedCo:" <+> prettyTCM tv) $ do + tv <- force tv + let fallback + | endInCo = failDoc $ text "endsInSizedCo: target" <+> prettyTCM tv <+> text "of corecursive function is neither a CoSet or codata of size" <+> prettyTCM (VGen i) <+> text "nor a tuple type" + | otherwise = szMonotone i tv + case tv of + VSort (CoSet (VGen i)) -> return () + VMeasured mu bv -> endsInSizedCo' endInCo i bv + + -- case forall j <= i. C j coinductive in i + VQuant Pi x dom@Domain{ typ = VBelow Le (VGen i') } fv | i == i' -> + underAbs x dom fv $ \ j xv bv -> + endsInSizedCo' endInCo j bv + VGuard (Bound Le (Measure [VGen j]) (Measure [VGen i'])) bv | i == i' -> + endsInSizedCo' endInCo j bv + + -- same case again, written as j < i+1. C j + VQuant Pi x dom@Domain{ typ = VBelow Lt (VSucc (VGen i')) } fv | i == i' -> + underAbs x dom fv $ \ j xv bv -> + endsInSizedCo' endInCo j bv + VGuard (Bound Lt (Measure [VGen j]) (Measure [VSucc (VGen i')])) bv | i == i' -> + endsInSizedCo' endInCo j bv + + -- case forall j < i. C j: already coinductive in i !! + -- Trivially, forall j < 0. C j is the top type. + -- And, forall i < # forall j < i is equivalent to forall j < # + -- so we can instantiate i to #. + VGuard (Bound Lt (Measure [VGen j]) (Measure [VGen i'])) bv | i == i' -> + return () + VQuant Pi x dom@Domain{ typ = VBelow Lt (VGen i') } fv | i == i' -> return () + + VQuant Pi x dom fv -> do + lowerSemiContinuous i $ typ dom + underAbs x dom fv $ \ _ xv bv -> endsInSizedCo' endInCo i bv + + VSing _ tv -> endsInSizedCo' endInCo i =<< whnfClos tv + VApp (VDef (DefId DatK n)) vl -> do + sige <- lookupSymbQ n + case sige of + DataSig { numPars = np, isSized = Sized, isCo = CoInd } + | length vl > np -> do + v <- whnfClos $ vl !! np + if isVGeni v then return () else fallback + where isVGeni (VGen i) = True + isVGeni (VPlus vs) = and $ map isVGeni vs + isVGeni (VMax vs) = and $ map isVGeni vs + isVGeni VZero = True + isVGeni _ = False +{- WE DO NOT HAVE SUBST ON VALUES! + case vl !! np of + VGen j -> if i == j then return () else fail1 + VZero -> return () + VClos rho e -> do + v <- whnf (update rho i VZero) e -- BUGGER + if v == VZero then return () else fail1 +-} +-- we also allow the target to be a tuple if all of its components +-- fulfill "endsInSizedCo" + DataSig { symbTyp = dv, constructors = cis, isTuple = True } -> do + allTypesOfTuple tv vl dv cis (endsInSizedCo' endInCo i) +{- + -- match target of constructor against tv to instantiate + -- c : ... -> D ps -- ps = snd (cPatFam ci) + mrhoci <- Util.firstJustM $ map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis + case mrhoci of + Nothing -> failDoc $ text "endsInSizedCo: panic: target type" <+> prettyTCM tv <+> text "is not an instance of any constructor" + Just (rho,ci) -> enter ("endsInSizedCo: detected tuple target, checking components") $ + fieldsEndInSizedCo endInCo i (cFields ci) rho +-} + _ -> fallback + _ -> fallback +{- failDoc $ text "endsInSizedCo: target" <+> prettyTCM tv <+> text "of corecursive function is neither a function type nor a codata nor a tuple type" +-} + +-- | @allTypesOfTyples args dv cis check@ performs @check@ on all component +-- types of tuple type @tv = d args@ where @dv@ is the type of @d@. +allTypesOfTuple :: TVal -> [Val] -> TVal -> [ConstructorInfo] -> (TVal -> TypeCheck ()) -> TypeCheck () +allTypesOfTuple tv vl dv cis check = do + -- match target of constructor against tv to instantiate + -- c : ... -> D ps -- ps = snd (cPatFam ci) + mrhoci <- Util.firstJustM $ + map (\ ci -> fmap (,ci) <$> nonLinMatchList False emptyEnv (snd $ cPatFam ci) vl dv) cis + -- we know that only one constructor can match, otherwise it would not be a tuple type + case mrhoci of + Nothing -> failDoc $ text "allTypesOfTuple: panic: target type" <+> prettyTCM tv <+> text "is not an instance of any constructor" + Just (rho,ci) -> enter ("allTypesOfTuple: detected tuple target, checking components") $ + allComponentTypes (cFields ci) rho check + +{- +fieldsEndInSizedCo :: Bool -> Int -> [FieldInfo] -> Env -> TypeCheck () +fieldsEndInSizedCo endInCo i fis rho0 = allComponentTypes fis rho0 (endsInSizedCo' endInCo i) +fieldsEndInSizedCo endInCo i fis rho0 = enter ("fieldsEndInSizedCo: checking fields of tuple type " ++ show fis ++ " in environment " ++ show rho0) $ + loop fis rho0 where + loop [] rho = return () + -- nothing to check for erased index fields + loop (f : fs) rho | fClass f == Index && erased (fDec f) = + loop fs rho + loop (f : fs) rho | fClass f == Index = do + tv <- whnf rho (fType f) + endsInSizedCo' endInCo i tv + loop fs rho + loop (f : fs) rho = do + tv <- whnf rho (fType f) + when (not $ erased (fDec f)) $ endsInSizedCo' endInCo i tv + -- for non-index fields, value is not given by matching, so introduce + -- generic value + new (fName f) (Domain tv defaultKind (fDec f)) $ \ xv -> do + let rho' = update rho (fName f) xv + -- do not need to check erased fields? + loop fs rho' +-} + +-- | @allComponentTypes fis env check@ applies @check@ to all field types +-- in @fis@ (evaluated wrt to environment @env@). +-- Erased fields are skipped. (Is this correct?) +allComponentTypes :: [FieldInfo] -> Env -> (TVal -> TypeCheck ()) -> TypeCheck () +allComponentTypes fis rho0 check = enter ("allComponentTypes: checking fields of tuple type " ++ show fis ++ " in environment " ++ show rho0) $ + loop fis rho0 where + loop [] rho = return () + + -- nothing to check for erased index fields + loop (f : fs) rho | fClass f == Index && erased (fDec f) = + loop fs rho + + -- ordinary index field types are checked + loop (f : fs) rho | fClass f == Index = do + check =<< whnf rho (fType f) + loop fs rho + + -- proper fields + loop (f : fs) rho = do + tv <- whnf rho (fType f) + -- do not need to check erased fields? + when (not $ erased (fDec f)) $ check tv + -- for non-index fields, value is not given by matching, so introduce + -- generic value + new (fName f) (Domain tv defaultKind (fDec f)) $ \ xv -> do + loop fs $ update rho (fName f) xv + + + +endsInCo :: TVal -> TypeCheck Bool +endsInCo tv = -- traceCheck ("endsInCo: " ++ show tv) $ + case tv of + VQuant Pi x dom fv -> underAbs x dom fv $ \ _ _ bv -> endsInCo bv + + VApp (VDef (DefId DatK n)) vl -> do + sige <- lookupSymbQ n + case sige of + DataSig { isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $ + return True + _ -> return False + _ -> return False + +-- precondition: Pattern does not contain "Unusable" +admPattern :: Pattern -> TVal -> TypeCheck (Pattern, [Co]) +admPattern p tv = traceAdm ("admPattern " ++ show p ++ " type: " ++ show tv) $ + case tv of + VGuard beta bv -> addBoundHyp beta $ admPattern p bv + VApp (VDef (DefId DatK d)) vl -> do + case p of + ProjP n -> return (p, []) + _ -> throwErrorMsg "admPattern: IMPOSSIBLE: non-projection pattern for record type" + VQuant Pi x dom fv -> underAbs x dom fv $ \ k xv bv -> do + {- + if p is successor pattern + check that bv is admissible in k, returning subset of [Ind, CoInd] + p is usable if either CoInd or it is a var or dot pattern and Ind +-} + if isSuccessorPattern p then do + inco <- admType k bv + when (CoInd `elem` inco && not (shallowSuccP p)) $ cannotMatchDeep p tv + if (CoInd `elem` inco) + || (inco /= [] && completeP p) + then return (p, inco) + else return (UnusableP p, inco) + else return (p, []) + + _ -> throwErrorMsg "admPattern: IMPOSSIBLE: pattern for a non-function type" + +cannotMatchDeep p tv = recoverFailDoc $ + text "cannot match against deep successor pattern" + <+> text (show p) <+> text "at type" <+> prettyTCM tv + +admType :: Int -> TVal -> TypeCheck [Co] +admType i tv = enter ("admType: checking " ++ show tv ++ " admissible in v" ++ show i) $ + case tv of + VQuant Pi x dom@(Domain av _ _) fv -> do + isInd <- szUsed Ind i av + when (not isInd) $ + szAntitone i av `newErrorDoc` docNotLowerSemi i av + underAbs x dom fv $ \ gen _ bv -> do + inco <- admType i bv + if isInd then return (Ind : inco) else return inco + _ -> do + isCoind <- szUsed CoInd i tv + if isCoind then return [CoInd] + else do + szMonotone i tv + return [] + +szUsed :: Co -> Int -> TVal -> TypeCheck Bool +szUsed co i tv = traceAdm ("szUsed: " ++ show tv ++ " " ++ show co ++ " in v" ++ show i) $ + case tv of + (VApp (VDef (DefId DatK n)) vl) -> + do sige <- lookupSymbQ n + case sige of + DataSig { numPars = p + , isSized = Sized + , isCo = co' } | co == co' && length vl > p -> + -- p is the number of parameters + -- it is also the index of the size argument + do s <- whnfClos $ vl !! p + case s of + VGen i' | i == i' -> return True + _ -> return False + _ -> return False + _ -> return False + + + +-- for inductive fun, and for every size argument i +-- - every argument needs to be either inductive or antitone in i +-- - the result needs to be monotone in i + +{- szCheckIndFun admpos delta tv + + entry point for admissibility check for recursive functions + - scans for the first size quantification + - passes on to szCheckIndFunSize + - currently: also continues to look for the next size quantification... + -} + +szCheckIndFun :: [Int] -> TVal -> TypeCheck () +szCheckIndFun admpos tv = -- traceCheck ("szCheckIndFun: " ++ show delta ++ " |- " ++ show tv ++ " adm?") $ + case tv of + VQuant Pi x dom fv -> underAbs x dom fv $ \ k _ bv -> do + -- bv <- whnf' b + if isVSize (typ dom) then do + when (k `elem` admpos) $ + szCheckIndFunSize k bv + szCheckIndFun admpos bv -- this is for lexicographic induction on sizes, I suppose? Probably should me more fine grained! Andreas, 2008-12-01 + else szCheckIndFun admpos bv + _ -> return () + + +{- szCheckIndFunSize delta i tv + + checks whether type tv is admissible for recursion in index i + - every argument needs to be either inductive or antitone in i + - the result needs to be monotone in i + -} + +szCheckIndFunSize :: Int -> TVal -> TypeCheck () +szCheckIndFunSize i tv = -- traceCheck ("szCheckIndFunSize: " ++ show delta ++ " |- " ++ show tv ++ " adm(v" ++ show i ++ ")?") $ + case tv of + VQuant Pi x dom fv -> do + szLowerSemiCont i (typ dom) +-- new x dom $ \ k _ -> szCheckIndFunSize i =<< app fv (VGen k) + underAbs x dom fv $ \ _ _ bv -> szCheckIndFunSize i bv +{- + new' x dom $ do + bv <- whnf' b + szCheckIndFunSize i bv +-} + _ -> szMonotone i tv + +{- szLowerSemiCont + + - check for lower semi-continuity [Abel, CSL 2006] + - current approximation: inductive type or antitone + -} +szLowerSemiCont :: Int -> TVal -> TypeCheck () +szLowerSemiCont i av = -- traceCheck ("szlowerSemiCont: checking " ++ show av ++ " lower semi continuous in v" ++ show i) $ + (szAntitone i av `catchError` + (\ msg -> -- traceCheck (show msg) $ + szInductive i av)) + `newErrorDoc` docNotLowerSemi i av + + +{- checking cofun-types for admissibility + +conditions: + +1. type must end in coinductive type or in sized coinductive type + indexed by just a variable i which has been quantified in the type + +2. in the second case, each argument must be inductive or antitone in i + optimization: + arguments types before the quantification over i can be ignored +-} + +data CoFunType + = CoFun -- yes, but not sized cotermination + | SizedCoFun Int -- yes an admissible sized type (the Int specifies the number of the recursive size argument) + +{- +design: + +admCoFun delta tv : IsCoFunType + + endsInCo delta tv (len delta) id + +admEndsInCo delta tv firstVar jobs : IsCoFunType + + traverse tv, gather continutations in jobs, check for CoInd in the end + + if tv = (x:A) -> B + push A on delta + add the following task to jobs: + check A for lower semicontinuity in delta + continue on B + + if tv = Codata^i + run (jobs i) + if they return (), return YesSized Int, otherwise No + + if tv = Codata + return Yes + + otherwise + return No + -} + +-- {- TODO: FINISH THIS!! + +admCoFun :: TVal -> TypeCheck CoFunType +admCoFun tv = do + l <- getLen + admEndsInCo tv l (\ i -> return ()) + +admEndsInCo :: TVal -> Int -> (Int -> TypeCheck ()) -> TypeCheck CoFunType +admEndsInCo tv firstVar jobs = -- traceCheck ("admEndsInCo: " ++ show tv) $ + case tv of + VQuant Pi x dom fv -> do + l <- getLen + let jobs' = (addJob l (typ dom) jobs) + underAbs x dom fv $ \ _ _ bv -> admEndsInCo bv firstVar jobs' +{- + new' x dom $ do + bv <- whnf' b + admEndsInCo bv firstVar jobs' +-} + +{- + -- if not applied, it cannot be a sized type + VDef n -> do + sig <- gets signature + case (lookupSig n sig) of + DataSig { isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $ + return CoFun + _ -> throwErrorMsg $ "type of cofun does not end in coinductive type" +-} + + VApp (VDef (DefId DatK n)) vl -> do + sige <- lookupSymbQ n + case sige of + DataSig { isSized = NotSized, isCo = CoInd } -> -- traceCheck ("found non-sized coinductive target") $ + return CoFun + DataSig { numPars = p, isSized = Sized, isCo = CoInd } | length vl > p -> -- traceCheck ("found sized coinductive target") $ + do + -- p is the number of parameters + -- it is also the index of the size argument + s <- whnfClos $ vl !! p + case s of + VGen i -> do + jobs i + return $ SizedCoFun $ i - firstVar + _ -> throwErrorMsg $ "size argument in result type must be a variable" + _ -> throwErrorMsg $ "type of cofun does not end in coinductive type" + +addJob :: Int -> TVal -> (Int -> TypeCheck ()) + -> (Int -> TypeCheck ()) +addJob l tv jobs recVar = do + -- is the "recursive" size variable actually in scope? + jobs recVar + when (recVar < l) $ szLowerSemiCont recVar tv + +-- -} + + +{- szCheckCoFun OBSOLETE!! + + entry point for admissibility check for corecursive functions + - scans for the first size quantification + - passes on to szCheckIndFunSize + - currently: also continues to look for the next size quantification + - and checks in the end whether the target is a coinductive type + + +-- STALE COMMENT: for a cofun : arguments nocc i and result coinductive in i +szCheckCoFun :: SemCxt -> TVal -> TypeCheck () +szCheckCoFun delta tv = + case tv of + VPi dec x av env b -> do + let (k, delta') = cxtPush dec av delta + bv <- whnf (update env x (VGen k)) b + case av of + VSize -> do szCheckCoFunSize delta' k bv + szCheckCoFun delta' bv + _ -> szCheckCoFun delta' bv + -- result + (VApp (VDef n) vl) -> + do sig <- gets signature + case (lookupSig n sig) of + (DataSig _ _ _ CoInd _) -> + return () + _ -> throwErrorMsg $ "cofun doesn't target coinductive type" + (VDef n) -> + do sig <- gets signature + case (lookupSig n sig) of + (DataSig _ _ _ CoInd _) -> + return () + _ -> throwErrorMsg $ "cofun doesn't target coinductive type" + _ -> throwErrorMsg $ "cofun doesn't target coinductive type" + +szCheckCoFunSize :: SemCxt -> Int -> TVal -> TypeCheck () +szCheckCoFunSize delta i tv = -- traceCheck ("szco " ++ show tv) $ + case tv of + VPi dec x av env b -> do + let (k, delta') = cxtPush dec av delta + bv <- whnf (update env x (VGen k)) b + szLowerSemiCont delta i av + szCheckCoFunSize delta' i bv + -- result must be coinductive + _ -> szCoInductive delta i tv + +-} + +szMono :: Co -> Int -> TVal -> TypeCheck () +szMono co i tv = + case co of + Ind -> szMonotone i tv + CoInd -> szAntitone i tv + +szMonotone :: Int -> TVal -> TypeCheck () +szMonotone i tv = traceCheck ("szMonotone: " -- ++ show delta ++ " |- " + ++ show tv ++ " mon(v" ++ show i ++ ")?") $ + do + let si = VSucc (VGen i) + tv' <- substitute (sgSub i si) tv + leqVal Pos vTopSort tv tv' + +szAntitone :: Int -> TVal -> TypeCheck () +szAntitone i tv = traceCheck ("szAntitone: " -- ++ show delta ++ " |- " + ++ show tv ++ " anti(v" ++ show i ++ ")?") $ + do + let si = VSucc (VGen i) + tv' <- substitute (sgSub i si) tv + leqVal Neg vTopSort tv tv' + +-- checks if tv is a sized inductive type of size i +szInductive :: Int -> TVal -> TypeCheck () +szInductive i tv = szUsed' Ind i tv + +-- checks if tv is a sized coinductive type of size i +szCoInductive :: Int -> TVal -> TypeCheck () +szCoInductive i tv = szUsed' CoInd i tv + +szUsed' :: Co -> Int -> TVal -> TypeCheck () +szUsed' co i tv = + case tv of + (VApp (VDef (DefId DatK n)) vl) -> + do sige <- lookupSymbQ n + case sige of + DataSig { numPars = p, isSized = Sized, isCo = co' } | co == co' && length vl > p -> + -- p is the number of parameters + -- it is also the index of the size argument + do s <- whnfClos $ vl !! p + case s of + VGen i' | i == i' -> return () + _ -> throwErrorMsg $ "expected size variable" + _ -> throwErrorMsg $ "expected (co)inductive sized type" + _ -> throwErrorMsg $ "expected (co)inductive sized type" diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/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 +import Control.Monad.Writer (Writer, runWriter, All, getAll) + +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Debug.Trace + +import Text.PrettyPrint as PP + +(+?+) :: String -> String -> String +(+?+) xs "[]" = [] +(+?+) xs ys = xs ++ ys + +implies :: Bool -> Bool -> Bool +implies a b = if a then b else True + +class Pretty a where + pretty :: a -> Doc + prettyPrec :: Int -> a -> Doc + + pretty = prettyPrec 0 + prettyPrec = const pretty + +instance Pretty Doc where + pretty = id + +angleBrackets :: Doc -> Doc +angleBrackets d = text "<" <+> d <+> text ">" + +-- | Apply when condition is @True@. +fwhen :: Bool -> (a -> a) -> a -> a +fwhen True f a = f a +fwhen False f a = a + +parensIf :: Bool -> Doc -> Doc +parensIf b = fwhen b PP.parens + +hsepBy :: Doc -> [Doc] -> Doc +hsepBy sep [] = empty +hsepBy sep [d] = d +hsepBy sep (d:ds) = d <> sep <> hsepBy sep ds + +pwords :: String -> [Doc] +pwords = map text . words + +fwords :: String -> Doc +fwords = fsep . pwords + +fromAllWriter :: Writer All a -> (Bool, a) +fromAllWriter m = let (a, w) = runWriter m + in (getAll w, a) + +traceM :: (Monad m) => String -> m () +traceM msg = trace msg $ return () + +infixr 9 <.> + +-- | Composition: pure function after monadic function. +(<.>) :: Functor m => (b -> c) -> (a -> m b) -> a -> m c +(f <.> g) a = f <$> g a + +whenM :: Monad m => m Bool -> m () -> m () +whenM mb k = mb >>= (`when` k) + +unlessM :: Monad m => m Bool -> m () -> m () +unlessM mb k = mb >>= (`unless` k) + +whenJustM :: (Monad m) => m (Maybe a) -> (a -> m ()) -> m () +whenJustM mm k = mm >>= (`whenJust` k) + +whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m () +whenJust (Just a) k = k a +whenJust Nothing k = return () + +whenNothing :: (Monad m) => Maybe a -> m () -> m () +whenNothing Nothing m = m +whenNothing Just{} m = return () + +ifNothingM :: (Monad m) => m (Maybe a) -> m b -> (a -> m b) -> m b +ifNothingM mma mb f = maybe mb f =<< mma + +ifJustM :: (Monad m) => m (Maybe a) -> (a -> m b) -> m b -> m b +ifJustM mma f mb = maybe mb f =<< mma + +mapMapM :: (Monad m, Ord k) => (a -> m b) -> Map k a -> m (Map k b) +mapMapM f = Map.foldrWithKey step (return $ Map.empty) + where step k a m = do a' <- f a + m' <- m + return $ Map.insert k a' m' + +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM c d e = do { b <- c ; if b then d else e } + +{- Control.Monad.IfElse +whenM :: Monad m => m Bool -> m () -> m () +whenM c d = do { b <- c; if b then d else return () } + +unlessM :: Monad m => m Bool -> m () -> m () +unlessM c e = do { b <- c; if b then return () else e } +-} + +andLazy :: Monad m => m Bool -> m Bool -> m Bool +andLazy ma mb = ifM ma mb $ return False + +andM :: Monad m => [m Bool] -> m Bool +andM [] = return True +andM (m:ms) = m `andLazy` andM ms + +findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) +findM p [] = return Nothing +findM p (x : xs) = do b <- p x + if b then return (Just x) else findM p xs + +-- | Binary version of @=<<@. +(==<<) :: Monad m => (a -> b -> m c) -> (m a, m b) -> m c +f ==<< (ma, mb) = do { a <- ma; f a =<< mb } + +parens :: String -> String +parens s = "(" ++ s ++ ")" + +brackets :: String -> String +brackets s = "[" ++ s ++ "]" + +bracketsIf :: Bool -> String -> String +bracketsIf False s = s +bracketsIf True s = "[" ++ s ++ "]" + +separate :: String -> String -> String -> String +separate sep "" y = y +separate sep x "" = x +separate sep x y = x ++ sep ++ y + +showList :: String -> (a -> String) -> [a] -> String +showList sep f [] = "" +showList sep f [e] = f e +showList sep f (e:es) = f e ++ sep ++ showList sep f es +-- OR: showList sep f es = foldl separate "" $ map f es + +hasDuplicate :: (Eq a) => [a] -> Bool +hasDuplicate [] = False +hasDuplicate (x : xs) = x `elem` xs || hasDuplicate xs + +compressMaybes :: [Maybe a] -> [a] +compressMaybes = concat . map (maybe [] (\ a -> [a])) + +mapFst :: (a -> c) -> (a,d) -> (c,d) +mapFst f (a,b) = (f a, b) + +mapSnd :: (b -> d) -> (a,b) -> (a,d) +mapSnd f (a,b) = (a, f b) + +mapPair :: (a -> c) -> (b -> d) -> (a,b) -> (c,d) +mapPair f g (a,b) = (f a, g b) + +zipPair :: (a -> b -> c) -> (d -> e -> f) -> (a,d) -> (b,e) -> (c,f) +zipPair f g (a,d) (b,e) = (f a b, g d e) + +headMaybe :: [a] -> Maybe a +headMaybe [] = Nothing +headMaybe (a:as) = Just a + +firstJust :: [Maybe a] -> Maybe a +firstJust = headMaybe . compressMaybes + +firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a) +firstJustM [] = return Nothing +firstJustM (mm : mms) = do + m <- mm + case m of + Nothing -> firstJustM mms + Just{} -> return m + +mapOver :: (Functor f) => f a -> (a -> b) -> f b +mapOver = flip fmap + +for = mapOver + +mapAssoc :: (a -> b) -> [(n,a)] -> [(n,b)] +mapAssoc f = map (\ (n, a) -> (n, f a)) + +mapAssocM :: (Applicative m, Monad m) => (a -> m b) -> [(n,a)] -> m [(n,b)] +mapAssocM f = mapM (\ (n, a) -> (n,) <$> f a) + +compAssoc :: Eq b => [(a,b)] -> [(b,c)] -> [(a,c)] +compAssoc xs ys = [ (a,c) | (a,b) <- xs, (b',c) <- ys, b == b' ] + +-- * Lists and stacks of lists + +class Push a b where + push :: a -> b -> b + +instance Push a [a] where + push = (:) + +instance Push a [[a]] where + push a (b:bs) = (a : b) : bs + +-- TOO HARD for ghc: +-- instance Push a b => Push a [b] where +-- push a (b:bs) = push a b : bs + +class Retrieve a b c | b -> c where + retrieve :: Eq a => a -> b -> Maybe c + +instance Retrieve a [(a,b)] b where + retrieve = lookup + +instance Retrieve a [[(a,b)]] b where + retrieve a = retrieve a . concat + +-- instance Retrieve a b c => Retrieve a [b] c where +-- retrieve a = firstJust . map (retrieve a) + +{- +class ListLike a where + length :: a -> Int + null :: a -> Bool + nil :: a +-} + +class Size a where + size :: a -> Int + +instance Size [a] where + size = length + +class Null a where + null :: a -> Bool + +instance Null [a] where + null = List.null diff --git a/src/Value.hs b/src/Value.hs new file mode 100644 --- /dev/null +++ b/src/Value.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} + +module Value where + +import Prelude hiding (null) + +import Control.Applicative + +import qualified Data.List as List +import Data.Set (Set) +import qualified Data.Set as Set +import Debug.Trace + +import Abstract +import Polarity +import Util +import TraceError -- orM + +-- call-by-value +-- cofuns are not forced + +data Val + -- sizes + = VInfty + | VZero + | VSucc Val + | VMax [Val] + | VPlus [Val] + | VMeta MVar Env Int -- X rho + n (n-fold successor of X rho) + -- types + | VSort (Sort Val) + | VMeasured (Measure Val) Val -- mu -> A (only in checkPattern) + | VGuard (Bound Val) Val -- mu A + | VBelow LtLe Val -- domain in bounded size quant. + | VQuant + { vqPiSig :: PiSigma + , vqName :: Name + , vqDom :: Domain + , vqFun :: FVal + } + | VSing Val TVal -- Singleton type (TVal not Pi) + -- functions + | VLam Name Env Expr + | VAbs Name Int Val Valuation -- abstract free variable + | VConst Val -- constant function + | VUp Val TVal -- delayed eta expansion; TVal is a Pi + -- values + | VRecord RecInfo EnvMap -- a record value / fully applied constructor + | VPair Val Val -- eager pair + -- neutrals + | VGen Int -- free variable (de Bruijn level) + | VDef DefId -- co(data/constructor/fun) + -- VDef occurs only inside a VApp! + | VCase Val TVal Env [Clause] + | VApp Val [Clos] + -- closures + | VProj PrePost Name -- a projection as an argument to a neutral + | VClos Env Expr -- closure for cbn evaluation + -- don't care + | VIrr -- erased hypothetical inhabitant of empty type + deriving (Eq,Ord) + +-- | Makes constant function if name is empty. +vLam :: Name -> Env -> Expr -> FVal +vLam x env e + | emptyName x = VConst $ VClos env e + | otherwise = VLam x env e + +-- | Is a value a function? May become more @True@ after forcing the @VUp@. +isFun :: Val -> Bool +isFun VLam{} = True +isFun VAbs{} = True +isFun VConst{} = True +isFun (VUp _ VQuant{ vqPiSig = Pi }) = True +isFun v = False + +absName :: FVal -> Name +absName fv = + case fv of + VLam x _ _ -> x + VAbs x _ _ _ -> x + VUp _ (VQuant Pi x _ _) -> x + _ -> noName + +type FVal = Val +type TVal = Val -- type value +type Clos = Val +type Domain = Dom TVal + +-- | Valuation of free variables. +newtype Valuation = Valuation { valuation :: [(Int,Val)] } + deriving (Eq,Ord) + +emptyVal = Valuation [] +sgVal i v = Valuation [(i,v)] + +valuateGen :: Int -> Valuation -> Val +valuateGen i valu = maybe (VGen i) id $ lookup i $ valuation valu + +type TeleVal = [TBinding Val] + +data Environ a = Environ + { envMap :: [(Name,a)] -- the actual map from names to values + , envBound :: Maybe (Measure Val) -- optionally the current termination measure + } + deriving (Eq,Ord,Show) + +type EnvMap = [(Name,Val)] +type Env = Environ Val + +{- +data MeasVal = MeasVal [Val] -- lexicographic termination measure + deriving (Eq,Ord,Show) +-} + +-- smart constructors ------------------------------------------------ + +-- | The value representing type Size. +vSize :: Val +vSize = VBelow Le VInfty -- 2012-01-28 non-termination bug I have not found +-- vSize = VSort $ SortC Size + +vFinSize = VBelow Lt VInfty + +-- | Ensure we construct the correct value representing Size. +vSort :: Sort Val -> Val +vSort (SortC Size) = vSize +vSort s = VSort s + +isVSize :: Val -> Bool +isVSize (VSort (SortC Size)) = True +isVSize (VBelow Le VInfty) = True +isVSize _ = False + +vTSize = VSort $ SortC TSize + +vTopSort :: Val +vTopSort = VSort $ Set VInfty + +mkClos :: Env -> Expr -> Val +mkClos rho Infty = VInfty +mkClos rho Zero = VZero +-- mkClos rho (Succ e) = VSucc (mkClos rho e) -- violates an invariant!! succeed/crazys +mkClos rho (Below ltle e) = VBelow ltle (mkClos rho e) +mkClos rho (Proj fx n) = VProj fx n +mkClos rho (Var x) = lookupPure rho x +mkClos rho (Ann e) = mkClos rho $ unTag e +mkClos rho e = VClos rho e + -- Problem with MetaVars: freeVars of a meta var is unknown in this repr.! + -- VClos (rho { envMap = filterEnv (freeVars e) (envMap rho)}) e + +filterEnv :: Set Name -> EnvMap -> EnvMap +filterEnv ns [] = [] +filterEnv ns ((x,v) : rho) = + if Set.member x ns then (x,v) : filterEnv (Set.delete x ns) rho + else filterEnv ns rho + +vDef id = VDef id `VApp` [] +vCon co n = vDef $ DefId (ConK co) n +-- vCon co n = vDef $ DefId (ConK (coToConK co)) n +vFun n = vDef $ DefId FunK $ QName n +vDat n = vDef $ DefId DatK n + +{- POSSIBLY BREAKS INVARIANT! +vApp :: Val -> [Val] -> Val +vApp f [] = f +vApp f vs = VApp f vs +-} + +vAbs :: Name -> Int -> Val -> FVal +vAbs x i v = VAbs x i v emptyVal + +arrow , prod :: TVal -> TVal -> TVal +arrow = quant Pi +prod = quant Sigma + +quant piSig a b = VQuant piSig x (defaultDomain a) (VConst b) + where x = fresh "" +-- quant piSig a b = VQuant piSig x (defaultDomain a) (Environ [(bla,b)] Nothing) (Var bla) +-- where x = fresh "" +-- bla = fresh "#codom" + + +-- * Sizes ------------------------------------------------------------ + +-- Sizes form a commutative semiring with multiplication (Plus) and +-- idempotent addition (Max) +-- +-- Wellformed size values are polynomials, i.e., sums (Max) of products (Plus). +-- A monomial m takes one of the forms (k stands for a variable: VGen or VMeta) +-- 0. VSucc^* VZero +-- 1. VSucc^* k +-- 2. VSucc^* (VPlus [k1,...,kn]) where n>=2 +-- A polynomial takes one of the forms +-- 0. VInfty +-- 1. m +-- 2. VMax ms where length ms >= 2 and each mi different +{- OLD +-- * VSucc^* VGen +-- * VMax vs where each v_i = VSucc^* (VGen k_i) and all k_i different +-- and vs has length >= 2 +-} +-- +-- the smart constructors construct wellformed size values using the laws +-- $ # = # Infty +-- max # k = # +-- $ (max i j) = max ($ i) ($ j) $ distributes over max +-- max (max i j) k = max i j k Assoc-Commut of max +-- max i i = i Idempotency of max +succSize :: Val -> Val +succSize v = case v of + VInfty -> VInfty + VMax vs -> maxSize $ map succSize vs + VMeta i rho n -> VMeta i rho (n + 1) -- TODO: integrate + and mvar + _ -> VSucc v +vSucc = succSize + +-- "multiplication" of sizes +plusSize :: Val -> Val -> Val +plusSize VZero v = v +plusSize v VZero = v +plusSize VInfty v = VInfty +plusSize v VInfty = VInfty +plusSize (VMax vs) v = maxSize $ map (plusSize v) vs +plusSize v (VMax vs) = maxSize $ map (plusSize v) vs +plusSize (VSucc v) v' = succSize $ plusSize v v' +plusSize v' (VSucc v) = succSize $ plusSize v v' +plusSize (VPlus vs) (VPlus vs') = VPlus $ List.sort (vs ++ vs') -- every summand is a var! -- TODO: more efficient sorting! +plusSize (VPlus vs) v = VPlus $ List.insert v vs +plusSize v (VPlus vs) = VPlus $ List.insert v vs +plusSize v v' = VPlus $ List.sort [v,v'] + +plusSizes :: [Val] -> Val +plusSizes [] = VZero +plusSizes [v] = v +plusSizes (v:vs) = v `plusSize` (plusSizes vs) + +-- maxSize vs = VInfty if any v_i=Infty +-- = VMax (sort (nub (flatten vs)) else +-- precondition vs + +maxSize :: [Val] -> Val +maxSize vs = case Set.toList . Set.fromList <$> flatten vs of + Nothing -> VInfty + Just [] -> VZero + Just [v] -> v + Just vs' -> VMax vs' + where flatten (VZero:vs) = flatten vs + flatten (VInfty:_) = Nothing + flatten (VMax vs:vs') = flatten vs' >>= return . (vs++) + flatten (v:vs) = flatten vs >>= return . (v:) + flatten [] = return [] + +{- +maxSize :: [Val] -> Val +maxSize vs = case flatten [] vs of + [] -> VInfty + [v] -> v + vs' -> VMax vs' + where flatten acc (VInfty:_) = [] + flatten acc (VMax vs:vs') = flatten (vs ++ acc) vs' + flatten acc (v:vs) = flatten (v:acc) vs + flatten acc [] = Set.toList $ Set.fromList acc -- sort, nub +-} + +-- * destructors ------------------------------------------------------- + +vSortToSort :: Sort Val -> Sort Expr +vSortToSort (SortC c) = SortC c +vSortToSort (Set VInfty) = Set Infty + +predSize :: Val -> Maybe Val +predSize VInfty = Just VInfty +predSize (VSucc v) = Just v +predSize (VMax vs) = do vs' <- mapM predSize vs + return $ maxSize vs' +predSize (VMeta v rho n) | n > 0 = return $ VMeta v rho (n-1) +predSize _ = Nothing -- variable or zero or sum + +instance HasPred Val where + predecessor VInfty = Nothing -- for printing bounds + predecessor v = predSize v + +isFunType :: TVal -> Bool +isFunType VQuant{ vqPiSig = Pi } = True +isFunType _ = False + +isDataType :: TVal -> Bool +isDataType (VApp (VDef (DefId DatK _)) _) = True +isDataType (VSing v tv) = isDataType tv +isDataType _ = False + +-- * ugly printing ----------------------------------------------------- + +instance Show (Sort Val) where + show (SortC c) = show c + show (Set VZero) = "Set" + show (CoSet VInfty) = "Set" + show (Set v) = parens $ ("Set " ++ show v) + show (CoSet v) = parens $ ("CoSet " ++ show v) + +instance Show Val where + show v | isVSize v = "Size" + show (VSort s) = show s + show VInfty = "#" + show VZero = "0" + show (VSucc v) = "($ " ++ show v ++ ")" + show (VMax vl) = "(max " ++ showVals vl ++ ")" + show (VPlus (v:vl)) = parens $ foldr (\ v s -> show v ++ " + " ++ s) (show v) vl + show (VApp v []) = show v + show (VApp v vl) = "(" ++ show v ++ " " ++ showVals vl ++ ")" + show (VDef id) = show id + show (VProj Pre id) = show id + show (VProj Post id) = "." ++ show id + show (VPair v1 v2) = "(" ++ show v1 ++ ", " ++ show v2 ++ ")" + show (VGen k) = "v" ++ show k + show (VMeta k rho 0) = "?" ++ show k ++ showEnv rho + show (VMeta k rho 1) = "$?" ++ show k ++ showEnv rho + show (VMeta k rho n) = "(?" ++ show k ++ showEnv rho ++ " + " ++ show n ++")" + show (VRecord ri env) = show ri ++ "{" ++ Util.showList "; " (\ (n, v) -> show n ++ " = " ++ show v) env ++ "}" + show (VCase v vt env cs) = "case " ++ show v ++ " : " ++ show vt ++ " { " ++ showCases cs ++ " } " ++ showEnv env + show (VClos (Environ [] Nothing) e) = showsPrec precAppR e "" + show (VClos env e) = "{" ++ show e ++ " " ++ showEnv env ++ "}" + show (VSing v vt) = "<" ++ show v ++ " : " ++ show vt ++ ">" + show VIrr = "." + show (VMeasured mu tv) = parens $ show mu ++ " -> " ++ show tv + show (VGuard beta tv) = parens $ show beta ++ " -> " ++ show tv + show (VBelow ltle v) = show ltle ++ " " ++ show v + + show (VQuant pisig x (Domain (VBelow ltle v) ki dec) bv) + | (ltle,v) /= (Le,VInfty) = + parens $ (\ p -> if p==defaultPol then "" else show p) (polarity dec) ++ + (if erased dec then brackets binding else parens binding) + ++ " " ++ show pisig ++ " " ++ showSkipLambda bv + where binding = show x ++ " " ++ show ltle ++ " " ++ show v + + show (VQuant pisig x (Domain av ki dec) bv) = + parens $ (\ p -> if p==defaultPol then "" else show p) (polarity dec) ++ + (if erased dec then brackets binding + else if emptyName x then s1 else parens binding) + ++ " " ++ show pisig ++ " " ++ showSkipLambda bv + where s1 = s2 ++ s0 + s2 = show av + s3 = show ki + s0 = if ki == defaultKind || s2 == s3 then "" else "::" ++ s3 + binding = if emptyName x then s1 else show x ++ " : " ++ s1 + + show (VLam x env e) = "(\\" ++ show x ++ " -> " ++ show e ++ showEnv env ++ ")" + show (VConst v) = "(\\ _ -> " ++ show v ++ ")" + show (VAbs x i v valu) = "(\\" ++ show x ++ "@" ++ show i ++ show v ++ showValuation valu ++ ")" + show (VUp v vt) = "(" ++ show v ++ " Up " ++ show vt ++ ")" + +showSkipLambda v = + case v of + (VLam x env e) -> show e ++ showEnv env + (VConst v) -> show v + (VAbs x i v valu) -> show v ++ showValuation valu + v -> show v + +showVals :: [Val] -> String +showVals [] = "" +showVals (v:vl) = show v ++ (if null vl then "" else " " ++ showVals vl) + +-- environment --------------------------------------------------- + +emptyEnv :: Environ a +emptyEnv = Environ [] Nothing + +appendEnv :: Environ a -> Environ a -> Environ a +appendEnv (Environ rho mmeas) (Environ rho' mmeas') = + Environ (rho ++ rho') (orM mmeas mmeas') + +-- | enviroment extension / update +update :: Environ a -> Name -> a -> Environ a +update env n v | emptyName n = env + | otherwise = env { envMap = (n,v) : envMap env } + +lookupPure :: Show a => Environ a -> Name -> a +lookupPure rho x = + case lookup x (envMap rho) of + Just v -> v + Nothing -> error $ "lookupPure: unbound identifier " ++ show x ++ " in environment " ++ show rho + +lookupEnv :: Monad m => Environ a -> Name -> m a +lookupEnv rho x = + case lookup x (envMap rho) of + Just v -> return $ v + Nothing -> fail $ "lookupEnv: unbound identifier " ++ show x -- ++ " in environment " ++ show rho +{- +lookupEnv :: Monad m => Environ a -> Name -> m a +lookupEnv [] n = fail $ "lookupEnv: identifier " ++ show n ++ " not bound" +lookupEnv ((x,v):xs) n = if x == n then return v + else lookupEnv xs n +-} + +showValuation :: Valuation -> String +showValuation (Valuation []) = "" +showValuation (Valuation tau) = "{" ++ Util.showList ", " (\(i,v) -> show i ++ " = " ++ show v) tau ++ "}" + +showEnv :: Environ Val -> String +showEnv (Environ [] Nothing) = "" +showEnv (Environ rho Nothing) = "{" ++ showEnv' rho ++ "}" +showEnv (Environ [] (Just mu)) = "{ measure=" ++ show mu ++ " }" +showEnv (Environ rho (Just mu)) = "{" ++ showEnv' rho ++ " | measure=" ++ show mu ++ " }" + +showEnv' :: EnvMap -> String +showEnv' = Util.showList ", " (\ (n,v) -> show n ++ " = " ++ show v) diff --git a/src/Value.hs-boot b/src/Value.hs-boot new file mode 100644 --- /dev/null +++ b/src/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/src/Warshall.hs b/src/Warshall.hs new file mode 100644 --- /dev/null +++ b/src/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/test/fail/Makefile b/test/fail/Makefile --- a/test/fail/Makefile +++ b/test/fail/Makefile @@ -14,7 +14,7 @@ # an error. Then one has to verify the new error message is actually the # intended one (manually), and remove the .err file. -mugda=../../Main +mugda=../../src/Main # Enable read -n SHELL=bash @@ -29,7 +29,7 @@ default : all all : $(allstems) -debug : +debug : @echo $(allagda) # No error recorded @@ -91,7 +91,7 @@ # RETARDED!!!!!!! # echo rm -f $*.tmp; echo rm -f $*.tmp.2; \ -# false; +# false; # Clean diff --git a/test/succeed/Makefile b/test/succeed/Makefile --- a/test/succeed/Makefile +++ b/test/succeed/Makefile @@ -1,14 +1,14 @@ -# MiniAgda +# MiniAgda # Makefile for successful tests # Authors: Andreas Abel, Ulf Norell # Created: 2004-12-03, 2008-09-03 -mugda = ../../Main +mugda = ../../src/Main # Getting all miniagda files allagda=$(patsubst %.ma,%,$(shell find . -name "*.ma")) -all : $(allagda) +all : $(allagda) $(allagda) : % : %.ma @echo "----------------------------------------------------------------------"