From c5fd5651940c7d42e497ce6ed709fda7773a48b6 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sun, 13 Jan 2019 17:50:37 +0900 Subject: [PATCH 01/95] Split constructors of DefinitionS to individual data types --- frege/compiler/common/Desugar.fr | 29 +- frege/compiler/grammar/Frege.fr | 9141 +++++++++++---------- frege/compiler/grammar/Frege.y | 138 +- frege/compiler/passes/Enter.fr | 110 +- frege/compiler/passes/Fields.fr | 31 +- frege/compiler/passes/Fix.fr | 94 +- frege/compiler/passes/Imp.fr | 12 +- frege/compiler/passes/Instances.fr | 39 +- frege/compiler/passes/Transdef.fr | 120 +- frege/compiler/passes/TypeAlias.fr | 26 +- frege/compiler/types/SourceDefinitions.fr | 121 +- frege/tools/Splitter.fr | 9 +- 12 files changed, 5075 insertions(+), 4795 deletions(-) diff --git a/frege/compiler/common/Desugar.fr b/frege/compiler/common/Desugar.fr index 7d4755b3..4b560f52 100644 --- a/frege/compiler/common/Desugar.fr +++ b/frege/compiler/common/Desugar.fr @@ -81,7 +81,7 @@ type Def = DefinitionS type Exp = ExprS type Pat = ExprS type Item = Token -type Qual = Either (Maybe Pat, Exp) [Def] +type Qual = Either (Maybe Pat, Exp) [LetMemberS] type Guard = (Position, [Qual], Exp) type SigTau = Either SigmaS TauS @@ -160,8 +160,20 @@ opSname t = case t.qual of {-- change the visibility of a definition -} -updVis :: Visibility -> DefinitionS -> DefinitionS -updVis v d = d.{vis = v} +updVis :: Visibility -> DefinitionS -> DefinitionS +updVis v (DefinitionS.Imp _) = error "ImpDcl doesn't have a visibility" +updVis v (DefinitionS.Fix _) = error "FixDcl doesn't have a visibility" +updVis v (DefinitionS.Doc _) = error "DocDcl doesn't have a visibility" +updVis v (DefinitionS.Typ d) = DefinitionS.Typ $ d.{vis = v} +updVis v (DefinitionS.Cla d) = DefinitionS.Cla $ d.{vis = v} +updVis v (DefinitionS.Ins d) = DefinitionS.Ins $ d.{vis = v} +updVis v (DefinitionS.Drv d) = DefinitionS.Drv $ d.{vis = v} +updVis v (DefinitionS.Ann d) = DefinitionS.Ann $ d.{vis = v} +updVis v (DefinitionS.Nat d) = DefinitionS.Nat $ d.{vis = v} +updVis v (DefinitionS.Fun d) = DefinitionS.Fun $ d.{vis = v} +updVis v (DefinitionS.Dat d) = DefinitionS.Dat $ d.{vis = v} +updVis v (DefinitionS.Jav d) = DefinitionS.Jav $ d.{vis = v} +updVis v (DefinitionS.Mod d) = error "ModDcl doesn't have a visibility" {-- set the visibility of a constructor to 'Private' @@ -172,7 +184,7 @@ updCtr dc = dc.{vis = Private} {-- create an annotation -} -annotation :: SigmaS -> Token -> Def +annotation :: SigmaS -> Token -> AnnDcl annotation sig it = AnnDcl { pos=yyline it, vis=Public, name=it.value, typ=sig, doc=Nothing} -- exprToPat :: Exp -> YYM Global Pat @@ -321,13 +333,15 @@ funhead ex = do {-- - * construct a function definition as list + * construct a function definition -} -fundef lhs pats expr = [FunDcl {vis=Public, lhs, pats, expr, positions=[], doc=Nothing}]; +fundef :: ExprS -> [ExprS] -> ExprS -> FunDcl +fundef lhs pats expr = FunDcl {vis=Public, lhs, pats, expr, positions=[], doc=Nothing} {-- * construct a function with guards -} +fungds :: ExprS -> [ExprS] -> [Guard] -> FunDcl fungds lhs pats gds = let expr = gdsexpr gds -- (gdln,_,_) = head gds @@ -424,6 +438,7 @@ refutable _ = true * > TQ [e | ] L * > = e : L -} +listComprehension :: Position -> ExprS -> [Qual] -> ExprS -> StG ExprS listComprehension pos e [] l2 = YYM.pure (cons `nApp` e `nApp` l2) where f = Position.first pos @@ -469,7 +484,7 @@ listComprehension pos e (q:qs) l2 = case q of calts = if refutable pat then [calt2, calt1, calt3] else [calt2, calt1] ecas = Case CNormal usvar calts hdef = FunDcl {vis = Private, lhs=hvar, pats=[uspat], expr=ecas, positions = [], doc = Nothing} - YYM.pure (Let [hdef] (App hvar (App tlvar xs))) + YYM.pure (Let [LetMemberS.Fun hdef] (App hvar (App tlvar xs))) where rest = listComprehension pos e qs l2 diff --git a/frege/compiler/grammar/Frege.fr b/frege/compiler/grammar/Frege.fr index e92aadd7..86761d2e 100644 --- a/frege/compiler/grammar/Frege.fr +++ b/frege/compiler/grammar/Frege.fr @@ -108,14 +108,14 @@ data YYsi res tok = | YYNTalias Token | YYNTannoitem Token | YYNTannoitems [Token] - | YYNTannotation [Def] + | YYNTannotation [AnnDcl] | YYNTapats [Exp] | YYNTappex Exp | YYNTbinex Exp | YYNTcalt CAltS | YYNTcalts [CAltS] | YYNTccontext [ContextS] - | YYNTclassdef Def + | YYNTclassdef ClaDcl | YYNTcommata Int | YYNTconfld [ConField SName] | YYNTconflds [ConField SName] @@ -123,14 +123,16 @@ data YYsi res tok = | YYNTcontypes [ConField SName] | YYNTdalt DConS | YYNTdalts [DConS] - | YYNTdatadef Def - | YYNTdatainit Def + | YYNTdatadef DatDcl + | YYNTdatainit DatDcl + | YYNTdatajavadef JavDcl + | YYNTdatajavainit JavDcl | YYNTdefinition [Def] | YYNTdefinitions [Def] - | YYNTderivedef Def + | YYNTderivedef DrvDcl | YYNTdocs String | YYNTdocsO (Maybe String) - | YYNTdocumentation Def + | YYNTdocumentation DocDcl | YYNTdodefs [Qual] | YYNTdplocaldef [Def] | YYNTdvars [TauS] @@ -141,11 +143,11 @@ data YYsi res tok = | YYNTfield (String, Exp) | YYNTfields [(String, Exp)] | YYNTfitem Token - | YYNTfixity Def + | YYNTfixity FixDcl | YYNTfldid (SigmaS -> ConField SName) | YYNTfldids [SigmaS -> ConField SName] | YYNTforall SigmaS - | YYNTfundef [Def] + | YYNTfundef FunDcl | YYNTfunhead (Exp, [Pat]) | YYNTgargs [TauS] | YYNTgetfield (Token, Bool,Exp) @@ -155,15 +157,15 @@ data YYsi res tok = | YYNTguard Guard | YYNTguards [Guard] | YYNTicontext [ContextS] - | YYNTimport Def + | YYNTimport ImpDcl | YYNTimportitem ImportItem | YYNTimportliste ImportList | YYNTimportspec ImportItem | YYNTimportspecs [ImportItem] - | YYNTimpurenativedef Def - | YYNTinfix Def - | YYNTinstdef Def - | YYNTinsthead Def + | YYNTimpurenativedef NatDcl + | YYNTinfix FixDcl + | YYNTinstdef InsDcl + | YYNTinsthead InsDcl | YYNTinterfaces [TauS] | YYNTjitem String | YYNTjtoken Token @@ -173,8 +175,8 @@ data YYsi res tok = | YYNTlambdabody Exp | YYNTlcqual Qual | YYNTlcquals [Qual] - | YYNTletdef [Def] - | YYNTletdefs [Def] + | YYNTletdef [LetMemberS] + | YYNTletdefs [LetMemberS] | YYNTliteral Exp | YYNTlocaldef [Def] | YYNTlocaldefs [Def] @@ -184,10 +186,10 @@ data YYsi res tok = | YYNTmethodspec (Token, String, Maybe [TauS]) | YYNTmodule ParseResult | YYNTmoduleclause (String, Position) - | YYNTmoduledefinition Def + | YYNTmoduledefinition ModDcl | YYNTmodulename (String, Position) | YYNTmodulename1 (String, Position) - | YYNTnativedef Def + | YYNTnativedef NatDcl | YYNTnativename String | YYNTnativepur Bool | YYNTnativespec (String, Maybe [TauS]) @@ -231,7 +233,7 @@ data YYsi res tok = | YYNTtopex Exp | YYNTtyname SName | YYNTtypeclause (Maybe TauS) - | YYNTtypedef Def + | YYNTtypedef TypDcl | YYNTtyvar TauS | YYNTunex Exp | YYNTunop Token @@ -241,7 +243,7 @@ data YYsi res tok = | YYNTvisdalt DConS | YYNTvisibledefinition [Def] | YYNTwheredef [Def] - | YYNTwherelet [Def] + | YYNTwherelet [LetMemberS] | YYNTwheretokens [Token] | YYNTword String | YYNTwords [String]; @@ -269,6 +271,8 @@ showsi (YYStart _) = "%start "; showsi (YYNTdalts _) = ""; showsi (YYNTdatadef _) = ""; showsi (YYNTdatainit _) = ""; + showsi (YYNTdatajavadef _) = ""; + showsi (YYNTdatajavainit _) = ""; showsi (YYNTdefinition _) = ""; showsi (YYNTdefinitions _) = ""; showsi (YYNTderivedef _) = ""; @@ -494,14 +498,14 @@ private yyaction8 t = case yychar t of { }; }; private yyaction9 t = case yychar t of { - ';' -> YYAction 104; + ';' -> YYAction 106; _ -> case yytoken t of { - VARID -> YYAction 102; - WHERE -> YYAction 103; + VARID -> YYAction 104; + WHERE -> YYAction 105; _ -> YYAction yyErr; }; }; -private yyaction10 t = YYAction (-169); +private yyaction10 t = YYAction (-170); private yyaction11 t = YYAction (-12); private yyaction12 t = case yytoken t of { VARID -> YYAction 10; @@ -515,15 +519,15 @@ private yyaction12 t = case yytoken t of { PURE -> YYAction 18; _ -> YYAction yyErr; }; -private yyaction13 t = YYAction (-174); -private yyaction14 t = YYAction (-175); -private yyaction15 t = YYAction (-172); -private yyaction16 t = YYAction (-170); -private yyaction17 t = YYAction (-171); -private yyaction18 t = YYAction (-173); +private yyaction13 t = YYAction (-175); +private yyaction14 t = YYAction (-176); +private yyaction15 t = YYAction (-173); +private yyaction16 t = YYAction (-171); +private yyaction17 t = YYAction (-172); +private yyaction18 t = YYAction (-174); private yyaction19 t = YYAction (-15); private yyaction20 t = case yychar t of { - '.' -> YYAction 108; + '.' -> YYAction 110; _ -> YYAction yyErr; }; private yyaction21 t = YYAction (-20); @@ -540,46 +544,46 @@ private yyaction22 t = case yytoken t of { _ -> YYAction yyErr; }; private yyaction23 t = case yychar t of { - '-' -> YYAction (-180); - '.' -> YYAction (-180); - '(' -> YYAction (-180); - ',' -> YYAction (-168); - '|' -> YYAction (-180); - '[' -> YYAction (-180); - '?' -> YYAction (-180); - '!' -> YYAction (-180); - '=' -> YYAction (-180); - '_' -> YYAction (-180); - _ -> case yytoken t of { - VARID -> YYAction (-180); - CONID -> YYAction (-180); - QUALIFIER -> YYAction (-180); - TRUE -> YYAction (-180); - FALSE -> YYAction (-180); - DO -> YYAction (-180); - INTCONST -> YYAction (-180); - STRCONST -> YYAction (-180); - LONGCONST -> YYAction (-180); - FLTCONST -> YYAction (-180); - DBLCONST -> YYAction (-180); - DECCONST -> YYAction (-180); - CHRCONST -> YYAction (-180); - REGEXP -> YYAction (-180); - BIGCONST -> YYAction (-180); - DCOLON -> YYAction (-168); - SOMEOP -> YYAction (-180); - _ -> YYAction yyErr; - }; -}; -private yyaction24 t = YYAction (-183); + '-' -> YYAction (-181); + '.' -> YYAction (-181); + '(' -> YYAction (-181); + ',' -> YYAction (-169); + '|' -> YYAction (-181); + '[' -> YYAction (-181); + '?' -> YYAction (-181); + '!' -> YYAction (-181); + '=' -> YYAction (-181); + '_' -> YYAction (-181); + _ -> case yytoken t of { + VARID -> YYAction (-181); + CONID -> YYAction (-181); + QUALIFIER -> YYAction (-181); + TRUE -> YYAction (-181); + FALSE -> YYAction (-181); + DO -> YYAction (-181); + INTCONST -> YYAction (-181); + STRCONST -> YYAction (-181); + LONGCONST -> YYAction (-181); + FLTCONST -> YYAction (-181); + DBLCONST -> YYAction (-181); + DECCONST -> YYAction (-181); + CHRCONST -> YYAction (-181); + REGEXP -> YYAction (-181); + BIGCONST -> YYAction (-181); + DCOLON -> YYAction (-169); + SOMEOP -> YYAction (-181); + _ -> YYAction yyErr; + }; +}; +private yyaction24 t = YYAction (-184); private yyaction25 t = case yychar t of { '?' -> YYAction 61; '!' -> YYAction 62; - '{' -> YYAction (-408); + '{' -> YYAction (-410); _ -> case yytoken t of { - VARID -> YYAction 110; - CONID -> YYAction 111; - QUALIFIER -> YYAction 112; + VARID -> YYAction 112; + CONID -> YYAction 113; + QUALIFIER -> YYAction 114; _ -> YYAction yyErr; }; }; @@ -597,74 +601,74 @@ private yyaction27 t = case yytoken t of { _ -> YYAction yyErr; }; private yyaction28 t = case yytoken t of { - INTCONST -> YYAction 116; + INTCONST -> YYAction 118; _ -> YYAction yyErr; }; private yyaction29 t = case yytoken t of { - INTCONST -> YYAction 117; + INTCONST -> YYAction 119; _ -> YYAction yyErr; }; private yyaction30 t = case yytoken t of { - INTCONST -> YYAction 118; + INTCONST -> YYAction 120; _ -> YYAction yyErr; }; private yyaction31 t = case yychar t of { - '-' -> YYAction 122; - '(' -> YYAction 123; + '-' -> YYAction 124; + '(' -> YYAction 125; '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 119; - PACKAGE -> YYAction 120; - SOMEOP -> YYAction 121; + VARID -> YYAction 121; + PACKAGE -> YYAction 122; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; private yyaction32 t = case yytoken t of { - CONID -> YYAction 129; + CONID -> YYAction 131; _ -> YYAction yyErr; }; private yyaction33 t = case yytoken t of { - CONID -> YYAction 130; + CONID -> YYAction 132; _ -> YYAction yyErr; }; private yyaction34 t = case yychar t of { - '(' -> YYAction 132; + '(' -> YYAction 134; _ -> case yytoken t of { CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; private yyaction35 t = case yychar t of { - '(' -> YYAction 136; + '(' -> YYAction 138; _ -> case yytoken t of { CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; private yyaction36 t = case yytoken t of { NEWTYPE -> YYAction 32; - DATA -> YYAction 33; + DATA -> YYAction 143; _ -> YYAction yyErr; }; private yyaction37 t = case yytoken t of { - CONID -> YYAction 142; + CONID -> YYAction 145; _ -> YYAction yyErr; }; -private yyaction38 t = YYAction (-347); -private yyaction39 t = YYAction (-348); +private yyaction38 t = YYAction (-349); +private yyaction39 t = YYAction (-350); private yyaction40 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -687,14 +691,14 @@ private yyaction40 t = case yychar t of { }; private yyaction41 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -716,19 +720,19 @@ private yyaction41 t = case yychar t of { }; }; private yyaction42 t = case yychar t of { - '(' -> YYAction 136; + '(' -> YYAction 138; _ -> case yytoken t of { CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; private yyaction43 t = case yychar t of { - '{' -> YYAction 149; + '{' -> YYAction 152; _ -> YYAction yyErr; }; private yyaction44 t = case yychar t of { - '{' -> YYAction 150; + '{' -> YYAction 153; _ -> YYAction yyErr; }; private yyaction45 t = case yychar t of { @@ -743,7 +747,7 @@ private yyaction45 t = case yychar t of { VARID -> YYAction 23; CONID -> YYAction 24; QUALIFIER -> YYAction 25; - NATIVE -> YYAction 151; + NATIVE -> YYAction 154; NEWTYPE -> YYAction 32; DATA -> YYAction 33; CLASS -> YYAction 34; @@ -781,7 +785,7 @@ private yyaction46 t = case yychar t of { VARID -> YYAction 23; CONID -> YYAction 24; QUALIFIER -> YYAction 25; - NATIVE -> YYAction 151; + NATIVE -> YYAction 154; NEWTYPE -> YYAction 32; DATA -> YYAction 33; CLASS -> YYAction 34; @@ -819,7 +823,7 @@ private yyaction47 t = case yychar t of { VARID -> YYAction 23; CONID -> YYAction 24; QUALIFIER -> YYAction 25; - NATIVE -> YYAction 151; + NATIVE -> YYAction 154; NEWTYPE -> YYAction 32; DATA -> YYAction 33; CLASS -> YYAction 34; @@ -846,27 +850,27 @@ private yyaction47 t = case yychar t of { }; }; private yyaction48 t = case yytoken t of { - NATIVE -> YYAction 151; - _ -> YYAction yyErr; - }; -private yyaction49 t = YYAction (-351); -private yyaction50 t = YYAction (-350); -private yyaction51 t = YYAction (-353); -private yyaction52 t = YYAction (-354); -private yyaction53 t = YYAction (-355); -private yyaction54 t = YYAction (-356); -private yyaction55 t = YYAction (-349); -private yyaction56 t = YYAction (-357); -private yyaction57 t = YYAction (-352); + NATIVE -> YYAction 154; + _ -> YYAction yyErr; + }; +private yyaction49 t = YYAction (-353); +private yyaction50 t = YYAction (-352); +private yyaction51 t = YYAction (-355); +private yyaction52 t = YYAction (-356); +private yyaction53 t = YYAction (-357); +private yyaction54 t = YYAction (-358); +private yyaction55 t = YYAction (-351); +private yyaction56 t = YYAction (-359); +private yyaction57 t = YYAction (-354); private yyaction58 t = case yychar t of { - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -888,17 +892,17 @@ private yyaction58 t = case yychar t of { }; }; private yyaction59 t = case yychar t of { - '-' -> YYAction 157; - '(' -> YYAction 144; - ')' -> YYAction 158; - ',' -> YYAction 159; + '-' -> YYAction 160; + '(' -> YYAction 147; + ')' -> YYAction 161; + ',' -> YYAction 162; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -916,21 +920,21 @@ private yyaction59 t = case yychar t of { CHRCONST -> YYAction 55; REGEXP -> YYAction 56; BIGCONST -> YYAction 57; - SOMEOP -> YYAction 121; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; private yyaction60 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; - ']' -> YYAction 165; + ']' -> YYAction 168; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -951,16 +955,16 @@ private yyaction60 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction61 t = YYAction (-192); -private yyaction62 t = YYAction (-191); +private yyaction61 t = YYAction (-193); +private yyaction62 t = YYAction (-192); private yyaction63 t = case yychar t of { - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -978,13 +982,13 @@ private yyaction63 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction64 t = YYAction (-426); +private yyaction64 t = YYAction (-428); private yyaction65 t = case yychar t of { - '}' -> YYAction 170; + '}' -> YYAction 173; _ -> YYAction yyBrace; }; private yyaction66 t = case yychar t of { - ';' -> YYAction 171; + ';' -> YYAction 174; '}' -> YYAction (-26); _ -> YYAction yyBrace; }; @@ -1001,71 +1005,72 @@ private yyaction76 t = YYAction (-117); private yyaction77 t = YYAction (-118); private yyaction78 t = YYAction (-119); private yyaction79 t = YYAction (-120); -private yyaction80 t = YYAction (-124); +private yyaction80 t = YYAction (-121); private yyaction81 t = YYAction (-125); -private yyaction82 t = case yychar t of { - ';' -> YYAction (-126); - '}' -> YYAction (-126); +private yyaction82 t = YYAction (-126); +private yyaction83 t = case yychar t of { + ';' -> YYAction (-127); + '}' -> YYAction (-127); _ -> case yytoken t of { - WHERE -> YYAction 172; + WHERE -> YYAction 175; _ -> YYAction yyBrace; }; }; -private yyaction83 t = YYAction (-203); -private yyaction84 t = YYAction (-424); -private yyaction85 t = case yychar t of { - '{' -> YYAction 174; - '-' -> YYAction (-427); - ';' -> YYAction (-427); - '}' -> YYAction (-427); - '.' -> YYAction (-427); - '(' -> YYAction (-427); - ')' -> YYAction (-427); - ',' -> YYAction (-427); - '|' -> YYAction (-427); - '[' -> YYAction (-427); - ']' -> YYAction (-427); - '?' -> YYAction (-427); - '!' -> YYAction (-427); - '=' -> YYAction (-427); - '\\' -> YYAction (-427); - '_' -> YYAction (-427); - _ -> case yytoken t of { - VARID -> YYAction (-427); - CONID -> YYAction (-427); - QUALIFIER -> YYAction (-427); - WHERE -> YYAction (-427); - TRUE -> YYAction (-427); - FALSE -> YYAction (-427); - THEN -> YYAction (-427); - ELSE -> YYAction (-427); - OF -> YYAction (-427); - DO -> YYAction (-427); - INTCONST -> YYAction (-427); - STRCONST -> YYAction (-427); - LONGCONST -> YYAction (-427); - FLTCONST -> YYAction (-427); - DBLCONST -> YYAction (-427); - DECCONST -> YYAction (-427); - CHRCONST -> YYAction (-427); - REGEXP -> YYAction (-427); - BIGCONST -> YYAction (-427); - ARROW -> YYAction (-427); - DCOLON -> YYAction (-427); - GETS -> YYAction (-427); - DOTDOT -> YYAction (-427); - SOMEOP -> YYAction (-427); +private yyaction84 t = YYAction (-204); +private yyaction85 t = YYAction (-426); +private yyaction86 t = case yychar t of { + '{' -> YYAction 177; + '-' -> YYAction (-429); + ';' -> YYAction (-429); + '}' -> YYAction (-429); + '.' -> YYAction (-429); + '(' -> YYAction (-429); + ')' -> YYAction (-429); + ',' -> YYAction (-429); + '|' -> YYAction (-429); + '[' -> YYAction (-429); + ']' -> YYAction (-429); + '?' -> YYAction (-429); + '!' -> YYAction (-429); + '=' -> YYAction (-429); + '\\' -> YYAction (-429); + '_' -> YYAction (-429); + _ -> case yytoken t of { + VARID -> YYAction (-429); + CONID -> YYAction (-429); + QUALIFIER -> YYAction (-429); + WHERE -> YYAction (-429); + TRUE -> YYAction (-429); + FALSE -> YYAction (-429); + THEN -> YYAction (-429); + ELSE -> YYAction (-429); + OF -> YYAction (-429); + DO -> YYAction (-429); + INTCONST -> YYAction (-429); + STRCONST -> YYAction (-429); + LONGCONST -> YYAction (-429); + FLTCONST -> YYAction (-429); + DBLCONST -> YYAction (-429); + DECCONST -> YYAction (-429); + CHRCONST -> YYAction (-429); + REGEXP -> YYAction (-429); + BIGCONST -> YYAction (-429); + ARROW -> YYAction (-429); + DCOLON -> YYAction (-429); + GETS -> YYAction (-429); + DOTDOT -> YYAction (-429); + SOMEOP -> YYAction (-429); _ -> YYAction yyBrace; }; }; -private yyaction86 t = case yychar t of { - '(' -> YYAction 144; +private yyaction87 t = case yychar t of { + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -1083,67 +1088,75 @@ private yyaction86 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction87 t = case yychar t of { - '-' -> YYAction 177; +private yyaction88 t = case yychar t of { + '-' -> YYAction 180; _ -> case yytoken t of { - VARID -> YYAction 176; - SOMEOP -> YYAction 121; + VARID -> YYAction 179; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction88 t = case yytoken t of { - DCOLON -> YYAction 181; +private yyaction89 t = case yytoken t of { + DCOLON -> YYAction 184; _ -> YYAction yyErr; }; -private yyaction89 t = case yychar t of { - ',' -> YYAction 182; +private yyaction90 t = case yychar t of { + ',' -> YYAction 185; _ -> case yytoken t of { - DCOLON -> YYAction (-207); + DCOLON -> YYAction (-208); _ -> YYAction yyErr; }; }; -private yyaction90 t = YYAction (-210); -private yyaction91 t = case yychar t of { - ';' -> YYAction (-338); - '}' -> YYAction (-338); +private yyaction91 t = YYAction (-211); +private yyaction92 t = case yychar t of { + ';' -> YYAction (-340); + '}' -> YYAction (-340); _ -> case yytoken t of { - WHERE -> YYAction 183; + WHERE -> YYAction 186; _ -> YYAction yyBrace; }; }; -private yyaction92 t = case yychar t of { - '|' -> YYAction 185; - '=' -> YYAction 186; +private yyaction93 t = case yychar t of { + ';' -> YYAction (-340); + '}' -> YYAction (-340); + _ -> case yytoken t of { + WHERE -> YYAction 186; + _ -> YYAction yyBrace; + }; +}; +private yyaction94 t = case yychar t of { + '|' -> YYAction 189; + '=' -> YYAction 190; _ -> YYAction yyErr; }; -private yyaction93 t = case yychar t of { - '-' -> YYAction 190; - '|' -> YYAction (-346); - '=' -> YYAction (-346); +private yyaction95 t = case yychar t of { + '-' -> YYAction 194; + '|' -> YYAction (-348); + '=' -> YYAction (-348); _ -> case yytoken t of { - SOMEOP -> YYAction 189; + SOMEOP -> YYAction 193; _ -> YYAction yyErr; }; }; -private yyaction94 t = YYAction (-425); -private yyaction95 t = YYAction (-400); -private yyaction96 t = YYAction (-396); -private yyaction97 t = case yychar t of { - '(' -> YYAction 144; +private yyaction96 t = YYAction (-427); +private yyaction97 t = YYAction (-402); +private yyaction98 t = YYAction (-398); +private yyaction99 t = case yychar t of { + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '_' -> YYAction 64; - '-' -> YYAction (-401); - ';' -> YYAction (-401); - '}' -> YYAction (-401); - ')' -> YYAction (-401); - ',' -> YYAction (-401); - '|' -> YYAction (-401); - ']' -> YYAction (-401); - '=' -> YYAction (-401); - _ -> case yytoken t of { - VARID -> YYAction 143; + '-' -> YYAction (-403); + ';' -> YYAction (-403); + '}' -> YYAction (-403); + ')' -> YYAction (-403); + ',' -> YYAction (-403); + '|' -> YYAction (-403); + ']' -> YYAction (-403); + '=' -> YYAction (-403); + _ -> case yytoken t of { + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -1158,74 +1171,74 @@ private yyaction97 t = case yychar t of { CHRCONST -> YYAction 55; REGEXP -> YYAction 56; BIGCONST -> YYAction 57; - WHERE -> YYAction (-401); - THEN -> YYAction (-401); - ELSE -> YYAction (-401); - OF -> YYAction (-401); - ARROW -> YYAction (-401); - DCOLON -> YYAction (-401); - GETS -> YYAction (-401); - DOTDOT -> YYAction (-401); - SOMEOP -> YYAction (-401); + WHERE -> YYAction (-403); + THEN -> YYAction (-403); + ELSE -> YYAction (-403); + OF -> YYAction (-403); + ARROW -> YYAction (-403); + DCOLON -> YYAction (-403); + GETS -> YYAction (-403); + DOTDOT -> YYAction (-403); + SOMEOP -> YYAction (-403); _ -> YYAction yyBrace; }; }; -private yyaction98 t = YYAction (-402); -private yyaction99 t = case yychar t of { - '.' -> YYAction 192; - '-' -> YYAction (-404); - ';' -> YYAction (-404); - '}' -> YYAction (-404); - '(' -> YYAction (-404); - ')' -> YYAction (-404); - ',' -> YYAction (-404); - '|' -> YYAction (-404); - '[' -> YYAction (-404); - ']' -> YYAction (-404); - '?' -> YYAction (-404); - '!' -> YYAction (-404); - '=' -> YYAction (-404); - '\\' -> YYAction (-404); - '_' -> YYAction (-404); - _ -> case yytoken t of { - VARID -> YYAction (-404); - CONID -> YYAction (-404); - QUALIFIER -> YYAction (-404); - WHERE -> YYAction (-404); - TRUE -> YYAction (-404); - FALSE -> YYAction (-404); - THEN -> YYAction (-404); - ELSE -> YYAction (-404); - OF -> YYAction (-404); - DO -> YYAction (-404); - INTCONST -> YYAction (-404); - STRCONST -> YYAction (-404); - LONGCONST -> YYAction (-404); - FLTCONST -> YYAction (-404); - DBLCONST -> YYAction (-404); - DECCONST -> YYAction (-404); - CHRCONST -> YYAction (-404); - REGEXP -> YYAction (-404); - BIGCONST -> YYAction (-404); - ARROW -> YYAction (-404); - DCOLON -> YYAction (-404); - GETS -> YYAction (-404); - DOTDOT -> YYAction (-404); - SOMEOP -> YYAction (-404); +private yyaction100 t = YYAction (-404); +private yyaction101 t = case yychar t of { + '.' -> YYAction 196; + '-' -> YYAction (-406); + ';' -> YYAction (-406); + '}' -> YYAction (-406); + '(' -> YYAction (-406); + ')' -> YYAction (-406); + ',' -> YYAction (-406); + '|' -> YYAction (-406); + '[' -> YYAction (-406); + ']' -> YYAction (-406); + '?' -> YYAction (-406); + '!' -> YYAction (-406); + '=' -> YYAction (-406); + '\\' -> YYAction (-406); + '_' -> YYAction (-406); + _ -> case yytoken t of { + VARID -> YYAction (-406); + CONID -> YYAction (-406); + QUALIFIER -> YYAction (-406); + WHERE -> YYAction (-406); + TRUE -> YYAction (-406); + FALSE -> YYAction (-406); + THEN -> YYAction (-406); + ELSE -> YYAction (-406); + OF -> YYAction (-406); + DO -> YYAction (-406); + INTCONST -> YYAction (-406); + STRCONST -> YYAction (-406); + LONGCONST -> YYAction (-406); + FLTCONST -> YYAction (-406); + DBLCONST -> YYAction (-406); + DECCONST -> YYAction (-406); + CHRCONST -> YYAction (-406); + REGEXP -> YYAction (-406); + BIGCONST -> YYAction (-406); + ARROW -> YYAction (-406); + DCOLON -> YYAction (-406); + GETS -> YYAction (-406); + DOTDOT -> YYAction (-406); + SOMEOP -> YYAction (-406); _ -> YYAction yyBrace; }; }; -private yyaction100 t = case yychar t of { - '{' -> YYAction 193; +private yyaction102 t = case yychar t of { + '{' -> YYAction 197; _ -> YYAction yyErr; }; -private yyaction101 t = YYAction (-410); -private yyaction102 t = YYAction (-23); -private yyaction103 t = case yychar t of { - '{' -> YYAction 194; +private yyaction103 t = YYAction (-412); +private yyaction104 t = YYAction (-23); +private yyaction105 t = case yychar t of { + '{' -> YYAction 198; _ -> YYAction yyErr; }; -private yyaction104 t = case yychar t of { +private yyaction106 t = case yychar t of { '-' -> YYAction 58; '(' -> YYAction 59; '[' -> YYAction 60; @@ -1272,19 +1285,19 @@ private yyaction104 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction105 t = case yychar t of { - '(' -> YYAction 196; +private yyaction107 t = case yychar t of { + '(' -> YYAction 200; _ -> YYAction yyErr; }; -private yyaction106 t = case yychar t of { +private yyaction108 t = case yychar t of { '(' -> YYAction (-24); _ -> case yytoken t of { - VARID -> YYAction 102; + VARID -> YYAction 104; _ -> YYAction yyErr; }; }; -private yyaction107 t = YYAction (-14); -private yyaction108 t = case yytoken t of { +private yyaction109 t = YYAction (-14); +private yyaction110 t = case yytoken t of { VARID -> YYAction 10; CONID -> YYAction 11; QUALIFIER -> YYAction 12; @@ -1296,176 +1309,180 @@ private yyaction108 t = case yytoken t of { PURE -> YYAction 18; _ -> YYAction yyErr; }; -private yyaction109 t = YYAction (-21); -private yyaction110 t = YYAction (-184); -private yyaction111 t = YYAction (-182); -private yyaction112 t = case yychar t of { +private yyaction111 t = YYAction (-21); +private yyaction112 t = YYAction (-185); +private yyaction113 t = YYAction (-183); +private yyaction114 t = case yychar t of { '?' -> YYAction 61; '!' -> YYAction 62; - '{' -> YYAction (-409); + '{' -> YYAction (-411); _ -> case yytoken t of { - VARID -> YYAction 110; - CONID -> YYAction 199; + VARID -> YYAction 112; + CONID -> YYAction 203; _ -> YYAction yyErr; }; }; -private yyaction113 t = YYAction (-185); -private yyaction114 t = YYAction (-179); -private yyaction115 t = case yychar t of { - '(' -> YYAction 204; - ';' -> YYAction (-142); - '}' -> YYAction (-142); +private yyaction115 t = YYAction (-186); +private yyaction116 t = YYAction (-180); +private yyaction117 t = case yychar t of { + '(' -> YYAction 208; + ';' -> YYAction (-143); + '}' -> YYAction (-143); _ -> case yytoken t of { - VARID -> YYAction 201; - CONID -> YYAction 202; - PUBLIC -> YYAction 203; + VARID -> YYAction 205; + CONID -> YYAction 206; + PUBLIC -> YYAction 207; _ -> YYAction yyBrace; }; }; -private yyaction116 t = YYAction (-193); -private yyaction117 t = YYAction (-195); private yyaction118 t = YYAction (-194); -private yyaction119 t = YYAction (-168); -private yyaction120 t = case yytoken t of { - TYPE -> YYAction 207; +private yyaction119 t = YYAction (-196); +private yyaction120 t = YYAction (-195); +private yyaction121 t = YYAction (-169); +private yyaction122 t = case yytoken t of { + TYPE -> YYAction 211; WHERE -> YYAction (-41); CLASS -> YYAction (-41); _ -> YYAction yyErr; }; -private yyaction121 t = YYAction (-190); -private yyaction122 t = YYAction (-213); -private yyaction123 t = case yychar t of { - '-' -> YYAction 209; +private yyaction123 t = YYAction (-191); +private yyaction124 t = YYAction (-214); +private yyaction125 t = case yychar t of { + '-' -> YYAction 213; '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - SOMEOP -> YYAction 121; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction124 t = YYAction (-214); -private yyaction125 t = YYAction (-212); -private yyaction126 t = YYAction (-211); -private yyaction127 t = case yychar t of { - '{' -> YYAction 217; +private yyaction126 t = YYAction (-215); +private yyaction127 t = YYAction (-213); +private yyaction128 t = YYAction (-212); +private yyaction129 t = case yychar t of { + '{' -> YYAction 221; '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 212; - CONID -> YYAction 213; - QUALIFIER -> YYAction 214; - PACKAGE -> YYAction 215; - STRCONST -> YYAction 216; - SOMEOP -> YYAction 121; - DCOLON -> YYAction (-221); + VARID -> YYAction 216; + CONID -> YYAction 217; + QUALIFIER -> YYAction 218; + PACKAGE -> YYAction 219; + STRCONST -> YYAction 220; + SOMEOP -> YYAction 123; + DCOLON -> YYAction (-222); _ -> YYAction yyErr; }; }; -private yyaction128 t = case yytoken t of { - DCOLON -> YYAction 224; +private yyaction130 t = case yytoken t of { + DCOLON -> YYAction 228; _ -> YYAction yyErr; }; -private yyaction129 t = case yychar t of { - '(' -> YYAction 226; - '=' -> YYAction 227; +private yyaction131 t = case yychar t of { + '(' -> YYAction 230; + '=' -> YYAction 231; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; _ -> YYAction yyErr; }; }; -private yyaction130 t = case yychar t of { - '(' -> YYAction 226; - '=' -> YYAction 230; +private yyaction132 t = case yychar t of { + '(' -> YYAction 230; + '=' -> YYAction 234; ';' -> YYAction (-293); '}' -> YYAction (-293); _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; WHERE -> YYAction (-293); _ -> YYAction yyBrace; }; }; -private yyaction131 t = case yytoken t of { - CONID -> YYAction 111; - QUALIFIER -> YYAction 232; +private yyaction133 t = case yytoken t of { + CONID -> YYAction 113; + QUALIFIER -> YYAction 236; _ -> YYAction yyErr; }; -private yyaction132 t = case yytoken t of { +private yyaction134 t = case yytoken t of { CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; -private yyaction133 t = case yychar t of { - '(' -> YYAction 226; +private yyaction135 t = case yychar t of { + '(' -> YYAction 230; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; _ -> YYAction yyErr; }; }; -private yyaction134 t = YYAction (-268); -private yyaction135 t = case yychar t of { - ';' -> YYAction (-338); - '}' -> YYAction (-338); +private yyaction136 t = YYAction (-269); +private yyaction137 t = case yychar t of { + ';' -> YYAction (-340); + '}' -> YYAction (-340); _ -> case yytoken t of { - WHERE -> YYAction 183; - EARROW -> YYAction 236; + WHERE -> YYAction 186; + EARROW -> YYAction 240; _ -> YYAction yyBrace; }; }; -private yyaction136 t = case yytoken t of { +private yyaction138 t = case yytoken t of { CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; -private yyaction137 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction139 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; -private yyaction138 t = YYAction (-276); -private yyaction139 t = case yychar t of { - ';' -> YYAction (-279); - '}' -> YYAction (-279); +private yyaction140 t = YYAction (-277); +private yyaction141 t = case yychar t of { + ';' -> YYAction (-280); + '}' -> YYAction (-280); _ -> case yytoken t of { - EARROW -> YYAction 246; - WHERE -> YYAction (-279); + EARROW -> YYAction 250; + WHERE -> YYAction (-280); _ -> YYAction yyBrace; }; }; -private yyaction140 t = case yychar t of { - ';' -> YYAction (-338); - '}' -> YYAction (-338); +private yyaction142 t = case yychar t of { + ';' -> YYAction (-340); + '}' -> YYAction (-340); _ -> case yytoken t of { - WHERE -> YYAction 183; + WHERE -> YYAction 186; _ -> YYAction yyBrace; }; }; -private yyaction141 t = YYAction (-35); -private yyaction142 t = case yychar t of { - '(' -> YYAction 226; - '=' -> YYAction 248; +private yyaction143 t = case yytoken t of { + CONID -> YYAction 252; + _ -> YYAction yyErr; + }; +private yyaction144 t = YYAction (-35); +private yyaction145 t = case yychar t of { + '(' -> YYAction 230; + '=' -> YYAction 253; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; _ -> YYAction yyErr; }; }; -private yyaction143 t = YYAction (-180); -private yyaction144 t = case yychar t of { - '-' -> YYAction 250; - '(' -> YYAction 144; - ')' -> YYAction 158; - ',' -> YYAction 159; +private yyaction146 t = YYAction (-181); +private yyaction147 t = case yychar t of { + '-' -> YYAction 255; + '(' -> YYAction 147; + ')' -> YYAction 161; + ',' -> YYAction 162; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -1483,45 +1500,45 @@ private yyaction144 t = case yychar t of { CHRCONST -> YYAction 55; REGEXP -> YYAction 56; BIGCONST -> YYAction 57; - SOMEOP -> YYAction 121; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction145 t = case yychar t of { - ';' -> YYAction 254; - _ -> case yytoken t of { - THEN -> YYAction 253; - _ -> YYAction yyErr; - }; -}; -private yyaction146 t = case yychar t of { - '-' -> YYAction 190; - ';' -> YYAction (-388); - '}' -> YYAction (-388); - ')' -> YYAction (-388); - ',' -> YYAction (-388); - '|' -> YYAction (-388); - ']' -> YYAction (-388); - '=' -> YYAction (-388); - _ -> case yytoken t of { - DCOLON -> YYAction 256; - SOMEOP -> YYAction 189; - WHERE -> YYAction (-388); - THEN -> YYAction (-388); - ELSE -> YYAction (-388); - OF -> YYAction (-388); - ARROW -> YYAction (-388); - GETS -> YYAction (-388); - DOTDOT -> YYAction (-388); +private yyaction148 t = case yychar t of { + ';' -> YYAction 259; + _ -> case yytoken t of { + THEN -> YYAction 258; + _ -> YYAction yyErr; + }; +}; +private yyaction149 t = case yychar t of { + '-' -> YYAction 194; + ';' -> YYAction (-390); + '}' -> YYAction (-390); + ')' -> YYAction (-390); + ',' -> YYAction (-390); + '|' -> YYAction (-390); + ']' -> YYAction (-390); + '=' -> YYAction (-390); + _ -> case yytoken t of { + DCOLON -> YYAction 261; + SOMEOP -> YYAction 193; + WHERE -> YYAction (-390); + THEN -> YYAction (-390); + ELSE -> YYAction (-390); + OF -> YYAction (-390); + ARROW -> YYAction (-390); + GETS -> YYAction (-390); + DOTDOT -> YYAction (-390); _ -> YYAction yyBrace; }; }; -private yyaction147 t = case yytoken t of { - OF -> YYAction 257; +private yyaction150 t = case yytoken t of { + OF -> YYAction 262; _ -> YYAction yyErr; }; -private yyaction148 t = YYAction (-281); -private yyaction149 t = case yychar t of { +private yyaction151 t = YYAction (-282); +private yyaction152 t = case yychar t of { '-' -> YYAction 58; '(' -> YYAction 59; '[' -> YYAction 60; @@ -1551,23 +1568,23 @@ private yyaction149 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction150 t = case yychar t of { +private yyaction153 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; FALSE -> YYAction 39; IF -> YYAction 40; CASE -> YYAction 41; - LET -> YYAction 262; + LET -> YYAction 267; DO -> YYAction 44; INTCONST -> YYAction 49; STRCONST -> YYAction 50; @@ -1581,32 +1598,32 @@ private yyaction150 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction151 t = case yychar t of { - '-' -> YYAction 122; - '(' -> YYAction 123; +private yyaction154 t = case yychar t of { + '-' -> YYAction 124; + '(' -> YYAction 125; '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 119; - SOMEOP -> YYAction 121; + VARID -> YYAction 121; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction152 t = YYAction (-32); -private yyaction153 t = YYAction (-33); -private yyaction154 t = YYAction (-34); -private yyaction155 t = YYAction (-209); -private yyaction156 t = YYAction (-395); -private yyaction157 t = case yychar t of { - '(' -> YYAction 144; - ')' -> YYAction 267; +private yyaction155 t = YYAction (-32); +private yyaction156 t = YYAction (-33); +private yyaction157 t = YYAction (-34); +private yyaction158 t = YYAction (-210); +private yyaction159 t = YYAction (-397); +private yyaction160 t = case yychar t of { + '(' -> YYAction 147; + ')' -> YYAction 272; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -1627,23 +1644,23 @@ private yyaction157 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction158 t = YYAction (-430); -private yyaction159 t = case yychar t of { - ',' -> YYAction 159; - ')' -> YYAction (-446); +private yyaction161 t = YYAction (-432); +private yyaction162 t = case yychar t of { + ',' -> YYAction 162; + ')' -> YYAction (-448); _ -> YYAction yyErr; }; -private yyaction160 t = case yychar t of { +private yyaction163 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; - ')' -> YYAction 269; + '(' -> YYAction 147; + ')' -> YYAction 274; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -1664,15 +1681,15 @@ private yyaction160 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction161 t = case yychar t of { - '(' -> YYAction 144; - ')' -> YYAction 271; +private yyaction164 t = case yychar t of { + '(' -> YYAction 147; + ')' -> YYAction 276; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -1690,60 +1707,60 @@ private yyaction161 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction162 t = case yychar t of { - ')' -> YYAction 272; +private yyaction165 t = case yychar t of { + ')' -> YYAction 277; _ -> YYAction yyErr; }; -private yyaction163 t = case yychar t of { - ';' -> YYAction 273; - ')' -> YYAction 274; - ',' -> YYAction 275; +private yyaction166 t = case yychar t of { + ';' -> YYAction 278; + ')' -> YYAction 279; + ',' -> YYAction 280; _ -> YYAction yyErr; }; -private yyaction164 t = case yychar t of { - '-' -> YYAction 277; - ';' -> YYAction (-388); - ')' -> YYAction (-388); - ',' -> YYAction (-388); +private yyaction167 t = case yychar t of { + '-' -> YYAction 282; + ';' -> YYAction (-390); + ')' -> YYAction (-390); + ',' -> YYAction (-390); _ -> case yytoken t of { - DCOLON -> YYAction 256; - SOMEOP -> YYAction 276; + DCOLON -> YYAction 261; + SOMEOP -> YYAction 281; _ -> YYAction yyErr; }; }; -private yyaction165 t = YYAction (-441); -private yyaction166 t = case yychar t of { - ',' -> YYAction 279; - '|' -> YYAction 280; - ']' -> YYAction (-459); +private yyaction168 t = YYAction (-443); +private yyaction169 t = case yychar t of { + ',' -> YYAction 284; + '|' -> YYAction 285; + ']' -> YYAction (-461); _ -> case yytoken t of { - DOTDOT -> YYAction (-459); + DOTDOT -> YYAction (-461); _ -> YYAction yyErr; }; }; -private yyaction167 t = case yychar t of { - ']' -> YYAction 282; +private yyaction170 t = case yychar t of { + ']' -> YYAction 287; _ -> case yytoken t of { - DOTDOT -> YYAction 281; + DOTDOT -> YYAction 286; _ -> YYAction yyErr; }; }; -private yyaction168 t = case yychar t of { +private yyaction171 t = case yychar t of { '\\' -> YYAction 63; _ -> case yytoken t of { - ARROW -> YYAction 283; + ARROW -> YYAction 288; _ -> YYAction yyErr; }; }; -private yyaction169 t = case yychar t of { - '(' -> YYAction 144; +private yyaction172 t = case yychar t of { + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '_' -> YYAction 64; - '\\' -> YYAction (-406); + '\\' -> YYAction (-408); _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -1758,12 +1775,12 @@ private yyaction169 t = case yychar t of { CHRCONST -> YYAction 55; REGEXP -> YYAction 56; BIGCONST -> YYAction 57; - ARROW -> YYAction (-406); + ARROW -> YYAction (-408); _ -> YYAction yyErr; }; }; -private yyaction170 t = YYAction (-3); -private yyaction171 t = case yychar t of { +private yyaction173 t = YYAction (-3); +private yyaction174 t = case yychar t of { '-' -> YYAction 58; '(' -> YYAction 59; '[' -> YYAction 60; @@ -1811,66 +1828,67 @@ private yyaction171 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction172 t = case yychar t of { - '{' -> YYAction 288; +private yyaction175 t = case yychar t of { + '{' -> YYAction 293; _ -> YYAction yyErr; }; -private yyaction173 t = YYAction (-345); -private yyaction174 t = case yychar t of { - '}' -> YYAction 289; +private yyaction176 t = YYAction (-347); +private yyaction177 t = case yychar t of { + '}' -> YYAction 294; _ -> case yytoken t of { - VARID -> YYAction 119; + VARID -> YYAction 121; _ -> YYAction yyBrace; }; }; -private yyaction175 t = YYAction (-405); -private yyaction176 t = YYAction (-197); -private yyaction177 t = YYAction (-198); -private yyaction178 t = YYAction (-196); -private yyaction179 t = case yychar t of { - '-' -> YYAction 177; - ';' -> YYAction (-199); - '}' -> YYAction (-199); +private yyaction178 t = YYAction (-407); +private yyaction179 t = YYAction (-198); +private yyaction180 t = YYAction (-199); +private yyaction181 t = YYAction (-197); +private yyaction182 t = case yychar t of { + '-' -> YYAction 180; + ';' -> YYAction (-200); + '}' -> YYAction (-200); _ -> case yytoken t of { - VARID -> YYAction 176; - SOMEOP -> YYAction 121; + VARID -> YYAction 179; + SOMEOP -> YYAction 123; _ -> YYAction yyBrace; }; }; -private yyaction180 t = YYAction (-201); -private yyaction181 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction183 t = YYAction (-202); +private yyaction184 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction182 t = case yychar t of { - '(' -> YYAction 123; +private yyaction185 t = case yychar t of { + '(' -> YYAction 125; _ -> case yytoken t of { - VARID -> YYAction 119; + VARID -> YYAction 121; _ -> YYAction yyErr; }; }; -private yyaction183 t = case yychar t of { - '{' -> YYAction 303; +private yyaction186 t = case yychar t of { + '{' -> YYAction 308; _ -> YYAction yyErr; }; -private yyaction184 t = YYAction (-282); -private yyaction185 t = case yychar t of { +private yyaction187 t = YYAction (-283); +private yyaction188 t = YYAction (-284); +private yyaction189 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -1891,16 +1909,16 @@ private yyaction185 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction186 t = case yychar t of { +private yyaction190 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -1921,26 +1939,26 @@ private yyaction186 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction187 t = YYAction (-344); -private yyaction188 t = case yychar t of { - '|' -> YYAction 185; - ';' -> YYAction (-376); - '}' -> YYAction (-376); +private yyaction191 t = YYAction (-346); +private yyaction192 t = case yychar t of { + '|' -> YYAction 189; + ';' -> YYAction (-378); + '}' -> YYAction (-378); _ -> case yytoken t of { - WHERE -> YYAction (-376); + WHERE -> YYAction (-378); _ -> YYAction yyBrace; }; }; -private yyaction189 t = case yychar t of { +private yyaction193 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -1961,16 +1979,16 @@ private yyaction189 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction190 t = case yychar t of { +private yyaction194 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -1991,23 +2009,23 @@ private yyaction190 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction191 t = YYAction (-403); -private yyaction192 t = case yychar t of { - '{' -> YYAction 312; - '[' -> YYAction 313; +private yyaction195 t = YYAction (-405); +private yyaction196 t = case yychar t of { + '{' -> YYAction 317; + '[' -> YYAction 318; '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 311; - SOMEOP -> YYAction 121; + VARID -> YYAction 316; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction193 t = case yytoken t of { - VARID -> YYAction 316; +private yyaction197 t = case yytoken t of { + VARID -> YYAction 321; _ -> YYAction yyErr; }; -private yyaction194 t = case yychar t of { +private yyaction198 t = case yychar t of { '-' -> YYAction 58; '(' -> YYAction 59; '[' -> YYAction 60; @@ -2054,96 +2072,96 @@ private yyaction194 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction195 t = YYAction (-1); -private yyaction196 t = case yychar t of { +private yyaction199 t = YYAction (-1); +private yyaction200 t = case yychar t of { '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 110; - QUALIFIER -> YYAction 320; - SOMEOP -> YYAction 121; + VARID -> YYAction 112; + QUALIFIER -> YYAction 325; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction197 t = YYAction (-25); -private yyaction198 t = YYAction (-13); -private yyaction199 t = YYAction (-181); -private yyaction200 t = YYAction (-178); -private yyaction201 t = case yychar t of { - '(' -> YYAction (-168); +private yyaction201 t = YYAction (-25); +private yyaction202 t = YYAction (-13); +private yyaction203 t = YYAction (-182); +private yyaction204 t = YYAction (-179); +private yyaction205 t = case yychar t of { + '(' -> YYAction (-169); _ -> case yytoken t of { - CONID -> YYAction 325; + CONID -> YYAction 330; _ -> YYAction yyErr; }; }; -private yyaction202 t = case yychar t of { - '(' -> YYAction 204; - ';' -> YYAction (-142); - '}' -> YYAction (-142); +private yyaction206 t = case yychar t of { + '(' -> YYAction 208; + ';' -> YYAction (-143); + '}' -> YYAction (-143); _ -> case yytoken t of { - VARID -> YYAction 119; - PUBLIC -> YYAction 203; + VARID -> YYAction 121; + PUBLIC -> YYAction 207; _ -> YYAction yyBrace; }; }; -private yyaction203 t = case yychar t of { - '(' -> YYAction 204; - ';' -> YYAction (-142); - '}' -> YYAction (-142); +private yyaction207 t = case yychar t of { + '(' -> YYAction 208; + ';' -> YYAction (-143); + '}' -> YYAction (-143); _ -> case yytoken t of { - VARID -> YYAction 119; - PUBLIC -> YYAction 203; + VARID -> YYAction 121; + PUBLIC -> YYAction 207; _ -> YYAction yyBrace; }; }; -private yyaction204 t = case yychar t of { - ')' -> YYAction 331; +private yyaction208 t = case yychar t of { + ')' -> YYAction 336; '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 143; - CONID -> YYAction 328; - QUALIFIER -> YYAction 329; - PUBLIC -> YYAction 330; - SOMEOP -> YYAction 121; + VARID -> YYAction 146; + CONID -> YYAction 333; + QUALIFIER -> YYAction 334; + PUBLIC -> YYAction 335; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction205 t = YYAction (-139); -private yyaction206 t = case yychar t of { - '(' -> YYAction 339; +private yyaction209 t = YYAction (-140); +private yyaction210 t = case yychar t of { + '(' -> YYAction 344; _ -> YYAction yyErr; }; -private yyaction207 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction211 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction208 t = case yytoken t of { - CLASS -> YYAction 343; +private yyaction212 t = case yytoken t of { + CLASS -> YYAction 348; WHERE -> YYAction (-43); _ -> YYAction yyErr; }; -private yyaction209 t = case yychar t of { - ')' -> YYAction 345; +private yyaction213 t = case yychar t of { + ')' -> YYAction 350; _ -> YYAction yyErr; }; -private yyaction210 t = case yychar t of { - ')' -> YYAction 346; +private yyaction214 t = case yychar t of { + ')' -> YYAction 351; _ -> YYAction yyErr; }; -private yyaction211 t = case yychar t of { - ')' -> YYAction 347; +private yyaction215 t = case yychar t of { + ')' -> YYAction 352; _ -> YYAction yyErr; }; -private yyaction212 t = case yychar t of { - '.' -> YYAction 348; +private yyaction216 t = case yychar t of { + '.' -> YYAction 353; ';' -> YYAction (-5); '{' -> YYAction (-5); '}' -> YYAction (-5); @@ -2153,17 +2171,17 @@ private yyaction212 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction213 t = YYAction (-6); -private yyaction214 t = case yytoken t of { - VARID -> YYAction 212; - CONID -> YYAction 213; - QUALIFIER -> YYAction 214; - PACKAGE -> YYAction 215; - STRCONST -> YYAction 216; +private yyaction217 t = YYAction (-6); +private yyaction218 t = case yytoken t of { + VARID -> YYAction 216; + CONID -> YYAction 217; + QUALIFIER -> YYAction 218; + PACKAGE -> YYAction 219; + STRCONST -> YYAction 220; _ -> YYAction yyErr; }; -private yyaction215 t = case yychar t of { - '.' -> YYAction 350; +private yyaction219 t = case yychar t of { + '.' -> YYAction 355; ';' -> YYAction (-7); '{' -> YYAction (-7); '}' -> YYAction (-7); @@ -2173,188 +2191,199 @@ private yyaction215 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction216 t = YYAction (-11); -private yyaction217 t = case yychar t of { - '}' -> YYAction 351; - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction220 t = YYAction (-11); +private yyaction221 t = case yychar t of { + '}' -> YYAction 356; + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyBrace; }; }; -private yyaction218 t = YYAction (-215); -private yyaction219 t = YYAction (-4); -private yyaction220 t = YYAction (-216); -private yyaction221 t = YYAction (-217); -private yyaction222 t = case yychar t of { - '{' -> YYAction 217; +private yyaction222 t = YYAction (-216); +private yyaction223 t = YYAction (-4); +private yyaction224 t = YYAction (-217); +private yyaction225 t = YYAction (-218); +private yyaction226 t = case yychar t of { + '{' -> YYAction 221; _ -> case yytoken t of { - DCOLON -> YYAction (-219); + DCOLON -> YYAction (-220); _ -> YYAction yyErr; }; }; -private yyaction223 t = YYAction (-220); -private yyaction224 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction227 t = YYAction (-221); +private yyaction228 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction225 t = YYAction (-250); -private yyaction226 t = case yytoken t of { - VARID -> YYAction 358; - EXTENDS -> YYAction 359; - SUPER -> YYAction 360; +private yyaction229 t = YYAction (-251); +private yyaction230 t = case yytoken t of { + VARID -> YYAction 363; + EXTENDS -> YYAction 364; + SUPER -> YYAction 365; _ -> YYAction yyErr; }; -private yyaction227 t = case yychar t of { - '?' -> YYAction 366; - '!' -> YYAction 367; +private yyaction231 t = case yychar t of { + '?' -> YYAction 371; + '!' -> YYAction 372; _ -> case yytoken t of { - CONID -> YYAction 361; - DOCUMENTATION -> YYAction 362; - PRIVATE -> YYAction 363; - PROTECTED -> YYAction 364; - PUBLIC -> YYAction 365; + CONID -> YYAction 366; + DOCUMENTATION -> YYAction 367; + PRIVATE -> YYAction 368; + PROTECTED -> YYAction 369; + PUBLIC -> YYAction 370; _ -> YYAction yyErr; }; }; -private yyaction228 t = case yychar t of { - '=' -> YYAction 372; +private yyaction232 t = case yychar t of { + '=' -> YYAction 377; _ -> YYAction yyErr; }; -private yyaction229 t = case yychar t of { - '(' -> YYAction 226; - '.' -> YYAction (-296); - '=' -> YYAction (-296); +private yyaction233 t = case yychar t of { + '(' -> YYAction 230; + '.' -> YYAction (-298); + '=' -> YYAction (-298); _ -> case yytoken t of { - VARID -> YYAction 225; - SOMEOP -> YYAction (-296); + VARID -> YYAction 229; + SOMEOP -> YYAction (-298); _ -> YYAction yyErr; }; }; -private yyaction230 t = case yychar t of { - '?' -> YYAction 366; - '!' -> YYAction 367; +private yyaction234 t = case yychar t of { + '?' -> YYAction 371; + '!' -> YYAction 372; _ -> case yytoken t of { - CONID -> YYAction 361; - DOCUMENTATION -> YYAction 362; - NATIVE -> YYAction 374; - PRIVATE -> YYAction 363; - PROTECTED -> YYAction 364; - PUBLIC -> YYAction 365; - PURE -> YYAction 375; + CONID -> YYAction 366; + DOCUMENTATION -> YYAction 367; + NATIVE -> YYAction 379; + PRIVATE -> YYAction 368; + PROTECTED -> YYAction 369; + PUBLIC -> YYAction 370; + PURE -> YYAction 380; _ -> YYAction yyErr; }; }; -private yyaction231 t = case yychar t of { - '=' -> YYAction 379; +private yyaction235 t = case yychar t of { + '=' -> YYAction 384; _ -> YYAction yyErr; }; -private yyaction232 t = case yytoken t of { - CONID -> YYAction 199; +private yyaction236 t = case yytoken t of { + CONID -> YYAction 203; _ -> YYAction yyErr; }; -private yyaction233 t = case yychar t of { - ',' -> YYAction 380; - ')' -> YYAction (-265); +private yyaction237 t = case yychar t of { + ',' -> YYAction 385; + ')' -> YYAction (-266); _ -> YYAction yyErr; }; -private yyaction234 t = case yychar t of { - ')' -> YYAction 381; +private yyaction238 t = case yychar t of { + ')' -> YYAction 386; _ -> YYAction yyErr; }; -private yyaction235 t = YYAction (-264); -private yyaction236 t = case yytoken t of { - CONID -> YYAction 382; +private yyaction239 t = YYAction (-265); +private yyaction240 t = case yytoken t of { + CONID -> YYAction 387; _ -> YYAction yyErr; }; -private yyaction237 t = YYAction (-271); -private yyaction238 t = case yychar t of { - ',' -> YYAction 383; - ')' -> YYAction (-273); +private yyaction241 t = YYAction (-272); +private yyaction242 t = case yychar t of { + ',' -> YYAction 388; + ')' -> YYAction (-274); _ -> YYAction yyErr; }; -private yyaction239 t = case yychar t of { - ')' -> YYAction 384; +private yyaction243 t = case yychar t of { + ')' -> YYAction 389; _ -> YYAction yyErr; }; -private yyaction240 t = case yychar t of { - '(' -> YYAction 240; - ')' -> YYAction 387; - ',' -> YYAction 159; - '[' -> YYAction 241; +private yyaction244 t = case yychar t of { + '(' -> YYAction 244; + ')' -> YYAction 392; + ',' -> YYAction 162; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 385; + VARID -> YYAction 390; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - EXTENDS -> YYAction 359; - SUPER -> YYAction 360; - FORALL -> YYAction 294; - ARROW -> YYAction 386; + QUALIFIER -> YYAction 133; + EXTENDS -> YYAction 364; + SUPER -> YYAction 365; + FORALL -> YYAction 299; + ARROW -> YYAction 391; _ -> YYAction yyErr; }; }; -private yyaction241 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; - ']' -> YYAction 390; +private yyaction245 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; + ']' -> YYAction 395; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction242 t = YYAction (-255); -private yyaction243 t = YYAction (-272); -private yyaction244 t = YYAction (-244); -private yyaction245 t = YYAction (-245); -private yyaction246 t = case yychar t of { - '(' -> YYAction 392; - '[' -> YYAction 393; +private yyaction246 t = YYAction (-256); +private yyaction247 t = YYAction (-273); +private yyaction248 t = YYAction (-245); +private yyaction249 t = YYAction (-246); +private yyaction250 t = case yychar t of { + '(' -> YYAction 397; + '[' -> YYAction 398; _ -> case yytoken t of { CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; -private yyaction247 t = YYAction (-280); -private yyaction248 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction251 t = YYAction (-281); +private yyaction252 t = case yychar t of { + '(' -> YYAction 230; + '=' -> YYAction 400; + ';' -> YYAction (-293); + '}' -> YYAction (-293); + _ -> case yytoken t of { + VARID -> YYAction 229; + WHERE -> YYAction (-293); + _ -> YYAction yyBrace; + }; +}; +private yyaction253 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction249 t = case yychar t of { - '=' -> YYAction 396; +private yyaction254 t = case yychar t of { + '=' -> YYAction 403; _ -> YYAction yyErr; }; -private yyaction250 t = case yychar t of { - '(' -> YYAction 144; - ')' -> YYAction 397; +private yyaction255 t = case yychar t of { + '(' -> YYAction 147; + ')' -> YYAction 404; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -2375,17 +2404,17 @@ private yyaction250 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction251 t = case yychar t of { +private yyaction256 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; - ')' -> YYAction 398; + '(' -> YYAction 147; + ')' -> YYAction 405; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -2406,15 +2435,15 @@ private yyaction251 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction252 t = case yychar t of { - '(' -> YYAction 144; - ')' -> YYAction 399; +private yyaction257 t = case yychar t of { + '(' -> YYAction 147; + ')' -> YYAction 406; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -2432,21 +2461,21 @@ private yyaction252 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction253 t = YYAction (-390); -private yyaction254 t = case yytoken t of { - THEN -> YYAction 400; +private yyaction258 t = YYAction (-392); +private yyaction259 t = case yytoken t of { + THEN -> YYAction 407; _ -> YYAction yyErr; }; -private yyaction255 t = case yychar t of { +private yyaction260 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -2467,65 +2496,134 @@ private yyaction255 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction256 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction261 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction257 t = case yychar t of { - '{' -> YYAction 403; +private yyaction262 t = case yychar t of { + '{' -> YYAction 410; _ -> YYAction yyErr; }; -private yyaction258 t = YYAction (-134); -private yyaction259 t = case yychar t of { - ';' -> YYAction (-135); - '}' -> YYAction (-135); +private yyaction263 t = YYAction (-135); +private yyaction264 t = case yychar t of { + ';' -> YYAction (-136); + '}' -> YYAction (-136); _ -> case yytoken t of { - WHERE -> YYAction 172; + WHERE -> YYAction 175; _ -> YYAction yyBrace; }; }; -private yyaction260 t = case yychar t of { - ';' -> YYAction 404; - '}' -> YYAction (-136); +private yyaction265 t = case yychar t of { + ';' -> YYAction 411; + '}' -> YYAction (-137); _ -> YYAction yyBrace; }; -private yyaction261 t = case yychar t of { - '}' -> YYAction 405; +private yyaction266 t = case yychar t of { + '}' -> YYAction 412; _ -> YYAction yyBrace; }; -private yyaction262 t = case yychar t of { - '{' -> YYAction 406; +private yyaction267 t = case yychar t of { + '{' -> YYAction 413; _ -> YYAction yyErr; }; -private yyaction263 t = case yychar t of { - '=' -> YYAction 408; - ';' -> YYAction (-370); - '}' -> YYAction (-370); - ',' -> YYAction (-370); - ']' -> YYAction (-370); +private yyaction268 t = case yychar t of { + '=' -> YYAction 415; + ';' -> YYAction (-372); + '}' -> YYAction (-372); + ',' -> YYAction (-372); + ']' -> YYAction (-372); _ -> case yytoken t of { - GETS -> YYAction 407; + GETS -> YYAction 414; _ -> YYAction yyBrace; }; }; -private yyaction264 t = case yychar t of { - ';' -> YYAction 409; - '}' -> YYAction (-367); +private yyaction269 t = case yychar t of { + ';' -> YYAction 416; + '}' -> YYAction (-369); _ -> YYAction yyBrace; }; -private yyaction265 t = YYAction (-361); -private yyaction266 t = case yychar t of { - '}' -> YYAction 410; +private yyaction270 t = YYAction (-363); +private yyaction271 t = case yychar t of { + '}' -> YYAction 417; _ -> YYAction yyBrace; }; -private yyaction267 t = case yychar t of { +private yyaction272 t = case yychar t of { + '-' -> YYAction (-436); + '.' -> YYAction (-436); + '(' -> YYAction (-436); + ',' -> YYAction (-207); + '|' -> YYAction (-436); + '[' -> YYAction (-436); + '?' -> YYAction (-436); + '!' -> YYAction (-436); + '=' -> YYAction (-436); + '_' -> YYAction (-436); + _ -> case yytoken t of { + VARID -> YYAction (-436); + CONID -> YYAction (-436); + QUALIFIER -> YYAction (-436); + TRUE -> YYAction (-436); + FALSE -> YYAction (-436); + DO -> YYAction (-436); + INTCONST -> YYAction (-436); + STRCONST -> YYAction (-436); + LONGCONST -> YYAction (-436); + FLTCONST -> YYAction (-436); + DBLCONST -> YYAction (-436); + DECCONST -> YYAction (-436); + CHRCONST -> YYAction (-436); + REGEXP -> YYAction (-436); + BIGCONST -> YYAction (-436); + DCOLON -> YYAction (-207); + SOMEOP -> YYAction (-436); + _ -> YYAction yyErr; + }; +}; +private yyaction273 t = YYAction (-449); +private yyaction274 t = case yychar t of { + '-' -> YYAction (-435); + '.' -> YYAction (-435); + '(' -> YYAction (-435); + ',' -> YYAction (-205); + '|' -> YYAction (-435); + '[' -> YYAction (-435); + '?' -> YYAction (-435); + '!' -> YYAction (-435); + '=' -> YYAction (-435); + '_' -> YYAction (-435); + _ -> case yytoken t of { + VARID -> YYAction (-435); + CONID -> YYAction (-435); + QUALIFIER -> YYAction (-435); + TRUE -> YYAction (-435); + FALSE -> YYAction (-435); + DO -> YYAction (-435); + INTCONST -> YYAction (-435); + STRCONST -> YYAction (-435); + LONGCONST -> YYAction (-435); + FLTCONST -> YYAction (-435); + DBLCONST -> YYAction (-435); + DECCONST -> YYAction (-435); + CHRCONST -> YYAction (-435); + REGEXP -> YYAction (-435); + BIGCONST -> YYAction (-435); + DCOLON -> YYAction (-205); + SOMEOP -> YYAction (-435); + _ -> YYAction yyErr; + }; +}; +private yyaction275 t = case yychar t of { + ')' -> YYAction 418; + _ -> YYAction yyErr; +}; +private yyaction276 t = case yychar t of { '-' -> YYAction (-434); '.' -> YYAction (-434); '(' -> YYAction (-434); @@ -2557,86 +2655,17 @@ private yyaction267 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction268 t = YYAction (-447); -private yyaction269 t = case yychar t of { - '-' -> YYAction (-433); - '.' -> YYAction (-433); - '(' -> YYAction (-433); - ',' -> YYAction (-204); - '|' -> YYAction (-433); - '[' -> YYAction (-433); - '?' -> YYAction (-433); - '!' -> YYAction (-433); - '=' -> YYAction (-433); - '_' -> YYAction (-433); - _ -> case yytoken t of { - VARID -> YYAction (-433); - CONID -> YYAction (-433); - QUALIFIER -> YYAction (-433); - TRUE -> YYAction (-433); - FALSE -> YYAction (-433); - DO -> YYAction (-433); - INTCONST -> YYAction (-433); - STRCONST -> YYAction (-433); - LONGCONST -> YYAction (-433); - FLTCONST -> YYAction (-433); - DBLCONST -> YYAction (-433); - DECCONST -> YYAction (-433); - CHRCONST -> YYAction (-433); - REGEXP -> YYAction (-433); - BIGCONST -> YYAction (-433); - DCOLON -> YYAction (-204); - SOMEOP -> YYAction (-433); - _ -> YYAction yyErr; - }; -}; -private yyaction270 t = case yychar t of { - ')' -> YYAction 411; - _ -> YYAction yyErr; -}; -private yyaction271 t = case yychar t of { - '-' -> YYAction (-432); - '.' -> YYAction (-432); - '(' -> YYAction (-432); - ',' -> YYAction (-205); - '|' -> YYAction (-432); - '[' -> YYAction (-432); - '?' -> YYAction (-432); - '!' -> YYAction (-432); - '=' -> YYAction (-432); - '_' -> YYAction (-432); - _ -> case yytoken t of { - VARID -> YYAction (-432); - CONID -> YYAction (-432); - QUALIFIER -> YYAction (-432); - TRUE -> YYAction (-432); - FALSE -> YYAction (-432); - DO -> YYAction (-432); - INTCONST -> YYAction (-432); - STRCONST -> YYAction (-432); - LONGCONST -> YYAction (-432); - FLTCONST -> YYAction (-432); - DBLCONST -> YYAction (-432); - DECCONST -> YYAction (-432); - CHRCONST -> YYAction (-432); - REGEXP -> YYAction (-432); - BIGCONST -> YYAction (-432); - DCOLON -> YYAction (-205); - SOMEOP -> YYAction (-432); - _ -> YYAction yyErr; - }; -}; -private yyaction272 t = YYAction (-431); -private yyaction273 t = case yychar t of { +private yyaction277 t = YYAction (-433); +private yyaction278 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -2657,17 +2686,17 @@ private yyaction273 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction274 t = YYAction (-440); -private yyaction275 t = case yychar t of { +private yyaction279 t = YYAction (-442); +private yyaction280 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -2688,17 +2717,17 @@ private yyaction275 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction276 t = case yychar t of { +private yyaction281 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; - ')' -> YYAction (-190); + ')' -> YYAction (-191); _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -2719,17 +2748,17 @@ private yyaction276 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction277 t = case yychar t of { +private yyaction282 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; - ')' -> YYAction 416; + '(' -> YYAction 147; + ')' -> YYAction 423; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -2750,22 +2779,22 @@ private yyaction277 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction278 t = case yychar t of { - ')' -> YYAction 417; +private yyaction283 t = case yychar t of { + ')' -> YYAction 424; _ -> YYAction yyErr; }; -private yyaction279 t = case yychar t of { +private yyaction284 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; - ')' -> YYAction (-461); - ']' -> YYAction (-461); + ')' -> YYAction (-463); + ']' -> YYAction (-463); _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -2783,27 +2812,27 @@ private yyaction279 t = case yychar t of { CHRCONST -> YYAction 55; REGEXP -> YYAction 56; BIGCONST -> YYAction 57; - DOTDOT -> YYAction (-461); + DOTDOT -> YYAction (-463); _ -> YYAction yyErr; }; }; -private yyaction280 t = case yychar t of { +private yyaction285 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; FALSE -> YYAction 39; IF -> YYAction 40; CASE -> YYAction 41; - LET -> YYAction 262; + LET -> YYAction 267; DO -> YYAction 44; INTCONST -> YYAction 49; STRCONST -> YYAction 50; @@ -2817,17 +2846,17 @@ private yyaction280 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction281 t = case yychar t of { +private yyaction286 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; - ']' -> YYAction 421; + ']' -> YYAction 428; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -2848,17 +2877,17 @@ private yyaction281 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction282 t = YYAction (-442); -private yyaction283 t = case yychar t of { +private yyaction287 t = YYAction (-444); +private yyaction288 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -2879,13 +2908,13 @@ private yyaction283 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction284 t = YYAction (-385); -private yyaction285 t = YYAction (-384); -private yyaction286 t = YYAction (-407); -private yyaction287 t = YYAction (-28); -private yyaction288 t = case yychar t of { +private yyaction289 t = YYAction (-387); +private yyaction290 t = YYAction (-386); +private yyaction291 t = YYAction (-409); +private yyaction292 t = YYAction (-28); +private yyaction293 t = case yychar t of { '-' -> YYAction 58; - '}' -> YYAction 424; + '}' -> YYAction 431; '(' -> YYAction 59; '[' -> YYAction 60; '?' -> YYAction 61; @@ -2914,96 +2943,96 @@ private yyaction288 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction289 t = YYAction (-428); -private yyaction290 t = case yychar t of { - '=' -> YYAction 426; - '}' -> YYAction (-458); - ',' -> YYAction (-458); +private yyaction294 t = YYAction (-430); +private yyaction295 t = case yychar t of { + '=' -> YYAction 433; + '}' -> YYAction (-460); + ',' -> YYAction (-460); _ -> YYAction yyBrace; }; -private yyaction291 t = case yychar t of { - '}' -> YYAction 427; +private yyaction296 t = case yychar t of { + '}' -> YYAction 434; _ -> YYAction yyBrace; }; -private yyaction292 t = case yychar t of { - ',' -> YYAction 428; - '}' -> YYAction (-448); +private yyaction297 t = case yychar t of { + ',' -> YYAction 435; + '}' -> YYAction (-450); _ -> YYAction yyBrace; }; -private yyaction293 t = YYAction (-200); -private yyaction294 t = case yychar t of { - '(' -> YYAction 226; - _ -> case yytoken t of { - VARID -> YYAction 225; - _ -> YYAction yyErr; - }; -}; -private yyaction295 t = YYAction (-202); -private yyaction296 t = YYAction (-227); -private yyaction297 t = YYAction (-228); -private yyaction298 t = case yychar t of { - '-' -> YYAction (-234); - ';' -> YYAction (-234); - '}' -> YYAction (-234); - ')' -> YYAction (-234); - ',' -> YYAction (-234); - '|' -> YYAction (-234); - ']' -> YYAction (-234); - '=' -> YYAction (-234); - _ -> case yytoken t of { - ARROW -> YYAction 430; - EARROW -> YYAction 431; - DOCUMENTATION -> YYAction (-234); - WHERE -> YYAction (-234); - CLASS -> YYAction (-234); - THEN -> YYAction (-234); - ELSE -> YYAction (-234); - OF -> YYAction (-234); - THROWS -> YYAction (-234); - DCOLON -> YYAction (-234); - GETS -> YYAction (-234); - DOTDOT -> YYAction (-234); - SOMEOP -> YYAction (-234); +private yyaction298 t = YYAction (-201); +private yyaction299 t = case yychar t of { + '(' -> YYAction 230; + _ -> case yytoken t of { + VARID -> YYAction 229; + _ -> YYAction yyErr; + }; +}; +private yyaction300 t = YYAction (-203); +private yyaction301 t = YYAction (-228); +private yyaction302 t = YYAction (-229); +private yyaction303 t = case yychar t of { + '-' -> YYAction (-235); + ';' -> YYAction (-235); + '}' -> YYAction (-235); + ')' -> YYAction (-235); + ',' -> YYAction (-235); + '|' -> YYAction (-235); + ']' -> YYAction (-235); + '=' -> YYAction (-235); + _ -> case yytoken t of { + ARROW -> YYAction 437; + EARROW -> YYAction 438; + DOCUMENTATION -> YYAction (-235); + WHERE -> YYAction (-235); + CLASS -> YYAction (-235); + THEN -> YYAction (-235); + ELSE -> YYAction (-235); + OF -> YYAction (-235); + THROWS -> YYAction (-235); + DCOLON -> YYAction (-235); + GETS -> YYAction (-235); + DOTDOT -> YYAction (-235); + SOMEOP -> YYAction (-235); _ -> YYAction yyBrace; }; }; -private yyaction299 t = YYAction (-233); -private yyaction300 t = YYAction (-243); -private yyaction301 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; - '-' -> YYAction (-319); - ';' -> YYAction (-319); - '}' -> YYAction (-319); - ')' -> YYAction (-319); - ',' -> YYAction (-319); - '|' -> YYAction (-319); - ']' -> YYAction (-319); - '=' -> YYAction (-319); - _ -> case yytoken t of { - VARID -> YYAction 225; +private yyaction304 t = YYAction (-234); +private yyaction305 t = YYAction (-244); +private yyaction306 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; + '-' -> YYAction (-321); + ';' -> YYAction (-321); + '}' -> YYAction (-321); + ')' -> YYAction (-321); + ',' -> YYAction (-321); + '|' -> YYAction (-321); + ']' -> YYAction (-321); + '=' -> YYAction (-321); + _ -> case yytoken t of { + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - DOCUMENTATION -> YYAction (-319); - WHERE -> YYAction (-319); - CLASS -> YYAction (-319); - THEN -> YYAction (-319); - ELSE -> YYAction (-319); - OF -> YYAction (-319); - THROWS -> YYAction (-319); - ARROW -> YYAction (-319); - DCOLON -> YYAction (-319); - GETS -> YYAction (-319); - EARROW -> YYAction (-319); - DOTDOT -> YYAction (-319); - SOMEOP -> YYAction (-319); + QUALIFIER -> YYAction 133; + DOCUMENTATION -> YYAction (-321); + WHERE -> YYAction (-321); + CLASS -> YYAction (-321); + THEN -> YYAction (-321); + ELSE -> YYAction (-321); + OF -> YYAction (-321); + THROWS -> YYAction (-321); + ARROW -> YYAction (-321); + DCOLON -> YYAction (-321); + GETS -> YYAction (-321); + EARROW -> YYAction (-321); + DOTDOT -> YYAction (-321); + SOMEOP -> YYAction (-321); _ -> YYAction yyBrace; }; }; -private yyaction302 t = YYAction (-208); -private yyaction303 t = case yychar t of { +private yyaction307 t = YYAction (-209); +private yyaction308 t = case yychar t of { '-' -> YYAction 58; - '}' -> YYAction 436; + '}' -> YYAction 443; '(' -> YYAction 59; '[' -> YYAction 60; '?' -> YYAction 61; @@ -3015,16 +3044,16 @@ private yyaction303 t = case yychar t of { CONID -> YYAction 24; QUALIFIER -> YYAction 25; DOCUMENTATION -> YYAction 26; - NATIVE -> YYAction 151; + NATIVE -> YYAction 154; TRUE -> YYAction 38; FALSE -> YYAction 39; IF -> YYAction 40; CASE -> YYAction 41; LET -> YYAction 43; DO -> YYAction 44; - PRIVATE -> YYAction 433; - PROTECTED -> YYAction 434; - PUBLIC -> YYAction 435; + PRIVATE -> YYAction 440; + PROTECTED -> YYAction 441; + PUBLIC -> YYAction 442; PURE -> YYAction 48; INTCONST -> YYAction 49; STRCONST -> YYAction 50; @@ -3038,91 +3067,91 @@ private yyaction303 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction304 t = case yychar t of { - ',' -> YYAction (-370); - '=' -> YYAction (-370); - _ -> case yytoken t of { - GETS -> YYAction 407; - ARROW -> YYAction (-370); - _ -> YYAction yyErr; - }; -}; -private yyaction305 t = case yychar t of { - ',' -> YYAction 442; +private yyaction309 t = case yychar t of { + ',' -> YYAction (-372); '=' -> YYAction (-372); _ -> case yytoken t of { + GETS -> YYAction 414; ARROW -> YYAction (-372); _ -> YYAction yyErr; }; }; -private yyaction306 t = case yychar t of { - '=' -> YYAction 444; +private yyaction310 t = case yychar t of { + ',' -> YYAction 449; + '=' -> YYAction (-374); _ -> case yytoken t of { - ARROW -> YYAction 443; + ARROW -> YYAction (-374); _ -> YYAction yyErr; }; }; -private yyaction307 t = YYAction (-343); -private yyaction308 t = YYAction (-377); -private yyaction309 t = case yychar t of { - '-' -> YYAction 190; - ';' -> YYAction (-393); - '}' -> YYAction (-393); - ')' -> YYAction (-393); - ',' -> YYAction (-393); - '|' -> YYAction (-393); - ']' -> YYAction (-393); - '=' -> YYAction (-393); - _ -> case yytoken t of { - SOMEOP -> YYAction 189; - WHERE -> YYAction (-393); - THEN -> YYAction (-393); - ELSE -> YYAction (-393); - OF -> YYAction (-393); - ARROW -> YYAction (-393); - DCOLON -> YYAction (-393); - GETS -> YYAction (-393); - DOTDOT -> YYAction (-393); +private yyaction311 t = case yychar t of { + '=' -> YYAction 451; + _ -> case yytoken t of { + ARROW -> YYAction 450; + _ -> YYAction yyErr; + }; +}; +private yyaction312 t = YYAction (-345); +private yyaction313 t = YYAction (-379); +private yyaction314 t = case yychar t of { + '-' -> YYAction 194; + ';' -> YYAction (-395); + '}' -> YYAction (-395); + ')' -> YYAction (-395); + ',' -> YYAction (-395); + '|' -> YYAction (-395); + ']' -> YYAction (-395); + '=' -> YYAction (-395); + _ -> case yytoken t of { + SOMEOP -> YYAction 193; + WHERE -> YYAction (-395); + THEN -> YYAction (-395); + ELSE -> YYAction (-395); + OF -> YYAction (-395); + ARROW -> YYAction (-395); + DCOLON -> YYAction (-395); + GETS -> YYAction (-395); + DOTDOT -> YYAction (-395); _ -> YYAction yyBrace; }; }; -private yyaction310 t = case yychar t of { - '-' -> YYAction 190; - ';' -> YYAction (-394); - '}' -> YYAction (-394); - ')' -> YYAction (-394); - ',' -> YYAction (-394); - '|' -> YYAction (-394); - ']' -> YYAction (-394); - '=' -> YYAction (-394); - _ -> case yytoken t of { - SOMEOP -> YYAction 189; - WHERE -> YYAction (-394); - THEN -> YYAction (-394); - ELSE -> YYAction (-394); - OF -> YYAction (-394); - ARROW -> YYAction (-394); - DCOLON -> YYAction (-394); - GETS -> YYAction (-394); - DOTDOT -> YYAction (-394); +private yyaction315 t = case yychar t of { + '-' -> YYAction 194; + ';' -> YYAction (-396); + '}' -> YYAction (-396); + ')' -> YYAction (-396); + ',' -> YYAction (-396); + '|' -> YYAction (-396); + ']' -> YYAction (-396); + '=' -> YYAction (-396); + _ -> case yytoken t of { + SOMEOP -> YYAction 193; + WHERE -> YYAction (-396); + THEN -> YYAction (-396); + ELSE -> YYAction (-396); + OF -> YYAction (-396); + ARROW -> YYAction (-396); + DCOLON -> YYAction (-396); + GETS -> YYAction (-396); + DOTDOT -> YYAction (-396); _ -> YYAction yyBrace; }; }; -private yyaction311 t = YYAction (-412); -private yyaction312 t = case yytoken t of { - VARID -> YYAction 446; +private yyaction316 t = YYAction (-414); +private yyaction317 t = case yytoken t of { + VARID -> YYAction 453; _ -> YYAction yyErr; }; -private yyaction313 t = case yychar t of { +private yyaction318 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -3143,483 +3172,499 @@ private yyaction313 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction314 t = YYAction (-413); -private yyaction315 t = YYAction (-414); -private yyaction316 t = case yychar t of { - '?' -> YYAction 450; - '=' -> YYAction 451; - '}' -> YYAction (-456); - ',' -> YYAction (-456); +private yyaction319 t = YYAction (-415); +private yyaction320 t = YYAction (-416); +private yyaction321 t = case yychar t of { + '?' -> YYAction 457; + '=' -> YYAction 458; + '}' -> YYAction (-458); + ',' -> YYAction (-458); _ -> case yytoken t of { - GETS -> YYAction 449; + GETS -> YYAction 456; _ -> YYAction yyBrace; }; }; -private yyaction317 t = case yychar t of { - '}' -> YYAction 452; +private yyaction322 t = case yychar t of { + '}' -> YYAction 459; _ -> YYAction yyBrace; }; -private yyaction318 t = case yychar t of { - ',' -> YYAction 453; - '}' -> YYAction (-451); +private yyaction323 t = case yychar t of { + ',' -> YYAction 460; + '}' -> YYAction (-453); _ -> YYAction yyBrace; }; -private yyaction319 t = case yychar t of { - '}' -> YYAction 454; +private yyaction324 t = case yychar t of { + '}' -> YYAction 461; _ -> YYAction yyBrace; }; -private yyaction320 t = case yychar t of { +private yyaction325 t = case yychar t of { '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 110; - QUALIFIER -> YYAction 455; + VARID -> YYAction 112; + QUALIFIER -> YYAction 462; _ -> YYAction yyErr; }; }; -private yyaction321 t = case yychar t of { - ')' -> YYAction 457; +private yyaction326 t = case yychar t of { + ')' -> YYAction 464; _ -> YYAction yyErr; }; -private yyaction322 t = YYAction (-189); -private yyaction323 t = case yychar t of { - ',' -> YYAction 458; - ')' -> YYAction (-176); +private yyaction327 t = YYAction (-190); +private yyaction328 t = case yychar t of { + ',' -> YYAction 465; + ')' -> YYAction (-177); _ -> YYAction yyErr; }; -private yyaction324 t = YYAction (-188); -private yyaction325 t = case yychar t of { - '(' -> YYAction 204; - ';' -> YYAction (-142); - '}' -> YYAction (-142); +private yyaction329 t = YYAction (-189); +private yyaction330 t = case yychar t of { + '(' -> YYAction 208; + ';' -> YYAction (-143); + '}' -> YYAction (-143); _ -> case yytoken t of { - VARID -> YYAction 119; - PUBLIC -> YYAction 203; + VARID -> YYAction 121; + PUBLIC -> YYAction 207; _ -> YYAction yyBrace; }; }; -private yyaction326 t = YYAction (-141); -private yyaction327 t = YYAction (-146); -private yyaction328 t = case yychar t of { - '(' -> YYAction 460; - ')' -> YYAction (-183); - ',' -> YYAction (-183); +private yyaction331 t = YYAction (-142); +private yyaction332 t = YYAction (-147); +private yyaction333 t = case yychar t of { + '(' -> YYAction 467; + ')' -> YYAction (-184); + ',' -> YYAction (-184); _ -> case yytoken t of { - VARID -> YYAction (-183); - CONID -> YYAction (-183); - SOMEOP -> YYAction (-183); + VARID -> YYAction (-184); + CONID -> YYAction (-184); + SOMEOP -> YYAction (-184); _ -> YYAction yyErr; }; }; -private yyaction329 t = case yychar t of { +private yyaction334 t = case yychar t of { '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 110; - CONID -> YYAction 111; - QUALIFIER -> YYAction 461; + VARID -> YYAction 112; + CONID -> YYAction 113; + QUALIFIER -> YYAction 468; _ -> YYAction yyErr; }; }; -private yyaction330 t = case yychar t of { +private yyaction335 t = case yychar t of { '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 143; - CONID -> YYAction 328; - QUALIFIER -> YYAction 329; - PUBLIC -> YYAction 330; - SOMEOP -> YYAction 121; + VARID -> YYAction 146; + CONID -> YYAction 333; + QUALIFIER -> YYAction 334; + PUBLIC -> YYAction 335; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction331 t = YYAction (-144); -private yyaction332 t = case yychar t of { - ')' -> YYAction 463; +private yyaction336 t = YYAction (-145); +private yyaction337 t = case yychar t of { + ')' -> YYAction 470; _ -> YYAction yyErr; }; -private yyaction333 t = case yychar t of { - ',' -> YYAction 464; - ')' -> YYAction (-147); +private yyaction338 t = case yychar t of { + ',' -> YYAction 471; + ')' -> YYAction (-148); _ -> YYAction yyErr; }; -private yyaction334 t = case yychar t of { - ')' -> YYAction (-156); - ',' -> YYAction (-156); +private yyaction339 t = case yychar t of { + ')' -> YYAction (-157); + ',' -> YYAction (-157); _ -> case yytoken t of { - VARID -> YYAction 465; - CONID -> YYAction 466; - SOMEOP -> YYAction 121; + VARID -> YYAction 472; + CONID -> YYAction 473; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction335 t = YYAction (-150); -private yyaction336 t = YYAction (-153); -private yyaction337 t = YYAction (-154); -private yyaction338 t = YYAction (-155); -private yyaction339 t = case yychar t of { +private yyaction340 t = YYAction (-151); +private yyaction341 t = YYAction (-154); +private yyaction342 t = YYAction (-155); +private yyaction343 t = YYAction (-156); +private yyaction344 t = case yychar t of { '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 143; - CONID -> YYAction 328; - QUALIFIER -> YYAction 329; - PUBLIC -> YYAction 330; - SOMEOP -> YYAction 121; + VARID -> YYAction 146; + CONID -> YYAction 333; + QUALIFIER -> YYAction 334; + PUBLIC -> YYAction 335; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction340 t = YYAction (-42); -private yyaction341 t = YYAction (-237); -private yyaction342 t = case yychar t of { - ';' -> YYAction (-236); - '}' -> YYAction (-236); - ')' -> YYAction (-236); - ',' -> YYAction (-236); - '|' -> YYAction (-236); - ']' -> YYAction (-236); +private yyaction345 t = YYAction (-42); +private yyaction346 t = YYAction (-238); +private yyaction347 t = case yychar t of { + ';' -> YYAction (-237); + '}' -> YYAction (-237); + ')' -> YYAction (-237); + ',' -> YYAction (-237); + '|' -> YYAction (-237); + ']' -> YYAction (-237); _ -> case yytoken t of { - ARROW -> YYAction 470; - WHERE -> YYAction (-236); - CLASS -> YYAction (-236); + ARROW -> YYAction 477; + WHERE -> YYAction (-237); + CLASS -> YYAction (-237); _ -> YYAction yyBrace; }; }; -private yyaction343 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction348 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction344 t = case yytoken t of { - WHERE -> YYAction 472; +private yyaction349 t = case yytoken t of { + WHERE -> YYAction 479; _ -> YYAction yyErr; }; -private yyaction345 t = YYAction (-206); -private yyaction346 t = YYAction (-204); -private yyaction347 t = YYAction (-205); -private yyaction348 t = case yytoken t of { - VARID -> YYAction 212; - CONID -> YYAction 213; - QUALIFIER -> YYAction 214; - PACKAGE -> YYAction 215; - STRCONST -> YYAction 216; +private yyaction350 t = YYAction (-207); +private yyaction351 t = YYAction (-205); +private yyaction352 t = YYAction (-206); +private yyaction353 t = case yytoken t of { + VARID -> YYAction 216; + CONID -> YYAction 217; + QUALIFIER -> YYAction 218; + PACKAGE -> YYAction 219; + STRCONST -> YYAction 220; _ -> YYAction yyErr; }; -private yyaction349 t = YYAction (-10); -private yyaction350 t = case yytoken t of { - VARID -> YYAction 212; - CONID -> YYAction 213; - QUALIFIER -> YYAction 214; - PACKAGE -> YYAction 215; - STRCONST -> YYAction 216; +private yyaction354 t = YYAction (-10); +private yyaction355 t = case yytoken t of { + VARID -> YYAction 216; + CONID -> YYAction 217; + QUALIFIER -> YYAction 218; + PACKAGE -> YYAction 219; + STRCONST -> YYAction 220; _ -> YYAction yyErr; }; -private yyaction351 t = YYAction (-288); -private yyaction352 t = case yychar t of { - ',' -> YYAction 476; - ';' -> YYAction (-239); - '}' -> YYAction (-239); - ')' -> YYAction (-239); - '|' -> YYAction (-239); +private yyaction356 t = YYAction (-290); +private yyaction357 t = case yychar t of { + ',' -> YYAction 483; + ';' -> YYAction (-240); + '}' -> YYAction (-240); + ')' -> YYAction (-240); + '|' -> YYAction (-240); _ -> case yytoken t of { - WHERE -> YYAction (-239); + WHERE -> YYAction (-240); _ -> YYAction yyBrace; }; }; -private yyaction353 t = case yychar t of { - '}' -> YYAction 477; +private yyaction358 t = case yychar t of { + '}' -> YYAction 484; _ -> YYAction yyBrace; }; -private yyaction354 t = YYAction (-218); -private yyaction355 t = case yychar t of { - ';' -> YYAction (-223); - '}' -> YYAction (-223); - '|' -> YYAction (-223); +private yyaction359 t = YYAction (-219); +private yyaction360 t = case yychar t of { + ';' -> YYAction (-224); + '}' -> YYAction (-224); + '|' -> YYAction (-224); _ -> case yytoken t of { - THROWS -> YYAction 478; + THROWS -> YYAction 485; _ -> YYAction yyBrace; }; }; -private yyaction356 t = case yychar t of { - '|' -> YYAction 479; - ';' -> YYAction (-224); - '}' -> YYAction (-224); +private yyaction361 t = case yychar t of { + '|' -> YYAction 486; + ';' -> YYAction (-225); + '}' -> YYAction (-225); _ -> YYAction yyBrace; }; -private yyaction357 t = YYAction (-226); -private yyaction358 t = case yytoken t of { - EXTENDS -> YYAction 480; - DCOLON -> YYAction 481; +private yyaction362 t = YYAction (-227); +private yyaction363 t = case yytoken t of { + EXTENDS -> YYAction 487; + DCOLON -> YYAction 488; _ -> YYAction yyErr; }; -private yyaction359 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction364 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction360 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction365 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; -private yyaction361 t = case yychar t of { - '{' -> YYAction 484; - '(' -> YYAction 240; - '[' -> YYAction 241; - '?' -> YYAction 485; - '!' -> YYAction 486; - ';' -> YYAction (-310); - '}' -> YYAction (-310); - '|' -> YYAction (-310); - _ -> case yytoken t of { - VARID -> YYAction 225; +private yyaction366 t = case yychar t of { + '{' -> YYAction 491; + '(' -> YYAction 244; + '[' -> YYAction 245; + '?' -> YYAction 492; + '!' -> YYAction 493; + ';' -> YYAction (-312); + '}' -> YYAction (-312); + '|' -> YYAction (-312); + _ -> case yytoken t of { + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - DOCUMENTATION -> YYAction (-310); - WHERE -> YYAction (-310); + QUALIFIER -> YYAction 133; + DOCUMENTATION -> YYAction (-312); + WHERE -> YYAction (-312); _ -> YYAction yyBrace; }; }; -private yyaction362 t = case yychar t of { - '?' -> YYAction 366; - '!' -> YYAction 367; +private yyaction367 t = case yychar t of { + '?' -> YYAction 371; + '!' -> YYAction 372; _ -> case yytoken t of { - CONID -> YYAction 361; - PRIVATE -> YYAction 363; - PROTECTED -> YYAction 364; - PUBLIC -> YYAction 365; + CONID -> YYAction 366; + PRIVATE -> YYAction 368; + PROTECTED -> YYAction 369; + PUBLIC -> YYAction 370; _ -> YYAction yyErr; }; }; -private yyaction363 t = case yychar t of { - '?' -> YYAction 366; - '!' -> YYAction 367; +private yyaction368 t = case yychar t of { + '?' -> YYAction 371; + '!' -> YYAction 372; _ -> case yytoken t of { - CONID -> YYAction 361; + CONID -> YYAction 366; _ -> YYAction yyErr; }; }; -private yyaction364 t = case yychar t of { - '?' -> YYAction 366; - '!' -> YYAction 367; +private yyaction369 t = case yychar t of { + '?' -> YYAction 371; + '!' -> YYAction 372; _ -> case yytoken t of { - CONID -> YYAction 361; + CONID -> YYAction 366; _ -> YYAction yyErr; }; }; -private yyaction365 t = case yychar t of { - '?' -> YYAction 366; - '!' -> YYAction 367; +private yyaction370 t = case yychar t of { + '?' -> YYAction 371; + '!' -> YYAction 372; _ -> case yytoken t of { - CONID -> YYAction 361; + CONID -> YYAction 366; _ -> YYAction yyErr; }; }; -private yyaction366 t = case yytoken t of { - CONID -> YYAction 361; +private yyaction371 t = case yytoken t of { + CONID -> YYAction 366; _ -> YYAction yyErr; }; -private yyaction367 t = case yytoken t of { - CONID -> YYAction 361; +private yyaction372 t = case yytoken t of { + CONID -> YYAction 366; _ -> YYAction yyErr; }; -private yyaction368 t = YYAction (-295); -private yyaction369 t = case yychar t of { - ';' -> YYAction (-300); - '}' -> YYAction (-300); - '|' -> YYAction (-300); +private yyaction373 t = YYAction (-295); +private yyaction374 t = case yychar t of { + ';' -> YYAction (-302); + '}' -> YYAction (-302); + '|' -> YYAction (-302); _ -> case yytoken t of { - DOCUMENTATION -> YYAction 497; - WHERE -> YYAction (-300); + DOCUMENTATION -> YYAction 504; + WHERE -> YYAction (-302); _ -> YYAction yyBrace; }; }; -private yyaction370 t = YYAction (-303); -private yyaction371 t = YYAction (-309); -private yyaction372 t = case yychar t of { - '?' -> YYAction 366; - '!' -> YYAction 367; +private yyaction375 t = YYAction (-305); +private yyaction376 t = YYAction (-311); +private yyaction377 t = case yychar t of { + '?' -> YYAction 371; + '!' -> YYAction 372; _ -> case yytoken t of { - CONID -> YYAction 361; - DOCUMENTATION -> YYAction 362; - PRIVATE -> YYAction 363; - PROTECTED -> YYAction 364; - PUBLIC -> YYAction 365; + CONID -> YYAction 366; + DOCUMENTATION -> YYAction 367; + PRIVATE -> YYAction 368; + PROTECTED -> YYAction 369; + PUBLIC -> YYAction 370; _ -> YYAction yyErr; }; }; -private yyaction373 t = YYAction (-297); -private yyaction374 t = YYAction (-284); -private yyaction375 t = case yytoken t of { - NATIVE -> YYAction 499; +private yyaction378 t = YYAction (-299); +private yyaction379 t = YYAction (-286); +private yyaction380 t = case yytoken t of { + NATIVE -> YYAction 506; _ -> YYAction yyErr; }; -private yyaction376 t = case yytoken t of { - VARID -> YYAction 212; - CONID -> YYAction 213; - QUALIFIER -> YYAction 214; - PACKAGE -> YYAction 215; - STRCONST -> YYAction 216; +private yyaction381 t = case yytoken t of { + VARID -> YYAction 216; + CONID -> YYAction 217; + QUALIFIER -> YYAction 218; + PACKAGE -> YYAction 219; + STRCONST -> YYAction 220; _ -> YYAction yyErr; }; -private yyaction377 t = YYAction (-292); -private yyaction378 t = case yychar t of { - '|' -> YYAction 502; - ';' -> YYAction (-298); - '}' -> YYAction (-298); +private yyaction382 t = YYAction (-292); +private yyaction383 t = case yychar t of { + '|' -> YYAction 509; + ';' -> YYAction (-300); + '}' -> YYAction (-300); _ -> case yytoken t of { - WHERE -> YYAction (-298); + WHERE -> YYAction (-300); _ -> YYAction yyBrace; }; }; -private yyaction379 t = case yychar t of { - '?' -> YYAction 366; - '!' -> YYAction 367; +private yyaction384 t = case yychar t of { + '?' -> YYAction 371; + '!' -> YYAction 372; _ -> case yytoken t of { - CONID -> YYAction 361; - DOCUMENTATION -> YYAction 362; - NATIVE -> YYAction 374; - PRIVATE -> YYAction 363; - PROTECTED -> YYAction 364; - PUBLIC -> YYAction 365; - PURE -> YYAction 375; + CONID -> YYAction 366; + DOCUMENTATION -> YYAction 367; + NATIVE -> YYAction 379; + PRIVATE -> YYAction 368; + PROTECTED -> YYAction 369; + PUBLIC -> YYAction 370; + PURE -> YYAction 380; _ -> YYAction yyErr; }; }; -private yyaction380 t = case yychar t of { - ')' -> YYAction (-266); +private yyaction385 t = case yychar t of { + ')' -> YYAction (-267); _ -> case yytoken t of { CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; -private yyaction381 t = YYAction (-269); -private yyaction382 t = case yychar t of { - '(' -> YYAction 226; +private yyaction386 t = YYAction (-270); +private yyaction387 t = case yychar t of { + '(' -> YYAction 230; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; _ -> YYAction yyErr; }; }; -private yyaction383 t = case yychar t of { - ')' -> YYAction (-274); +private yyaction388 t = case yychar t of { + ')' -> YYAction (-275); _ -> case yytoken t of { CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; -private yyaction384 t = YYAction (-277); -private yyaction385 t = case yychar t of { - '(' -> YYAction (-250); - ')' -> YYAction (-250); - ',' -> YYAction (-250); - '|' -> YYAction (-250); - '[' -> YYAction (-250); +private yyaction389 t = YYAction (-278); +private yyaction390 t = case yychar t of { + '(' -> YYAction (-251); + ')' -> YYAction (-251); + ',' -> YYAction (-251); + '|' -> YYAction (-251); + '[' -> YYAction (-251); _ -> case yytoken t of { - EXTENDS -> YYAction 480; - DCOLON -> YYAction 481; - VARID -> YYAction (-250); - CONID -> YYAction (-250); - QUALIFIER -> YYAction (-250); - ARROW -> YYAction (-250); + EXTENDS -> YYAction 487; + DCOLON -> YYAction 488; + VARID -> YYAction (-251); + CONID -> YYAction (-251); + QUALIFIER -> YYAction (-251); + ARROW -> YYAction (-251); _ -> YYAction yyErr; }; }; -private yyaction386 t = case yychar t of { - ')' -> YYAction 508; +private yyaction391 t = case yychar t of { + ')' -> YYAction 515; _ -> YYAction yyErr; }; -private yyaction387 t = YYAction (-257); -private yyaction388 t = case yychar t of { - ')' -> YYAction 509; - ',' -> YYAction 510; - '|' -> YYAction 511; +private yyaction392 t = YYAction (-258); +private yyaction393 t = case yychar t of { + ')' -> YYAction 516; + ',' -> YYAction 517; + '|' -> YYAction 518; _ -> YYAction yyErr; }; -private yyaction389 t = case yychar t of { - ')' -> YYAction 512; +private yyaction394 t = case yychar t of { + ')' -> YYAction 519; _ -> YYAction yyErr; }; -private yyaction390 t = YYAction (-256); -private yyaction391 t = case yychar t of { - ']' -> YYAction 513; +private yyaction395 t = YYAction (-257); +private yyaction396 t = case yychar t of { + ']' -> YYAction 520; _ -> YYAction yyErr; }; -private yyaction392 t = case yychar t of { - ')' -> YYAction 387; - ',' -> YYAction 159; +private yyaction397 t = case yychar t of { + ')' -> YYAction 392; + ',' -> YYAction 162; _ -> case yytoken t of { - ARROW -> YYAction 386; + ARROW -> YYAction 391; _ -> YYAction yyErr; }; }; -private yyaction393 t = case yychar t of { - ']' -> YYAction 390; +private yyaction398 t = case yychar t of { + ']' -> YYAction 395; _ -> YYAction yyErr; }; -private yyaction394 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction399 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; -private yyaction395 t = YYAction (-336); -private yyaction396 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction400 t = case yychar t of { + '?' -> YYAction 371; + '!' -> YYAction 372; _ -> case yytoken t of { - VARID -> YYAction 225; - CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + CONID -> YYAction 366; + DOCUMENTATION -> YYAction 367; + PRIVATE -> YYAction 368; + PROTECTED -> YYAction 369; + PUBLIC -> YYAction 370; _ -> YYAction yyErr; }; }; -private yyaction397 t = YYAction (-434); -private yyaction398 t = YYAction (-433); -private yyaction399 t = YYAction (-432); -private yyaction400 t = YYAction (-389); private yyaction401 t = case yychar t of { - ';' -> YYAction 517; + '=' -> YYAction 522; + _ -> YYAction yyErr; +}; +private yyaction402 t = YYAction (-338); +private yyaction403 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - ELSE -> YYAction 516; + VARID -> YYAction 229; + CONID -> YYAction 24; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction402 t = YYAction (-387); -private yyaction403 t = case yychar t of { +private yyaction404 t = YYAction (-436); +private yyaction405 t = YYAction (-435); +private yyaction406 t = YYAction (-434); +private yyaction407 t = YYAction (-391); +private yyaction408 t = case yychar t of { + ';' -> YYAction 525; + _ -> case yytoken t of { + ELSE -> YYAction 524; + _ -> YYAction yyErr; + }; +}; +private yyaction409 t = YYAction (-389); +private yyaction410 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -3640,7 +3685,7 @@ private yyaction403 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction404 t = case yychar t of { +private yyaction411 t = case yychar t of { '-' -> YYAction 58; '(' -> YYAction 59; '[' -> YYAction 60; @@ -3648,7 +3693,7 @@ private yyaction404 t = case yychar t of { '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; - '}' -> YYAction (-137); + '}' -> YYAction (-138); _ -> case yytoken t of { VARID -> YYAction 23; CONID -> YYAction 24; @@ -3671,11 +3716,11 @@ private yyaction404 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction405 t = case yytoken t of { - IN -> YYAction 524; +private yyaction412 t = case yytoken t of { + IN -> YYAction 532; _ -> YYAction yyErr; }; -private yyaction406 t = case yychar t of { +private yyaction413 t = case yychar t of { '-' -> YYAction 58; '(' -> YYAction 59; '[' -> YYAction 60; @@ -3705,16 +3750,16 @@ private yyaction406 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction407 t = case yychar t of { +private yyaction414 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -3735,16 +3780,16 @@ private yyaction407 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction408 t = case yychar t of { +private yyaction415 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -3765,24 +3810,24 @@ private yyaction408 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction409 t = case yychar t of { +private yyaction416 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; - '}' -> YYAction (-368); + '}' -> YYAction (-370); _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; FALSE -> YYAction 39; IF -> YYAction 40; CASE -> YYAction 41; - LET -> YYAction 262; + LET -> YYAction 267; DO -> YYAction 44; INTCONST -> YYAction 49; STRCONST -> YYAction 50; @@ -3796,63 +3841,63 @@ private yyaction409 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction410 t = YYAction (-411); -private yyaction411 t = YYAction (-435); -private yyaction412 t = case yychar t of { - ';' -> YYAction 529; - ')' -> YYAction (-462); +private yyaction417 t = YYAction (-413); +private yyaction418 t = YYAction (-437); +private yyaction419 t = case yychar t of { + ';' -> YYAction 537; + ')' -> YYAction (-464); _ -> YYAction yyErr; }; -private yyaction413 t = case yychar t of { - ')' -> YYAction 530; +private yyaction420 t = case yychar t of { + ')' -> YYAction 538; _ -> YYAction yyErr; }; -private yyaction414 t = case yychar t of { - ',' -> YYAction 279; - ')' -> YYAction (-459); - ']' -> YYAction (-459); +private yyaction421 t = case yychar t of { + ',' -> YYAction 284; + ')' -> YYAction (-461); + ']' -> YYAction (-461); _ -> case yytoken t of { - DOTDOT -> YYAction (-459); + DOTDOT -> YYAction (-461); _ -> YYAction yyErr; }; }; -private yyaction415 t = case yychar t of { - ')' -> YYAction 531; +private yyaction422 t = case yychar t of { + ')' -> YYAction 539; _ -> YYAction yyErr; }; -private yyaction416 t = YYAction (-437); -private yyaction417 t = YYAction (-436); -private yyaction418 t = YYAction (-460); -private yyaction419 t = case yychar t of { - ',' -> YYAction 532; - ']' -> YYAction (-364); +private yyaction423 t = YYAction (-439); +private yyaction424 t = YYAction (-438); +private yyaction425 t = YYAction (-462); +private yyaction426 t = case yychar t of { + ',' -> YYAction 540; + ']' -> YYAction (-366); _ -> YYAction yyErr; }; -private yyaction420 t = case yychar t of { - ']' -> YYAction 533; +private yyaction427 t = case yychar t of { + ']' -> YYAction 541; _ -> YYAction yyErr; }; -private yyaction421 t = YYAction (-443); -private yyaction422 t = case yychar t of { - ']' -> YYAction 534; +private yyaction428 t = YYAction (-445); +private yyaction429 t = case yychar t of { + ']' -> YYAction 542; _ -> YYAction yyErr; }; -private yyaction423 t = YYAction (-386); -private yyaction424 t = YYAction (-341); -private yyaction425 t = case yychar t of { - '}' -> YYAction 535; +private yyaction430 t = YYAction (-388); +private yyaction431 t = YYAction (-343); +private yyaction432 t = case yychar t of { + '}' -> YYAction 543; _ -> YYAction yyBrace; }; -private yyaction426 t = case yychar t of { +private yyaction433 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -3873,43 +3918,43 @@ private yyaction426 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction427 t = YYAction (-429); -private yyaction428 t = case yychar t of { - '}' -> YYAction (-450); +private yyaction434 t = YYAction (-431); +private yyaction435 t = case yychar t of { + '}' -> YYAction (-452); _ -> case yytoken t of { - VARID -> YYAction 119; + VARID -> YYAction 121; _ -> YYAction yyBrace; }; }; -private yyaction429 t = case yychar t of { - '.' -> YYAction 539; +private yyaction436 t = case yychar t of { + '.' -> YYAction 547; _ -> case yytoken t of { - SOMEOP -> YYAction 538; + SOMEOP -> YYAction 546; _ -> YYAction yyErr; }; }; -private yyaction430 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction437 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; -private yyaction431 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction438 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; -private yyaction432 t = YYAction (-320); -private yyaction433 t = case yychar t of { +private yyaction439 t = YYAction (-322); +private yyaction440 t = case yychar t of { '-' -> YYAction 58; '(' -> YYAction 59; '[' -> YYAction 60; @@ -3921,7 +3966,7 @@ private yyaction433 t = case yychar t of { VARID -> YYAction 23; CONID -> YYAction 24; QUALIFIER -> YYAction 25; - NATIVE -> YYAction 151; + NATIVE -> YYAction 154; TRUE -> YYAction 38; FALSE -> YYAction 39; IF -> YYAction 40; @@ -3941,7 +3986,7 @@ private yyaction433 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction434 t = case yychar t of { +private yyaction441 t = case yychar t of { '-' -> YYAction 58; '(' -> YYAction 59; '[' -> YYAction 60; @@ -3953,7 +3998,7 @@ private yyaction434 t = case yychar t of { VARID -> YYAction 23; CONID -> YYAction 24; QUALIFIER -> YYAction 25; - NATIVE -> YYAction 151; + NATIVE -> YYAction 154; TRUE -> YYAction 38; FALSE -> YYAction 39; IF -> YYAction 40; @@ -3973,7 +4018,7 @@ private yyaction434 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction435 t = case yychar t of { +private yyaction442 t = case yychar t of { '-' -> YYAction 58; '(' -> YYAction 59; '[' -> YYAction 60; @@ -3985,7 +4030,7 @@ private yyaction435 t = case yychar t of { VARID -> YYAction 23; CONID -> YYAction 24; QUALIFIER -> YYAction 25; - NATIVE -> YYAction 151; + NATIVE -> YYAction 154; TRUE -> YYAction 38; FALSE -> YYAction 39; IF -> YYAction 40; @@ -4005,8 +4050,8 @@ private yyaction435 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction436 t = YYAction (-339); -private yyaction437 t = case yychar t of { +private yyaction443 t = YYAction (-341); +private yyaction444 t = case yychar t of { '-' -> YYAction 58; '(' -> YYAction 59; '[' -> YYAction 60; @@ -4014,23 +4059,23 @@ private yyaction437 t = case yychar t of { '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; - ';' -> YYAction (-131); - '}' -> YYAction (-131); + ';' -> YYAction (-132); + '}' -> YYAction (-132); _ -> case yytoken t of { VARID -> YYAction 23; CONID -> YYAction 24; QUALIFIER -> YYAction 25; DOCUMENTATION -> YYAction 26; - NATIVE -> YYAction 151; + NATIVE -> YYAction 154; TRUE -> YYAction 38; FALSE -> YYAction 39; IF -> YYAction 40; CASE -> YYAction 41; LET -> YYAction 43; DO -> YYAction 44; - PRIVATE -> YYAction 433; - PROTECTED -> YYAction 434; - PUBLIC -> YYAction 435; + PRIVATE -> YYAction 440; + PROTECTED -> YYAction 441; + PUBLIC -> YYAction 442; PURE -> YYAction 48; INTCONST -> YYAction 49; STRCONST -> YYAction 50; @@ -4044,28 +4089,28 @@ private yyaction437 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction438 t = YYAction (-127); -private yyaction439 t = case yychar t of { - '}' -> YYAction 548; +private yyaction445 t = YYAction (-128); +private yyaction446 t = case yychar t of { + '}' -> YYAction 556; _ -> YYAction yyBrace; }; -private yyaction440 t = case yychar t of { - ';' -> YYAction 549; - '}' -> YYAction (-121); +private yyaction447 t = case yychar t of { + ';' -> YYAction 557; + '}' -> YYAction (-122); _ -> YYAction yyBrace; }; -private yyaction441 t = YYAction (-133); -private yyaction442 t = case yychar t of { +private yyaction448 t = YYAction (-134); +private yyaction449 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; - '=' -> YYAction (-374); + '=' -> YYAction (-376); _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -4083,22 +4128,22 @@ private yyaction442 t = case yychar t of { CHRCONST -> YYAction 55; REGEXP -> YYAction 56; BIGCONST -> YYAction 57; - ARROW -> YYAction (-374); + ARROW -> YYAction (-376); _ -> YYAction yyErr; }; }; -private yyaction443 t = YYAction (-359); -private yyaction444 t = YYAction (-360); -private yyaction445 t = case yychar t of { +private yyaction450 t = YYAction (-361); +private yyaction451 t = YYAction (-362); +private yyaction452 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -4119,35 +4164,35 @@ private yyaction445 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction446 t = case yychar t of { - '?' -> YYAction 553; - '=' -> YYAction 554; - '}' -> YYAction (-456); - ',' -> YYAction (-456); +private yyaction453 t = case yychar t of { + '?' -> YYAction 561; + '=' -> YYAction 562; + '}' -> YYAction (-458); + ',' -> YYAction (-458); _ -> case yytoken t of { - GETS -> YYAction 552; + GETS -> YYAction 560; _ -> YYAction yyBrace; }; }; -private yyaction447 t = case yychar t of { - '}' -> YYAction 555; +private yyaction454 t = case yychar t of { + '}' -> YYAction 563; _ -> YYAction yyBrace; }; -private yyaction448 t = case yychar t of { - ']' -> YYAction 556; +private yyaction455 t = case yychar t of { + ']' -> YYAction 564; _ -> YYAction yyErr; }; -private yyaction449 t = case yychar t of { +private yyaction456 t = case yychar t of { '-' -> YYAction 58; - '}' -> YYAction 557; - '(' -> YYAction 144; + '}' -> YYAction 565; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -4168,21 +4213,21 @@ private yyaction449 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction450 t = case yychar t of { - '}' -> YYAction 559; +private yyaction457 t = case yychar t of { + '}' -> YYAction 567; _ -> YYAction yyBrace; }; -private yyaction451 t = case yychar t of { +private yyaction458 t = case yychar t of { '-' -> YYAction 58; - '}' -> YYAction 560; - '(' -> YYAction 144; + '}' -> YYAction 568; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -4203,158 +4248,158 @@ private yyaction451 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction452 t = YYAction (-418); -private yyaction453 t = case yychar t of { - '}' -> YYAction (-453); +private yyaction459 t = YYAction (-420); +private yyaction460 t = case yychar t of { + '}' -> YYAction (-455); _ -> case yytoken t of { - VARID -> YYAction 562; + VARID -> YYAction 570; _ -> YYAction yyBrace; }; }; -private yyaction454 t = YYAction (-2); -private yyaction455 t = case yychar t of { +private yyaction461 t = YYAction (-2); +private yyaction462 t = case yychar t of { '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 110; + VARID -> YYAction 112; _ -> YYAction yyErr; }; }; -private yyaction456 t = YYAction (-187); -private yyaction457 t = YYAction (-22); -private yyaction458 t = case yychar t of { +private yyaction463 t = YYAction (-188); +private yyaction464 t = YYAction (-22); +private yyaction465 t = case yychar t of { '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 110; - QUALIFIER -> YYAction 320; - SOMEOP -> YYAction 121; + VARID -> YYAction 112; + QUALIFIER -> YYAction 325; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction459 t = YYAction (-140); -private yyaction460 t = case yychar t of { - ')' -> YYAction 567; +private yyaction466 t = YYAction (-141); +private yyaction467 t = case yychar t of { + ')' -> YYAction 575; _ -> case yytoken t of { - VARID -> YYAction 465; - CONID -> YYAction 466; - PUBLIC -> YYAction 566; - SOMEOP -> YYAction 121; + VARID -> YYAction 472; + CONID -> YYAction 473; + PUBLIC -> YYAction 574; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction461 t = case yychar t of { +private yyaction468 t = case yychar t of { '?' -> YYAction 61; '!' -> YYAction 62; _ -> case yytoken t of { - VARID -> YYAction 110; - CONID -> YYAction 199; + VARID -> YYAction 112; + CONID -> YYAction 203; _ -> YYAction yyErr; }; }; -private yyaction462 t = YYAction (-158); -private yyaction463 t = YYAction (-145); -private yyaction464 t = case yychar t of { +private yyaction469 t = YYAction (-159); +private yyaction470 t = YYAction (-146); +private yyaction471 t = case yychar t of { '?' -> YYAction 61; '!' -> YYAction 62; - ')' -> YYAction (-148); + ')' -> YYAction (-149); _ -> case yytoken t of { - VARID -> YYAction 143; - CONID -> YYAction 328; - QUALIFIER -> YYAction 329; - PUBLIC -> YYAction 330; - SOMEOP -> YYAction 121; + VARID -> YYAction 146; + CONID -> YYAction 333; + QUALIFIER -> YYAction 334; + PUBLIC -> YYAction 335; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction465 t = YYAction (-165); -private yyaction466 t = YYAction (-166); -private yyaction467 t = YYAction (-167); -private yyaction468 t = YYAction (-157); -private yyaction469 t = case yychar t of { - ')' -> YYAction 572; +private yyaction472 t = YYAction (-166); +private yyaction473 t = YYAction (-167); +private yyaction474 t = YYAction (-168); +private yyaction475 t = YYAction (-158); +private yyaction476 t = case yychar t of { + ')' -> YYAction 580; _ -> YYAction yyErr; }; -private yyaction470 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction477 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction471 t = YYAction (-44); -private yyaction472 t = case yychar t of { - '{' -> YYAction 574; +private yyaction478 t = YYAction (-44); +private yyaction479 t = case yychar t of { + '{' -> YYAction 582; _ -> YYAction yyErr; }; -private yyaction473 t = YYAction (-40); -private yyaction474 t = YYAction (-8); -private yyaction475 t = YYAction (-9); -private yyaction476 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction480 t = YYAction (-40); +private yyaction481 t = YYAction (-8); +private yyaction482 t = YYAction (-9); +private yyaction483 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction477 t = YYAction (-287); -private yyaction478 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction484 t = YYAction (-289); +private yyaction485 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction479 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction486 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction480 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction487 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction481 t = case yychar t of { - '(' -> YYAction 580; +private yyaction488 t = case yychar t of { + '(' -> YYAction 588; _ -> case yytoken t of { - SOMEOP -> YYAction 579; + SOMEOP -> YYAction 587; _ -> YYAction yyErr; }; }; -private yyaction482 t = case yychar t of { - ')' -> YYAction 583; +private yyaction489 t = case yychar t of { + ')' -> YYAction 591; _ -> YYAction yyErr; }; -private yyaction483 t = case yychar t of { - ')' -> YYAction 584; +private yyaction490 t = case yychar t of { + ')' -> YYAction 592; _ -> YYAction yyErr; }; -private yyaction484 t = case yychar t of { +private yyaction491 t = case yychar t of { '?' -> YYAction (-18); '!' -> YYAction (-18); _ -> case yytoken t of { @@ -4365,139 +4410,151 @@ private yyaction484 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction485 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction492 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; -private yyaction486 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction493 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; + QUALIFIER -> YYAction 133; _ -> YYAction yyErr; }; }; -private yyaction487 t = YYAction (-318); -private yyaction488 t = YYAction (-312); -private yyaction489 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; - '?' -> YYAction 485; - '!' -> YYAction 486; - ';' -> YYAction (-313); - '}' -> YYAction (-313); - '|' -> YYAction (-313); - _ -> case yytoken t of { - VARID -> YYAction 225; +private yyaction494 t = YYAction (-320); +private yyaction495 t = YYAction (-314); +private yyaction496 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; + '?' -> YYAction 492; + '!' -> YYAction 493; + ';' -> YYAction (-315); + '}' -> YYAction (-315); + '|' -> YYAction (-315); + _ -> case yytoken t of { + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - DOCUMENTATION -> YYAction (-313); - WHERE -> YYAction (-313); + QUALIFIER -> YYAction 133; + DOCUMENTATION -> YYAction (-315); + WHERE -> YYAction (-315); _ -> YYAction yyBrace; }; }; -private yyaction490 t = YYAction (-315); -private yyaction491 t = YYAction (-302); -private yyaction492 t = YYAction (-305); -private yyaction493 t = YYAction (-306); -private yyaction494 t = YYAction (-304); -private yyaction495 t = YYAction (-308); -private yyaction496 t = YYAction (-307); -private yyaction497 t = YYAction (-301); -private yyaction498 t = YYAction (-294); -private yyaction499 t = YYAction (-283); -private yyaction500 t = case yychar t of { - '{' -> YYAction 217; - ';' -> YYAction (-285); - '}' -> YYAction (-285); - _ -> case yytoken t of { - WHERE -> YYAction (-285); +private yyaction497 t = YYAction (-317); +private yyaction498 t = YYAction (-304); +private yyaction499 t = YYAction (-307); +private yyaction500 t = YYAction (-308); +private yyaction501 t = YYAction (-306); +private yyaction502 t = YYAction (-310); +private yyaction503 t = YYAction (-309); +private yyaction504 t = YYAction (-303); +private yyaction505 t = YYAction (-294); +private yyaction506 t = YYAction (-285); +private yyaction507 t = case yychar t of { + '{' -> YYAction 221; + ';' -> YYAction (-287); + '}' -> YYAction (-287); + _ -> case yytoken t of { + WHERE -> YYAction (-287); _ -> YYAction yyBrace; }; }; -private yyaction501 t = YYAction (-289); -private yyaction502 t = case yychar t of { - '?' -> YYAction 366; - '!' -> YYAction 367; +private yyaction508 t = YYAction (-296); +private yyaction509 t = case yychar t of { + '?' -> YYAction 371; + '!' -> YYAction 372; _ -> case yytoken t of { - CONID -> YYAction 361; - DOCUMENTATION -> YYAction 362; - PRIVATE -> YYAction 363; - PROTECTED -> YYAction 364; - PUBLIC -> YYAction 365; + CONID -> YYAction 366; + DOCUMENTATION -> YYAction 367; + PRIVATE -> YYAction 368; + PROTECTED -> YYAction 369; + PUBLIC -> YYAction 370; _ -> YYAction yyErr; }; }; -private yyaction503 t = case yytoken t of { - VARID -> YYAction 212; - CONID -> YYAction 213; - QUALIFIER -> YYAction 214; - PACKAGE -> YYAction 215; - STRCONST -> YYAction 216; +private yyaction510 t = case yytoken t of { + VARID -> YYAction 216; + CONID -> YYAction 217; + QUALIFIER -> YYAction 218; + PACKAGE -> YYAction 219; + STRCONST -> YYAction 220; _ -> YYAction yyErr; }; -private yyaction504 t = YYAction (-291); -private yyaction505 t = YYAction (-267); -private yyaction506 t = case yychar t of { - ';' -> YYAction (-338); - '}' -> YYAction (-338); +private yyaction511 t = YYAction (-291); +private yyaction512 t = YYAction (-268); +private yyaction513 t = case yychar t of { + ';' -> YYAction (-340); + '}' -> YYAction (-340); _ -> case yytoken t of { - WHERE -> YYAction 183; + WHERE -> YYAction 186; _ -> YYAction yyBrace; }; }; -private yyaction507 t = YYAction (-275); -private yyaction508 t = YYAction (-259); -private yyaction509 t = YYAction (-246); -private yyaction510 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction514 t = YYAction (-276); +private yyaction515 t = YYAction (-260); +private yyaction516 t = YYAction (-247); +private yyaction517 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction511 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction518 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; _ -> YYAction yyErr; }; }; -private yyaction512 t = YYAction (-258); -private yyaction513 t = YYAction (-249); -private yyaction514 t = YYAction (-278); -private yyaction515 t = YYAction (-337); -private yyaction516 t = YYAction (-392); -private yyaction517 t = case yytoken t of { - ELSE -> YYAction 598; +private yyaction519 t = YYAction (-259); +private yyaction520 t = YYAction (-250); +private yyaction521 t = YYAction (-279); +private yyaction522 t = case yychar t of { + '?' -> YYAction 371; + '!' -> YYAction 372; + _ -> case yytoken t of { + CONID -> YYAction 366; + DOCUMENTATION -> YYAction 367; + PRIVATE -> YYAction 368; + PROTECTED -> YYAction 369; + PUBLIC -> YYAction 370; _ -> YYAction yyErr; }; -private yyaction518 t = case yychar t of { +}; +private yyaction523 t = YYAction (-339); +private yyaction524 t = YYAction (-394); +private yyaction525 t = case yytoken t of { + ELSE -> YYAction 606; + _ -> YYAction yyErr; + }; +private yyaction526 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -4518,38 +4575,38 @@ private yyaction518 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction519 t = YYAction (-358); -private yyaction520 t = case yychar t of { - '|' -> YYAction 185; - '=' -> YYAction 444; +private yyaction527 t = YYAction (-360); +private yyaction528 t = case yychar t of { + '|' -> YYAction 189; + '=' -> YYAction 451; _ -> case yytoken t of { - ARROW -> YYAction 443; + ARROW -> YYAction 450; _ -> YYAction yyErr; }; }; -private yyaction521 t = case yychar t of { - ';' -> YYAction 602; - '}' -> YYAction (-381); +private yyaction529 t = case yychar t of { + ';' -> YYAction 610; + '}' -> YYAction (-383); _ -> case yytoken t of { - WHERE -> YYAction 172; + WHERE -> YYAction 175; _ -> YYAction yyBrace; }; }; -private yyaction522 t = case yychar t of { - '}' -> YYAction 604; +private yyaction530 t = case yychar t of { + '}' -> YYAction 612; _ -> YYAction yyBrace; }; -private yyaction523 t = YYAction (-138); -private yyaction524 t = case yychar t of { +private yyaction531 t = YYAction (-139); +private yyaction532 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -4570,24 +4627,24 @@ private yyaction524 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction525 t = case yychar t of { - '}' -> YYAction 606; +private yyaction533 t = case yychar t of { + '}' -> YYAction 614; _ -> YYAction yyBrace; }; -private yyaction526 t = YYAction (-371); -private yyaction527 t = YYAction (-362); -private yyaction528 t = YYAction (-369); -private yyaction529 t = case yychar t of { +private yyaction534 t = YYAction (-373); +private yyaction535 t = YYAction (-364); +private yyaction536 t = YYAction (-371); +private yyaction537 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; - ')' -> YYAction (-464); + ')' -> YYAction (-466); _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -4608,26 +4665,26 @@ private yyaction529 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction530 t = YYAction (-439); -private yyaction531 t = YYAction (-438); -private yyaction532 t = case yychar t of { +private yyaction538 t = YYAction (-441); +private yyaction539 t = YYAction (-440); +private yyaction540 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; - ']' -> YYAction (-366); + ']' -> YYAction (-368); _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; FALSE -> YYAction 39; IF -> YYAction 40; CASE -> YYAction 41; - LET -> YYAction 262; + LET -> YYAction 267; DO -> YYAction 44; INTCONST -> YYAction 49; STRCONST -> YYAction 50; @@ -4641,56 +4698,56 @@ private yyaction532 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction533 t = YYAction (-445); -private yyaction534 t = YYAction (-444); -private yyaction535 t = YYAction (-342); -private yyaction536 t = YYAction (-457); -private yyaction537 t = YYAction (-449); -private yyaction538 t = YYAction (-231); -private yyaction539 t = YYAction (-230); -private yyaction540 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction541 t = YYAction (-447); +private yyaction542 t = YYAction (-446); +private yyaction543 t = YYAction (-344); +private yyaction544 t = YYAction (-459); +private yyaction545 t = YYAction (-451); +private yyaction546 t = YYAction (-232); +private yyaction547 t = YYAction (-231); +private yyaction548 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - _ -> YYAction yyErr; - }; -}; -private yyaction541 t = case yychar t of { - '-' -> YYAction (-234); - ';' -> YYAction (-234); - '}' -> YYAction (-234); - ')' -> YYAction (-234); - ',' -> YYAction (-234); - '|' -> YYAction (-234); - ']' -> YYAction (-234); - '=' -> YYAction (-234); - _ -> case yytoken t of { - ARROW -> YYAction 430; - DOCUMENTATION -> YYAction (-234); - WHERE -> YYAction (-234); - CLASS -> YYAction (-234); - THEN -> YYAction (-234); - ELSE -> YYAction (-234); - OF -> YYAction (-234); - THROWS -> YYAction (-234); - DCOLON -> YYAction (-234); - GETS -> YYAction (-234); - DOTDOT -> YYAction (-234); - SOMEOP -> YYAction (-234); - _ -> YYAction yyBrace; + QUALIFIER -> YYAction 133; + _ -> YYAction yyErr; }; }; -private yyaction542 t = YYAction (-235); -private yyaction543 t = YYAction (-232); -private yyaction544 t = YYAction (-128); -private yyaction545 t = YYAction (-129); -private yyaction546 t = YYAction (-130); -private yyaction547 t = YYAction (-132); -private yyaction548 t = YYAction (-340); private yyaction549 t = case yychar t of { + '-' -> YYAction (-235); + ';' -> YYAction (-235); + '}' -> YYAction (-235); + ')' -> YYAction (-235); + ',' -> YYAction (-235); + '|' -> YYAction (-235); + ']' -> YYAction (-235); + '=' -> YYAction (-235); + _ -> case yytoken t of { + ARROW -> YYAction 437; + DOCUMENTATION -> YYAction (-235); + WHERE -> YYAction (-235); + CLASS -> YYAction (-235); + THEN -> YYAction (-235); + ELSE -> YYAction (-235); + OF -> YYAction (-235); + THROWS -> YYAction (-235); + DCOLON -> YYAction (-235); + GETS -> YYAction (-235); + DOTDOT -> YYAction (-235); + SOMEOP -> YYAction (-235); + _ -> YYAction yyBrace; + }; +}; +private yyaction550 t = YYAction (-236); +private yyaction551 t = YYAction (-233); +private yyaction552 t = YYAction (-129); +private yyaction553 t = YYAction (-130); +private yyaction554 t = YYAction (-131); +private yyaction555 t = YYAction (-133); +private yyaction556 t = YYAction (-342); +private yyaction557 t = case yychar t of { '-' -> YYAction 58; '(' -> YYAction 59; '[' -> YYAction 60; @@ -4698,22 +4755,22 @@ private yyaction549 t = case yychar t of { '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; - '}' -> YYAction (-122); + '}' -> YYAction (-123); _ -> case yytoken t of { VARID -> YYAction 23; CONID -> YYAction 24; QUALIFIER -> YYAction 25; DOCUMENTATION -> YYAction 26; - NATIVE -> YYAction 151; + NATIVE -> YYAction 154; TRUE -> YYAction 38; FALSE -> YYAction 39; IF -> YYAction 40; CASE -> YYAction 41; LET -> YYAction 43; DO -> YYAction 44; - PRIVATE -> YYAction 433; - PROTECTED -> YYAction 434; - PUBLIC -> YYAction 435; + PRIVATE -> YYAction 440; + PROTECTED -> YYAction 441; + PUBLIC -> YYAction 442; PURE -> YYAction 48; INTCONST -> YYAction 49; STRCONST -> YYAction 50; @@ -4727,19 +4784,19 @@ private yyaction549 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction550 t = YYAction (-373); -private yyaction551 t = YYAction (-375); -private yyaction552 t = case yychar t of { +private yyaction558 t = YYAction (-375); +private yyaction559 t = YYAction (-377); +private yyaction560 t = case yychar t of { '-' -> YYAction 58; - '}' -> YYAction 611; - '(' -> YYAction 144; + '}' -> YYAction 619; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -4760,21 +4817,21 @@ private yyaction552 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction553 t = case yychar t of { - '}' -> YYAction 612; +private yyaction561 t = case yychar t of { + '}' -> YYAction 620; _ -> YYAction yyBrace; }; -private yyaction554 t = case yychar t of { +private yyaction562 t = case yychar t of { '-' -> YYAction 58; - '}' -> YYAction 613; - '(' -> YYAction 144; + '}' -> YYAction 621; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -4795,206 +4852,206 @@ private yyaction554 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction555 t = YYAction (-422); -private yyaction556 t = YYAction (-423); -private yyaction557 t = YYAction (-417); -private yyaction558 t = YYAction (-454); -private yyaction559 t = YYAction (-415); -private yyaction560 t = YYAction (-416); -private yyaction561 t = YYAction (-455); -private yyaction562 t = case yychar t of { - '=' -> YYAction 615; - '}' -> YYAction (-456); - ',' -> YYAction (-456); +private yyaction563 t = YYAction (-424); +private yyaction564 t = YYAction (-425); +private yyaction565 t = YYAction (-419); +private yyaction566 t = YYAction (-456); +private yyaction567 t = YYAction (-417); +private yyaction568 t = YYAction (-418); +private yyaction569 t = YYAction (-457); +private yyaction570 t = case yychar t of { + '=' -> YYAction 623; + '}' -> YYAction (-458); + ',' -> YYAction (-458); _ -> case yytoken t of { - GETS -> YYAction 614; + GETS -> YYAction 622; _ -> YYAction yyBrace; }; }; -private yyaction563 t = YYAction (-452); -private yyaction564 t = YYAction (-186); -private yyaction565 t = YYAction (-177); -private yyaction566 t = case yytoken t of { - VARID -> YYAction 465; - CONID -> YYAction 466; - PUBLIC -> YYAction 566; - SOMEOP -> YYAction 121; +private yyaction571 t = YYAction (-454); +private yyaction572 t = YYAction (-187); +private yyaction573 t = YYAction (-178); +private yyaction574 t = case yytoken t of { + VARID -> YYAction 472; + CONID -> YYAction 473; + PUBLIC -> YYAction 574; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; -private yyaction567 t = YYAction (-152); -private yyaction568 t = case yychar t of { - ')' -> YYAction 617; +private yyaction575 t = YYAction (-153); +private yyaction576 t = case yychar t of { + ')' -> YYAction 625; _ -> YYAction yyErr; }; -private yyaction569 t = case yychar t of { - ')' -> YYAction (-159); - ',' -> YYAction (-159); +private yyaction577 t = case yychar t of { + ')' -> YYAction (-160); + ',' -> YYAction (-160); _ -> case yytoken t of { - VARID -> YYAction 465; - CONID -> YYAction 466; - SOMEOP -> YYAction 121; + VARID -> YYAction 472; + CONID -> YYAction 473; + SOMEOP -> YYAction 123; _ -> YYAction yyErr; }; }; -private yyaction570 t = case yychar t of { - ',' -> YYAction 619; - ')' -> YYAction (-162); +private yyaction578 t = case yychar t of { + ',' -> YYAction 627; + ')' -> YYAction (-163); _ -> YYAction yyErr; }; -private yyaction571 t = YYAction (-149); -private yyaction572 t = YYAction (-143); -private yyaction573 t = YYAction (-238); -private yyaction574 t = case yychar t of { - '-' -> YYAction 668; - ';' -> YYAction 669; - '{' -> YYAction 670; - '}' -> YYAction 671; - '.' -> YYAction 672; - '(' -> YYAction 673; - ')' -> YYAction 674; - ',' -> YYAction 675; - '|' -> YYAction 676; - '[' -> YYAction 677; - ']' -> YYAction 678; - '?' -> YYAction 679; - '!' -> YYAction 680; - '=' -> YYAction 681; - '\\' -> YYAction 682; - _ -> case yytoken t of { - VARID -> YYAction 620; - CONID -> YYAction 621; - QUALIFIER -> YYAction 622; - DOCUMENTATION -> YYAction 623; - EXTENDS -> YYAction 624; - SUPER -> YYAction 625; - PACKAGE -> YYAction 626; - IMPORT -> YYAction 627; - INFIX -> YYAction 628; - INFIXR -> YYAction 629; - INFIXL -> YYAction 630; - NATIVE -> YYAction 631; - DATA -> YYAction 632; - WHERE -> YYAction 633; - CLASS -> YYAction 634; - INSTANCE -> YYAction 635; - ABSTRACT -> YYAction 636; - TYPE -> YYAction 637; - TRUE -> YYAction 638; - FALSE -> YYAction 639; - IF -> YYAction 640; - THEN -> YYAction 641; - ELSE -> YYAction 642; - CASE -> YYAction 643; - OF -> YYAction 644; - DERIVE -> YYAction 645; - LET -> YYAction 646; - IN -> YYAction 647; - DO -> YYAction 648; - FORALL -> YYAction 649; - PRIVATE -> YYAction 650; - PROTECTED -> YYAction 651; - PUBLIC -> YYAction 652; - PURE -> YYAction 653; - THROWS -> YYAction 654; - MUTABLE -> YYAction 655; - INTCONST -> YYAction 656; - STRCONST -> YYAction 657; - LONGCONST -> YYAction 658; - FLTCONST -> YYAction 659; - DBLCONST -> YYAction 660; - CHRCONST -> YYAction 661; - ARROW -> YYAction 662; - DCOLON -> YYAction 663; - GETS -> YYAction 664; - EARROW -> YYAction 665; - DOTDOT -> YYAction 666; - SOMEOP -> YYAction 667; +private yyaction579 t = YYAction (-150); +private yyaction580 t = YYAction (-144); +private yyaction581 t = YYAction (-239); +private yyaction582 t = case yychar t of { + '-' -> YYAction 676; + ';' -> YYAction 677; + '{' -> YYAction 678; + '}' -> YYAction 679; + '.' -> YYAction 680; + '(' -> YYAction 681; + ')' -> YYAction 682; + ',' -> YYAction 683; + '|' -> YYAction 684; + '[' -> YYAction 685; + ']' -> YYAction 686; + '?' -> YYAction 687; + '!' -> YYAction 688; + '=' -> YYAction 689; + '\\' -> YYAction 690; + _ -> case yytoken t of { + VARID -> YYAction 628; + CONID -> YYAction 629; + QUALIFIER -> YYAction 630; + DOCUMENTATION -> YYAction 631; + EXTENDS -> YYAction 632; + SUPER -> YYAction 633; + PACKAGE -> YYAction 634; + IMPORT -> YYAction 635; + INFIX -> YYAction 636; + INFIXR -> YYAction 637; + INFIXL -> YYAction 638; + NATIVE -> YYAction 639; + DATA -> YYAction 640; + WHERE -> YYAction 641; + CLASS -> YYAction 642; + INSTANCE -> YYAction 643; + ABSTRACT -> YYAction 644; + TYPE -> YYAction 645; + TRUE -> YYAction 646; + FALSE -> YYAction 647; + IF -> YYAction 648; + THEN -> YYAction 649; + ELSE -> YYAction 650; + CASE -> YYAction 651; + OF -> YYAction 652; + DERIVE -> YYAction 653; + LET -> YYAction 654; + IN -> YYAction 655; + DO -> YYAction 656; + FORALL -> YYAction 657; + PRIVATE -> YYAction 658; + PROTECTED -> YYAction 659; + PUBLIC -> YYAction 660; + PURE -> YYAction 661; + THROWS -> YYAction 662; + MUTABLE -> YYAction 663; + INTCONST -> YYAction 664; + STRCONST -> YYAction 665; + LONGCONST -> YYAction 666; + FLTCONST -> YYAction 667; + DBLCONST -> YYAction 668; + CHRCONST -> YYAction 669; + ARROW -> YYAction 670; + DCOLON -> YYAction 671; + GETS -> YYAction 672; + EARROW -> YYAction 673; + DOTDOT -> YYAction 674; + SOMEOP -> YYAction 675; _ -> YYAction yyBrace; }; }; -private yyaction575 t = YYAction (-240); -private yyaction576 t = YYAction (-222); -private yyaction577 t = YYAction (-225); -private yyaction578 t = case yychar t of { - ')' -> YYAction 685; +private yyaction583 t = YYAction (-241); +private yyaction584 t = YYAction (-223); +private yyaction585 t = YYAction (-226); +private yyaction586 t = case yychar t of { + ')' -> YYAction 693; _ -> YYAction yyErr; }; -private yyaction579 t = YYAction (-262); -private yyaction580 t = case yychar t of { - '(' -> YYAction 580; +private yyaction587 t = YYAction (-263); +private yyaction588 t = case yychar t of { + '(' -> YYAction 588; _ -> case yytoken t of { - SOMEOP -> YYAction 579; + SOMEOP -> YYAction 587; _ -> YYAction yyErr; }; }; -private yyaction581 t = case yychar t of { - ')' -> YYAction 687; +private yyaction589 t = case yychar t of { + ')' -> YYAction 695; _ -> YYAction yyErr; }; -private yyaction582 t = case yychar t of { - ')' -> YYAction (-261); +private yyaction590 t = case yychar t of { + ')' -> YYAction (-262); _ -> case yytoken t of { - ARROW -> YYAction 688; + ARROW -> YYAction 696; _ -> YYAction yyErr; }; }; -private yyaction583 t = YYAction (-253); -private yyaction584 t = YYAction (-254); -private yyaction585 t = case yychar t of { - '?' -> YYAction 691; - '!' -> YYAction 692; +private yyaction591 t = YYAction (-254); +private yyaction592 t = YYAction (-255); +private yyaction593 t = case yychar t of { + '?' -> YYAction 699; + '!' -> YYAction 700; _ -> case yytoken t of { - VARID -> YYAction 119; - PRIVATE -> YYAction 689; - PUBLIC -> YYAction 690; + VARID -> YYAction 121; + PRIVATE -> YYAction 697; + PUBLIC -> YYAction 698; _ -> YYAction yyErr; }; }; -private yyaction586 t = case yychar t of { - '}' -> YYAction 698; +private yyaction594 t = case yychar t of { + '}' -> YYAction 706; _ -> YYAction yyBrace; }; -private yyaction587 t = case yychar t of { - ',' -> YYAction 700; - '}' -> YYAction (-321); +private yyaction595 t = case yychar t of { + ',' -> YYAction 708; + '}' -> YYAction (-323); _ -> case yytoken t of { - DOCUMENTATION -> YYAction 699; + DOCUMENTATION -> YYAction 707; _ -> YYAction yyBrace; }; }; -private yyaction588 t = YYAction (-317); -private yyaction589 t = YYAction (-316); -private yyaction590 t = YYAction (-314); -private yyaction591 t = YYAction (-286); -private yyaction592 t = YYAction (-299); -private yyaction593 t = YYAction (-290); -private yyaction594 t = YYAction (-270); -private yyaction595 t = case yychar t of { - ')' -> YYAction 701; +private yyaction596 t = YYAction (-319); +private yyaction597 t = YYAction (-318); +private yyaction598 t = YYAction (-316); +private yyaction599 t = YYAction (-288); +private yyaction600 t = YYAction (-301); +private yyaction601 t = YYAction (-297); +private yyaction602 t = YYAction (-271); +private yyaction603 t = case yychar t of { + ')' -> YYAction 709; _ -> YYAction yyErr; }; -private yyaction596 t = case yychar t of { - '|' -> YYAction 702; - ')' -> YYAction (-241); +private yyaction604 t = case yychar t of { + '|' -> YYAction 710; + ')' -> YYAction (-242); _ -> YYAction yyErr; }; -private yyaction597 t = case yychar t of { - ')' -> YYAction 703; +private yyaction605 t = case yychar t of { + ')' -> YYAction 711; _ -> YYAction yyErr; }; -private yyaction598 t = YYAction (-391); -private yyaction599 t = YYAction (-397); -private yyaction600 t = YYAction (-379); -private yyaction601 t = case yychar t of { +private yyaction606 t = YYAction (-393); +private yyaction607 t = YYAction (-399); +private yyaction608 t = YYAction (-381); +private yyaction609 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -5015,17 +5072,17 @@ private yyaction601 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction602 t = case yychar t of { +private yyaction610 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; - '}' -> YYAction (-383); + '}' -> YYAction (-385); _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -5046,36 +5103,36 @@ private yyaction602 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction603 t = YYAction (-380); -private yyaction604 t = YYAction (-398); -private yyaction605 t = YYAction (-399); -private yyaction606 t = case yychar t of { - ';' -> YYAction (-363); - '}' -> YYAction (-363); - ',' -> YYAction (-363); - ']' -> YYAction (-363); +private yyaction611 t = YYAction (-382); +private yyaction612 t = YYAction (-400); +private yyaction613 t = YYAction (-401); +private yyaction614 t = case yychar t of { + ';' -> YYAction (-365); + '}' -> YYAction (-365); + ',' -> YYAction (-365); + ']' -> YYAction (-365); _ -> case yytoken t of { - IN -> YYAction 524; + IN -> YYAction 532; _ -> YYAction yyBrace; }; }; -private yyaction607 t = YYAction (-463); -private yyaction608 t = YYAction (-365); -private yyaction609 t = YYAction (-229); -private yyaction610 t = YYAction (-123); -private yyaction611 t = YYAction (-421); -private yyaction612 t = YYAction (-419); -private yyaction613 t = YYAction (-420); -private yyaction614 t = case yychar t of { +private yyaction615 t = YYAction (-465); +private yyaction616 t = YYAction (-367); +private yyaction617 t = YYAction (-230); +private yyaction618 t = YYAction (-124); +private yyaction619 t = YYAction (-423); +private yyaction620 t = YYAction (-421); +private yyaction621 t = YYAction (-422); +private yyaction622 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -5096,16 +5153,16 @@ private yyaction614 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction615 t = case yychar t of { +private yyaction623 t = case yychar t of { '-' -> YYAction 58; - '(' -> YYAction 144; + '(' -> YYAction 147; '[' -> YYAction 60; '?' -> YYAction 61; '!' -> YYAction 62; '\\' -> YYAction 63; '_' -> YYAction 64; _ -> case yytoken t of { - VARID -> YYAction 143; + VARID -> YYAction 146; CONID -> YYAction 24; QUALIFIER -> YYAction 25; TRUE -> YYAction 38; @@ -5126,275 +5183,275 @@ private yyaction615 t = case yychar t of { _ -> YYAction yyErr; }; }; -private yyaction616 t = YYAction (-161); -private yyaction617 t = YYAction (-151); -private yyaction618 t = YYAction (-160); -private yyaction619 t = case yychar t of { - ')' -> YYAction (-163); - _ -> case yytoken t of { - VARID -> YYAction 465; - CONID -> YYAction 466; - PUBLIC -> YYAction 566; - SOMEOP -> YYAction 121; - _ -> YYAction yyErr; - }; -}; -private yyaction620 t = YYAction (-47); -private yyaction621 t = YYAction (-48); -private yyaction622 t = YYAction (-49); -private yyaction623 t = YYAction (-52); -private yyaction624 t = YYAction (-50); -private yyaction625 t = YYAction (-51); -private yyaction626 t = YYAction (-53); -private yyaction627 t = YYAction (-54); -private yyaction628 t = YYAction (-55); -private yyaction629 t = YYAction (-56); -private yyaction630 t = YYAction (-57); -private yyaction631 t = YYAction (-58); -private yyaction632 t = YYAction (-59); -private yyaction633 t = YYAction (-60); -private yyaction634 t = YYAction (-61); -private yyaction635 t = YYAction (-62); -private yyaction636 t = YYAction (-63); -private yyaction637 t = YYAction (-64); -private yyaction638 t = YYAction (-65); -private yyaction639 t = YYAction (-66); -private yyaction640 t = YYAction (-67); -private yyaction641 t = YYAction (-68); -private yyaction642 t = YYAction (-69); -private yyaction643 t = YYAction (-70); -private yyaction644 t = YYAction (-71); -private yyaction645 t = YYAction (-72); -private yyaction646 t = YYAction (-73); -private yyaction647 t = YYAction (-74); -private yyaction648 t = YYAction (-75); -private yyaction649 t = YYAction (-76); -private yyaction650 t = YYAction (-77); -private yyaction651 t = YYAction (-78); -private yyaction652 t = YYAction (-79); -private yyaction653 t = YYAction (-80); -private yyaction654 t = YYAction (-81); -private yyaction655 t = YYAction (-82); -private yyaction656 t = YYAction (-83); -private yyaction657 t = YYAction (-84); -private yyaction658 t = YYAction (-85); -private yyaction659 t = YYAction (-86); -private yyaction660 t = YYAction (-87); -private yyaction661 t = YYAction (-88); -private yyaction662 t = YYAction (-89); -private yyaction663 t = YYAction (-90); -private yyaction664 t = YYAction (-91); -private yyaction665 t = YYAction (-92); -private yyaction666 t = YYAction (-93); -private yyaction667 t = YYAction (-94); -private yyaction668 t = YYAction (-103); -private yyaction669 t = YYAction (-104); -private yyaction670 t = case yychar t of { - '-' -> YYAction 668; - ';' -> YYAction 669; - '{' -> YYAction 670; - '}' -> YYAction 707; - '.' -> YYAction 672; - '(' -> YYAction 673; - ')' -> YYAction 674; - ',' -> YYAction 675; - '|' -> YYAction 676; - '[' -> YYAction 677; - ']' -> YYAction 678; - '?' -> YYAction 679; - '!' -> YYAction 680; - '=' -> YYAction 681; - '\\' -> YYAction 682; - _ -> case yytoken t of { - VARID -> YYAction 620; - CONID -> YYAction 621; - QUALIFIER -> YYAction 622; - DOCUMENTATION -> YYAction 623; - EXTENDS -> YYAction 624; - SUPER -> YYAction 625; - PACKAGE -> YYAction 626; - IMPORT -> YYAction 627; - INFIX -> YYAction 628; - INFIXR -> YYAction 629; - INFIXL -> YYAction 630; - NATIVE -> YYAction 631; - DATA -> YYAction 632; - WHERE -> YYAction 633; - CLASS -> YYAction 634; - INSTANCE -> YYAction 635; - ABSTRACT -> YYAction 636; - TYPE -> YYAction 637; - TRUE -> YYAction 638; - FALSE -> YYAction 639; - IF -> YYAction 640; - THEN -> YYAction 641; - ELSE -> YYAction 642; - CASE -> YYAction 643; - OF -> YYAction 644; - DERIVE -> YYAction 645; - LET -> YYAction 646; - IN -> YYAction 647; - DO -> YYAction 648; - FORALL -> YYAction 649; - PRIVATE -> YYAction 650; - PROTECTED -> YYAction 651; - PUBLIC -> YYAction 652; - PURE -> YYAction 653; - THROWS -> YYAction 654; - MUTABLE -> YYAction 655; - INTCONST -> YYAction 656; - STRCONST -> YYAction 657; - LONGCONST -> YYAction 658; - FLTCONST -> YYAction 659; - DBLCONST -> YYAction 660; - CHRCONST -> YYAction 661; - ARROW -> YYAction 662; - DCOLON -> YYAction 663; - GETS -> YYAction 664; - EARROW -> YYAction 665; - DOTDOT -> YYAction 666; - SOMEOP -> YYAction 667; +private yyaction624 t = YYAction (-162); +private yyaction625 t = YYAction (-152); +private yyaction626 t = YYAction (-161); +private yyaction627 t = case yychar t of { + ')' -> YYAction (-164); + _ -> case yytoken t of { + VARID -> YYAction 472; + CONID -> YYAction 473; + PUBLIC -> YYAction 574; + SOMEOP -> YYAction 123; + _ -> YYAction yyErr; + }; +}; +private yyaction628 t = YYAction (-47); +private yyaction629 t = YYAction (-48); +private yyaction630 t = YYAction (-49); +private yyaction631 t = YYAction (-52); +private yyaction632 t = YYAction (-50); +private yyaction633 t = YYAction (-51); +private yyaction634 t = YYAction (-53); +private yyaction635 t = YYAction (-54); +private yyaction636 t = YYAction (-55); +private yyaction637 t = YYAction (-56); +private yyaction638 t = YYAction (-57); +private yyaction639 t = YYAction (-58); +private yyaction640 t = YYAction (-59); +private yyaction641 t = YYAction (-60); +private yyaction642 t = YYAction (-61); +private yyaction643 t = YYAction (-62); +private yyaction644 t = YYAction (-63); +private yyaction645 t = YYAction (-64); +private yyaction646 t = YYAction (-65); +private yyaction647 t = YYAction (-66); +private yyaction648 t = YYAction (-67); +private yyaction649 t = YYAction (-68); +private yyaction650 t = YYAction (-69); +private yyaction651 t = YYAction (-70); +private yyaction652 t = YYAction (-71); +private yyaction653 t = YYAction (-72); +private yyaction654 t = YYAction (-73); +private yyaction655 t = YYAction (-74); +private yyaction656 t = YYAction (-75); +private yyaction657 t = YYAction (-76); +private yyaction658 t = YYAction (-77); +private yyaction659 t = YYAction (-78); +private yyaction660 t = YYAction (-79); +private yyaction661 t = YYAction (-80); +private yyaction662 t = YYAction (-81); +private yyaction663 t = YYAction (-82); +private yyaction664 t = YYAction (-83); +private yyaction665 t = YYAction (-84); +private yyaction666 t = YYAction (-85); +private yyaction667 t = YYAction (-86); +private yyaction668 t = YYAction (-87); +private yyaction669 t = YYAction (-88); +private yyaction670 t = YYAction (-89); +private yyaction671 t = YYAction (-90); +private yyaction672 t = YYAction (-91); +private yyaction673 t = YYAction (-92); +private yyaction674 t = YYAction (-93); +private yyaction675 t = YYAction (-94); +private yyaction676 t = YYAction (-103); +private yyaction677 t = YYAction (-104); +private yyaction678 t = case yychar t of { + '-' -> YYAction 676; + ';' -> YYAction 677; + '{' -> YYAction 678; + '}' -> YYAction 715; + '.' -> YYAction 680; + '(' -> YYAction 681; + ')' -> YYAction 682; + ',' -> YYAction 683; + '|' -> YYAction 684; + '[' -> YYAction 685; + ']' -> YYAction 686; + '?' -> YYAction 687; + '!' -> YYAction 688; + '=' -> YYAction 689; + '\\' -> YYAction 690; + _ -> case yytoken t of { + VARID -> YYAction 628; + CONID -> YYAction 629; + QUALIFIER -> YYAction 630; + DOCUMENTATION -> YYAction 631; + EXTENDS -> YYAction 632; + SUPER -> YYAction 633; + PACKAGE -> YYAction 634; + IMPORT -> YYAction 635; + INFIX -> YYAction 636; + INFIXR -> YYAction 637; + INFIXL -> YYAction 638; + NATIVE -> YYAction 639; + DATA -> YYAction 640; + WHERE -> YYAction 641; + CLASS -> YYAction 642; + INSTANCE -> YYAction 643; + ABSTRACT -> YYAction 644; + TYPE -> YYAction 645; + TRUE -> YYAction 646; + FALSE -> YYAction 647; + IF -> YYAction 648; + THEN -> YYAction 649; + ELSE -> YYAction 650; + CASE -> YYAction 651; + OF -> YYAction 652; + DERIVE -> YYAction 653; + LET -> YYAction 654; + IN -> YYAction 655; + DO -> YYAction 656; + FORALL -> YYAction 657; + PRIVATE -> YYAction 658; + PROTECTED -> YYAction 659; + PUBLIC -> YYAction 660; + PURE -> YYAction 661; + THROWS -> YYAction 662; + MUTABLE -> YYAction 663; + INTCONST -> YYAction 664; + STRCONST -> YYAction 665; + LONGCONST -> YYAction 666; + FLTCONST -> YYAction 667; + DBLCONST -> YYAction 668; + CHRCONST -> YYAction 669; + ARROW -> YYAction 670; + DCOLON -> YYAction 671; + GETS -> YYAction 672; + EARROW -> YYAction 673; + DOTDOT -> YYAction 674; + SOMEOP -> YYAction 675; _ -> YYAction yyBrace; }; }; -private yyaction671 t = YYAction (-46); -private yyaction672 t = YYAction (-101); -private yyaction673 t = YYAction (-99); -private yyaction674 t = YYAction (-100); -private yyaction675 t = YYAction (-95); -private yyaction676 t = YYAction (-96); -private yyaction677 t = YYAction (-97); -private yyaction678 t = YYAction (-98); -private yyaction679 t = YYAction (-102); -private yyaction680 t = YYAction (-105); -private yyaction681 t = YYAction (-106); -private yyaction682 t = YYAction (-107); -private yyaction683 t = case yychar t of { - '}' -> YYAction 709; +private yyaction679 t = YYAction (-46); +private yyaction680 t = YYAction (-101); +private yyaction681 t = YYAction (-99); +private yyaction682 t = YYAction (-100); +private yyaction683 t = YYAction (-95); +private yyaction684 t = YYAction (-96); +private yyaction685 t = YYAction (-97); +private yyaction686 t = YYAction (-98); +private yyaction687 t = YYAction (-102); +private yyaction688 t = YYAction (-105); +private yyaction689 t = YYAction (-106); +private yyaction690 t = YYAction (-107); +private yyaction691 t = case yychar t of { + '}' -> YYAction 717; _ -> YYAction yyBrace; }; -private yyaction684 t = case yychar t of { - '-' -> YYAction 668; - ';' -> YYAction 669; - '{' -> YYAction 670; - '.' -> YYAction 672; - '(' -> YYAction 673; - ')' -> YYAction 674; - ',' -> YYAction 675; - '|' -> YYAction 676; - '[' -> YYAction 677; - ']' -> YYAction 678; - '?' -> YYAction 679; - '!' -> YYAction 680; - '=' -> YYAction 681; - '\\' -> YYAction 682; +private yyaction692 t = case yychar t of { + '-' -> YYAction 676; + ';' -> YYAction 677; + '{' -> YYAction 678; + '.' -> YYAction 680; + '(' -> YYAction 681; + ')' -> YYAction 682; + ',' -> YYAction 683; + '|' -> YYAction 684; + '[' -> YYAction 685; + ']' -> YYAction 686; + '?' -> YYAction 687; + '!' -> YYAction 688; + '=' -> YYAction 689; + '\\' -> YYAction 690; '}' -> YYAction (-108); _ -> case yytoken t of { - VARID -> YYAction 620; - CONID -> YYAction 621; - QUALIFIER -> YYAction 622; - DOCUMENTATION -> YYAction 623; - EXTENDS -> YYAction 624; - SUPER -> YYAction 625; - PACKAGE -> YYAction 626; - IMPORT -> YYAction 627; - INFIX -> YYAction 628; - INFIXR -> YYAction 629; - INFIXL -> YYAction 630; - NATIVE -> YYAction 631; - DATA -> YYAction 632; - WHERE -> YYAction 633; - CLASS -> YYAction 634; - INSTANCE -> YYAction 635; - ABSTRACT -> YYAction 636; - TYPE -> YYAction 637; - TRUE -> YYAction 638; - FALSE -> YYAction 639; - IF -> YYAction 640; - THEN -> YYAction 641; - ELSE -> YYAction 642; - CASE -> YYAction 643; - OF -> YYAction 644; - DERIVE -> YYAction 645; - LET -> YYAction 646; - IN -> YYAction 647; - DO -> YYAction 648; - FORALL -> YYAction 649; - PRIVATE -> YYAction 650; - PROTECTED -> YYAction 651; - PUBLIC -> YYAction 652; - PURE -> YYAction 653; - THROWS -> YYAction 654; - MUTABLE -> YYAction 655; - INTCONST -> YYAction 656; - STRCONST -> YYAction 657; - LONGCONST -> YYAction 658; - FLTCONST -> YYAction 659; - DBLCONST -> YYAction 660; - CHRCONST -> YYAction 661; - ARROW -> YYAction 662; - DCOLON -> YYAction 663; - GETS -> YYAction 664; - EARROW -> YYAction 665; - DOTDOT -> YYAction 666; - SOMEOP -> YYAction 667; + VARID -> YYAction 628; + CONID -> YYAction 629; + QUALIFIER -> YYAction 630; + DOCUMENTATION -> YYAction 631; + EXTENDS -> YYAction 632; + SUPER -> YYAction 633; + PACKAGE -> YYAction 634; + IMPORT -> YYAction 635; + INFIX -> YYAction 636; + INFIXR -> YYAction 637; + INFIXL -> YYAction 638; + NATIVE -> YYAction 639; + DATA -> YYAction 640; + WHERE -> YYAction 641; + CLASS -> YYAction 642; + INSTANCE -> YYAction 643; + ABSTRACT -> YYAction 644; + TYPE -> YYAction 645; + TRUE -> YYAction 646; + FALSE -> YYAction 647; + IF -> YYAction 648; + THEN -> YYAction 649; + ELSE -> YYAction 650; + CASE -> YYAction 651; + OF -> YYAction 652; + DERIVE -> YYAction 653; + LET -> YYAction 654; + IN -> YYAction 655; + DO -> YYAction 656; + FORALL -> YYAction 657; + PRIVATE -> YYAction 658; + PROTECTED -> YYAction 659; + PUBLIC -> YYAction 660; + PURE -> YYAction 661; + THROWS -> YYAction 662; + MUTABLE -> YYAction 663; + INTCONST -> YYAction 664; + STRCONST -> YYAction 665; + LONGCONST -> YYAction 666; + FLTCONST -> YYAction 667; + DBLCONST -> YYAction 668; + CHRCONST -> YYAction 669; + ARROW -> YYAction 670; + DCOLON -> YYAction 671; + GETS -> YYAction 672; + EARROW -> YYAction 673; + DOTDOT -> YYAction 674; + SOMEOP -> YYAction 675; _ -> YYAction yyBrace; }; }; -private yyaction685 t = YYAction (-252); -private yyaction686 t = case yychar t of { - ')' -> YYAction 711; +private yyaction693 t = YYAction (-253); +private yyaction694 t = case yychar t of { + ')' -> YYAction 719; _ -> YYAction yyErr; }; -private yyaction687 t = YYAction (-251); -private yyaction688 t = case yychar t of { - '(' -> YYAction 580; +private yyaction695 t = YYAction (-252); +private yyaction696 t = case yychar t of { + '(' -> YYAction 588; _ -> case yytoken t of { - SOMEOP -> YYAction 579; + SOMEOP -> YYAction 587; _ -> YYAction yyErr; }; }; -private yyaction689 t = case yychar t of { - '?' -> YYAction 691; - '!' -> YYAction 692; +private yyaction697 t = case yychar t of { + '?' -> YYAction 699; + '!' -> YYAction 700; _ -> case yytoken t of { - VARID -> YYAction 119; + VARID -> YYAction 121; _ -> YYAction yyErr; }; }; -private yyaction690 t = case yychar t of { - '?' -> YYAction 691; - '!' -> YYAction 692; +private yyaction698 t = case yychar t of { + '?' -> YYAction 699; + '!' -> YYAction 700; _ -> case yytoken t of { - VARID -> YYAction 119; + VARID -> YYAction 121; _ -> YYAction yyErr; }; }; -private yyaction691 t = case yytoken t of { - VARID -> YYAction 119; +private yyaction699 t = case yytoken t of { + VARID -> YYAction 121; _ -> YYAction yyErr; }; -private yyaction692 t = case yytoken t of { - VARID -> YYAction 119; +private yyaction700 t = case yytoken t of { + VARID -> YYAction 121; _ -> YYAction yyErr; }; -private yyaction693 t = YYAction (-335); -private yyaction694 t = case yytoken t of { - DCOLON -> YYAction 717; +private yyaction701 t = YYAction (-337); +private yyaction702 t = case yytoken t of { + DCOLON -> YYAction 725; _ -> YYAction yyErr; }; -private yyaction695 t = case yychar t of { - ',' -> YYAction 718; +private yyaction703 t = case yychar t of { + ',' -> YYAction 726; _ -> case yytoken t of { - DCOLON -> YYAction (-327); + DCOLON -> YYAction (-329); _ -> YYAction yyErr; }; }; -private yyaction696 t = YYAction (-329); -private yyaction697 t = YYAction (-332); -private yyaction698 t = YYAction (-311); -private yyaction699 t = case yychar t of { - '}' -> YYAction (-323); +private yyaction704 t = YYAction (-331); +private yyaction705 t = YYAction (-334); +private yyaction706 t = YYAction (-313); +private yyaction707 t = case yychar t of { + '}' -> YYAction (-325); '?' -> YYAction (-18); '!' -> YYAction (-18); _ -> case yytoken t of { @@ -5405,8 +5462,8 @@ private yyaction699 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction700 t = case yychar t of { - '}' -> YYAction (-322); +private yyaction708 t = case yychar t of { + '}' -> YYAction (-324); '?' -> YYAction (-18); '!' -> YYAction (-18); _ -> case yytoken t of { @@ -5417,198 +5474,198 @@ private yyaction700 t = case yychar t of { _ -> YYAction yyBrace; }; }; -private yyaction701 t = YYAction (-247); -private yyaction702 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; +private yyaction709 t = YYAction (-248); +private yyaction710 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; _ -> case yytoken t of { - VARID -> YYAction 225; + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; - _ -> YYAction yyErr; - }; -}; -private yyaction703 t = YYAction (-248); -private yyaction704 t = YYAction (-378); -private yyaction705 t = YYAction (-382); -private yyaction706 t = YYAction (-164); -private yyaction707 t = case yychar t of { - '-' -> YYAction 668; - ';' -> YYAction 669; - '{' -> YYAction 670; - '.' -> YYAction 672; - '(' -> YYAction 673; - ')' -> YYAction 674; - ',' -> YYAction 675; - '|' -> YYAction 676; - '[' -> YYAction 677; - ']' -> YYAction 678; - '?' -> YYAction 679; - '!' -> YYAction 680; - '=' -> YYAction 681; - '\\' -> YYAction 682; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; + _ -> YYAction yyErr; + }; +}; +private yyaction711 t = YYAction (-249); +private yyaction712 t = YYAction (-380); +private yyaction713 t = YYAction (-384); +private yyaction714 t = YYAction (-165); +private yyaction715 t = case yychar t of { + '-' -> YYAction 676; + ';' -> YYAction 677; + '{' -> YYAction 678; + '.' -> YYAction 680; + '(' -> YYAction 681; + ')' -> YYAction 682; + ',' -> YYAction 683; + '|' -> YYAction 684; + '[' -> YYAction 685; + ']' -> YYAction 686; + '?' -> YYAction 687; + '!' -> YYAction 688; + '=' -> YYAction 689; + '\\' -> YYAction 690; '}' -> YYAction (-112); _ -> case yytoken t of { - VARID -> YYAction 620; - CONID -> YYAction 621; - QUALIFIER -> YYAction 622; - DOCUMENTATION -> YYAction 623; - EXTENDS -> YYAction 624; - SUPER -> YYAction 625; - PACKAGE -> YYAction 626; - IMPORT -> YYAction 627; - INFIX -> YYAction 628; - INFIXR -> YYAction 629; - INFIXL -> YYAction 630; - NATIVE -> YYAction 631; - DATA -> YYAction 632; - WHERE -> YYAction 633; - CLASS -> YYAction 634; - INSTANCE -> YYAction 635; - ABSTRACT -> YYAction 636; - TYPE -> YYAction 637; - TRUE -> YYAction 638; - FALSE -> YYAction 639; - IF -> YYAction 640; - THEN -> YYAction 641; - ELSE -> YYAction 642; - CASE -> YYAction 643; - OF -> YYAction 644; - DERIVE -> YYAction 645; - LET -> YYAction 646; - IN -> YYAction 647; - DO -> YYAction 648; - FORALL -> YYAction 649; - PRIVATE -> YYAction 650; - PROTECTED -> YYAction 651; - PUBLIC -> YYAction 652; - PURE -> YYAction 653; - THROWS -> YYAction 654; - MUTABLE -> YYAction 655; - INTCONST -> YYAction 656; - STRCONST -> YYAction 657; - LONGCONST -> YYAction 658; - FLTCONST -> YYAction 659; - DBLCONST -> YYAction 660; - CHRCONST -> YYAction 661; - ARROW -> YYAction 662; - DCOLON -> YYAction 663; - GETS -> YYAction 664; - EARROW -> YYAction 665; - DOTDOT -> YYAction 666; - SOMEOP -> YYAction 667; + VARID -> YYAction 628; + CONID -> YYAction 629; + QUALIFIER -> YYAction 630; + DOCUMENTATION -> YYAction 631; + EXTENDS -> YYAction 632; + SUPER -> YYAction 633; + PACKAGE -> YYAction 634; + IMPORT -> YYAction 635; + INFIX -> YYAction 636; + INFIXR -> YYAction 637; + INFIXL -> YYAction 638; + NATIVE -> YYAction 639; + DATA -> YYAction 640; + WHERE -> YYAction 641; + CLASS -> YYAction 642; + INSTANCE -> YYAction 643; + ABSTRACT -> YYAction 644; + TYPE -> YYAction 645; + TRUE -> YYAction 646; + FALSE -> YYAction 647; + IF -> YYAction 648; + THEN -> YYAction 649; + ELSE -> YYAction 650; + CASE -> YYAction 651; + OF -> YYAction 652; + DERIVE -> YYAction 653; + LET -> YYAction 654; + IN -> YYAction 655; + DO -> YYAction 656; + FORALL -> YYAction 657; + PRIVATE -> YYAction 658; + PROTECTED -> YYAction 659; + PUBLIC -> YYAction 660; + PURE -> YYAction 661; + THROWS -> YYAction 662; + MUTABLE -> YYAction 663; + INTCONST -> YYAction 664; + STRCONST -> YYAction 665; + LONGCONST -> YYAction 666; + FLTCONST -> YYAction 667; + DBLCONST -> YYAction 668; + CHRCONST -> YYAction 669; + ARROW -> YYAction 670; + DCOLON -> YYAction 671; + GETS -> YYAction 672; + EARROW -> YYAction 673; + DOTDOT -> YYAction 674; + SOMEOP -> YYAction 675; _ -> YYAction yyBrace; }; }; -private yyaction708 t = case yychar t of { - '}' -> YYAction 723; +private yyaction716 t = case yychar t of { + '}' -> YYAction 731; _ -> YYAction yyBrace; }; -private yyaction709 t = YYAction (-45); -private yyaction710 t = YYAction (-109); -private yyaction711 t = YYAction (-263); -private yyaction712 t = YYAction (-260); -private yyaction713 t = YYAction (-331); -private yyaction714 t = YYAction (-330); -private yyaction715 t = YYAction (-334); -private yyaction716 t = YYAction (-333); -private yyaction717 t = case yychar t of { - '(' -> YYAction 240; - '[' -> YYAction 241; - _ -> case yytoken t of { - VARID -> YYAction 225; +private yyaction717 t = YYAction (-45); +private yyaction718 t = YYAction (-109); +private yyaction719 t = YYAction (-264); +private yyaction720 t = YYAction (-261); +private yyaction721 t = YYAction (-333); +private yyaction722 t = YYAction (-332); +private yyaction723 t = YYAction (-336); +private yyaction724 t = YYAction (-335); +private yyaction725 t = case yychar t of { + '(' -> YYAction 244; + '[' -> YYAction 245; + _ -> case yytoken t of { + VARID -> YYAction 229; CONID -> YYAction 24; - QUALIFIER -> YYAction 131; - FORALL -> YYAction 294; - _ -> YYAction yyErr; - }; -}; -private yyaction718 t = case yychar t of { - '?' -> YYAction 691; - '!' -> YYAction 692; - _ -> case yytoken t of { - VARID -> YYAction 119; - PRIVATE -> YYAction 689; - PUBLIC -> YYAction 690; - _ -> YYAction yyErr; - }; -}; -private yyaction719 t = YYAction (-325); -private yyaction720 t = YYAction (-324); -private yyaction721 t = YYAction (-242); -private yyaction722 t = YYAction (-113); -private yyaction723 t = case yychar t of { - '-' -> YYAction 668; - ';' -> YYAction 669; - '{' -> YYAction 670; - '.' -> YYAction 672; - '(' -> YYAction 673; - ')' -> YYAction 674; - ',' -> YYAction 675; - '|' -> YYAction 676; - '[' -> YYAction 677; - ']' -> YYAction 678; - '?' -> YYAction 679; - '!' -> YYAction 680; - '=' -> YYAction 681; - '\\' -> YYAction 682; + QUALIFIER -> YYAction 133; + FORALL -> YYAction 299; + _ -> YYAction yyErr; + }; +}; +private yyaction726 t = case yychar t of { + '?' -> YYAction 699; + '!' -> YYAction 700; + _ -> case yytoken t of { + VARID -> YYAction 121; + PRIVATE -> YYAction 697; + PUBLIC -> YYAction 698; + _ -> YYAction yyErr; + }; +}; +private yyaction727 t = YYAction (-327); +private yyaction728 t = YYAction (-326); +private yyaction729 t = YYAction (-243); +private yyaction730 t = YYAction (-113); +private yyaction731 t = case yychar t of { + '-' -> YYAction 676; + ';' -> YYAction 677; + '{' -> YYAction 678; + '.' -> YYAction 680; + '(' -> YYAction 681; + ')' -> YYAction 682; + ',' -> YYAction 683; + '|' -> YYAction 684; + '[' -> YYAction 685; + ']' -> YYAction 686; + '?' -> YYAction 687; + '!' -> YYAction 688; + '=' -> YYAction 689; + '\\' -> YYAction 690; '}' -> YYAction (-110); _ -> case yytoken t of { - VARID -> YYAction 620; - CONID -> YYAction 621; - QUALIFIER -> YYAction 622; - DOCUMENTATION -> YYAction 623; - EXTENDS -> YYAction 624; - SUPER -> YYAction 625; - PACKAGE -> YYAction 626; - IMPORT -> YYAction 627; - INFIX -> YYAction 628; - INFIXR -> YYAction 629; - INFIXL -> YYAction 630; - NATIVE -> YYAction 631; - DATA -> YYAction 632; - WHERE -> YYAction 633; - CLASS -> YYAction 634; - INSTANCE -> YYAction 635; - ABSTRACT -> YYAction 636; - TYPE -> YYAction 637; - TRUE -> YYAction 638; - FALSE -> YYAction 639; - IF -> YYAction 640; - THEN -> YYAction 641; - ELSE -> YYAction 642; - CASE -> YYAction 643; - OF -> YYAction 644; - DERIVE -> YYAction 645; - LET -> YYAction 646; - IN -> YYAction 647; - DO -> YYAction 648; - FORALL -> YYAction 649; - PRIVATE -> YYAction 650; - PROTECTED -> YYAction 651; - PUBLIC -> YYAction 652; - PURE -> YYAction 653; - THROWS -> YYAction 654; - MUTABLE -> YYAction 655; - INTCONST -> YYAction 656; - STRCONST -> YYAction 657; - LONGCONST -> YYAction 658; - FLTCONST -> YYAction 659; - DBLCONST -> YYAction 660; - CHRCONST -> YYAction 661; - ARROW -> YYAction 662; - DCOLON -> YYAction 663; - GETS -> YYAction 664; - EARROW -> YYAction 665; - DOTDOT -> YYAction 666; - SOMEOP -> YYAction 667; + VARID -> YYAction 628; + CONID -> YYAction 629; + QUALIFIER -> YYAction 630; + DOCUMENTATION -> YYAction 631; + EXTENDS -> YYAction 632; + SUPER -> YYAction 633; + PACKAGE -> YYAction 634; + IMPORT -> YYAction 635; + INFIX -> YYAction 636; + INFIXR -> YYAction 637; + INFIXL -> YYAction 638; + NATIVE -> YYAction 639; + DATA -> YYAction 640; + WHERE -> YYAction 641; + CLASS -> YYAction 642; + INSTANCE -> YYAction 643; + ABSTRACT -> YYAction 644; + TYPE -> YYAction 645; + TRUE -> YYAction 646; + FALSE -> YYAction 647; + IF -> YYAction 648; + THEN -> YYAction 649; + ELSE -> YYAction 650; + CASE -> YYAction 651; + OF -> YYAction 652; + DERIVE -> YYAction 653; + LET -> YYAction 654; + IN -> YYAction 655; + DO -> YYAction 656; + FORALL -> YYAction 657; + PRIVATE -> YYAction 658; + PROTECTED -> YYAction 659; + PUBLIC -> YYAction 660; + PURE -> YYAction 661; + THROWS -> YYAction 662; + MUTABLE -> YYAction 663; + INTCONST -> YYAction 664; + STRCONST -> YYAction 665; + LONGCONST -> YYAction 666; + FLTCONST -> YYAction 667; + DBLCONST -> YYAction 668; + CHRCONST -> YYAction 669; + ARROW -> YYAction 670; + DCOLON -> YYAction 671; + GETS -> YYAction 672; + EARROW -> YYAction 673; + DOTDOT -> YYAction 674; + SOMEOP -> YYAction 675; _ -> YYAction yyBrace; }; }; -private yyaction724 t = YYAction (-326); -private yyaction725 t = YYAction (-328); -private yyaction726 t = YYAction (-111); +private yyaction732 t = YYAction (-328); +private yyaction733 t = YYAction (-330); +private yyaction734 t = YYAction (-111); private reduce1 = \d\(a,p)\w\b -> do { changeST Global.{sub <- SubSt.{ thisPos = p}}; @@ -5691,7 +5748,7 @@ private reduce27 = const ; private reduce28 = \a\_\b -> a ++ b ; -private reduce29 = single +private reduce29 = single . DefinitionS.Doc ; private reduce32 = \_\ds -> map (updVis Private) ds ; @@ -5699,13 +5756,13 @@ private reduce33 = \_\ds -> map (updVis Protected) ds ; private reduce34 = \_\ds -> map (updVis Public) ds ; -private reduce35 = \_\(d::Def) -> [d.{ctrs <- map updCtr}] +private reduce35 = \_\(d::DatDcl) -> [DefinitionS.Dat $ d.{ctrs <- map updCtr}] ; -private reduce36 = single +private reduce36 = single . DefinitionS.Imp ; -private reduce37 = single +private reduce37 = single . DefinitionS.Fix ; -private reduce38 = single +private reduce38 = single . DefinitionS.Mod ; private reduce40 = \_\m\t\i\js -> ModDcl {pos = yyline m, extending=t, implementing=i, code=js } ; @@ -5735,105 +5792,113 @@ private reduce113 = \a\b\cs -> a:b:cs ; private reduce114 = \t -> DocDcl {pos = yyline t, text = t.value} ; -private reduce115 = single +private reduce115 = single . DefinitionS.Typ +; +private reduce116 = single . DefinitionS.Dat +; +private reduce117 = single . DefinitionS.Jav +; +private reduce118 = single . DefinitionS.Cla ; -private reduce116 = single +private reduce119 = single . DefinitionS.Ins ; -private reduce117 = single +private reduce120 = single . DefinitionS.Drv ; -private reduce118 = single +private reduce123 = const ; -private reduce119 = single +private reduce124 = \d\_\ds -> d ++ ds ; -private reduce122 = const +private reduce125 = map DefinitionS.Ann ; -private reduce123 = \d\_\ds -> d ++ ds +private reduce126 = single . DefinitionS.Nat ; -private reduce125 = single +private reduce127 = single . DefinitionS.Fun ; -private reduce128 = \_\ds -> map (updVis Private) ds +private reduce129 = \_\ds -> map (updVis Private) ds ; -private reduce129 = \_\ds -> map (updVis Protected) ds +private reduce130 = \_\ds -> map (updVis Protected) ds ; -private reduce130 = \_\ds -> map (updVis Public) ds +private reduce131 = \_\ds -> map (updVis Public) ds ; -private reduce131 = single +private reduce132 = single . DefinitionS.Doc ; -private reduce132 = (:) +private reduce133 = \doc\ds -> DefinitionS.Doc doc : ds ; -private reduce137 = const +private reduce135 = map LetMemberS.Ann ; -private reduce138 = \ds1\_\ds2 -> ds1 ++ ds2 +private reduce136 = single . LetMemberS.Fun ; -private reduce139 = \i\b\c -> ImpDcl {pos=snd b, pack=fst b, imports=c, as=Nothing} +private reduce138 = const ; -private reduce140 = \i\p\a\c\l -> do +private reduce139 = \ds1\_\ds2 -> ds1 ++ ds2 +; +private reduce140 = \i\b\c -> ImpDcl {pos=snd b, pack=fst b, imports=c, as=Nothing} +; +private reduce141 = \i\p\a\c\l -> do when (Token.value a != "as") do yyerror (yyline a) (show "as" ++ " expected instead of " ++ show (Token.value a)) changeST Global.{sub <- SubSt.{idKind <- insert (KeyTk c) (Left()) }} YYM.pure ImpDcl {pos = snd p, pack = fst p, imports = l, as = Just (Token.value c)} ; -private reduce141 = \i\p\c\l -> do +private reduce142 = \i\p\c\l -> do changeST Global.{sub <- SubSt.{idKind <- insert (KeyTk c) (Left()) }} YYM.pure ImpDcl {pos = snd p, pack = fst p, imports = l, as = Just (Token.value c)} ; -private reduce142 = linkAll +private reduce143 = linkAll ; -private reduce143 = \v\_\is\_ -> do +private reduce144 = \v\_\is\_ -> do when ( v.value `notElem` [ "except", "excluding", "without", "außer", "ohne", "hiding" ]) do yyerror (yyline v) (show "hiding" ++ " expected instead of " ++ show v.value) YYM.pure linkAll.{items=is} ; -private reduce144 = \_\_ -> linkNone +private reduce145 = \_\_ -> linkNone ; -private reduce145 = \_\is\_ -> linkNone.{items = is} +private reduce146 = \_\is\_ -> linkNone.{items = is} ; -private reduce146 = \_\il -> ImportList.{publik = true} il +private reduce147 = \_\il -> ImportList.{publik = true} il ; -private reduce147 = single +private reduce148 = single ; -private reduce148 = \s\_ -> [s] +private reduce149 = \s\_ -> [s] ; -private reduce149 = liste +private reduce150 = liste ; -private reduce150 = \v -> protoItem.{ name = v } +private reduce151 = \v -> protoItem.{ name = v } ; -private reduce151 = \v\_\ms\_ -> protoItem.{ name = Simple v, members = Just ms} +private reduce152 = \v\_\ms\_ -> protoItem.{ name = Simple v, members = Just ms} ; -private reduce152 = \v\_\_ -> protoItem.{ name = Simple v, members = Just []} +private reduce153 = \v\_\_ -> protoItem.{ name = Simple v, members = Just []} ; -private reduce153 = \v -> protoItem.{ name = v } +private reduce154 = \v -> protoItem.{ name = v } ; -private reduce154 = \t -> protoItem.{ name = opSname t } +private reduce155 = \t -> protoItem.{ name = opSname t } ; -private reduce155 = \v -> protoItem.{ name = Simple v} +private reduce156 = \v -> protoItem.{ name = Simple v} ; -private reduce156 = \s -> ImportItem.{alias = (enclosed . Token.value . SName.id . ImportItem.name) s} s +private reduce157 = \s -> ImportItem.{alias = (enclosed . Token.value . SName.id . ImportItem.name) s} s ; -private reduce157 = \s\a -> ImportItem.{alias = enclosed (Token.value a)} s +private reduce158 = \s\a -> ImportItem.{alias = enclosed (Token.value a)} s ; -private reduce158 = \_\s -> ImportItem.export s +private reduce159 = \_\s -> ImportItem.export s ; -private reduce159 = \v -> protoItem.{ name = Simple v, +private reduce160 = \v -> protoItem.{ name = Simple v, alias = enclosed (Token.value v)} ; -private reduce160 = \v\a -> protoItem.{ name = Simple v, +private reduce161 = \v\a -> protoItem.{ name = Simple v, alias = enclosed (Token.value a)} ; -private reduce161 = \_\s -> ImportItem.export s +private reduce162 = \_\s -> ImportItem.export s ; -private reduce162 = single +private reduce163 = single ; -private reduce163 = \s\_ -> [s] +private reduce164 = \s\_ -> [s] ; -private reduce164 = liste +private reduce165 = liste ; -private reduce167 = \v -> do { op <- unqualified v; pure op } -; -private reduce170 = Token.{tokid = VARID} +private reduce168 = \v -> do { op <- unqualified v; pure op } ; private reduce171 = Token.{tokid = VARID} ; @@ -5845,140 +5910,142 @@ private reduce174 = Token.{tokid = VARID} ; private reduce175 = Token.{tokid = VARID} ; -private reduce176 = single +private reduce176 = Token.{tokid = VARID} +; +private reduce177 = single ; -private reduce177 = liste +private reduce178 = liste ; -private reduce178 = \n\t\v -> With2 n t v +private reduce179 = \n\t\v -> With2 n t v ; -private reduce179 = \t\v -> With1 t v +private reduce180 = \t\v -> With1 t v ; -private reduce180 = \v -> Simple v +private reduce181 = \v -> Simple v ; -private reduce181 = \n\t\v -> With2 n t v +private reduce182 = \n\t\v -> With2 n t v ; -private reduce182 = \t\v -> With1 t v +private reduce183 = \t\v -> With1 t v ; -private reduce183 = \v -> Simple v +private reduce184 = \v -> Simple v ; -private reduce186 = \n\t\v -> With2 n t v +private reduce187 = \n\t\v -> With2 n t v ; -private reduce187 = \t\v -> With1 t v +private reduce188 = \t\v -> With1 t v ; -private reduce188 = Simple +private reduce189 = Simple ; -private reduce189 = opSname +private reduce190 = opSname ; -private reduce193 = \f\i -> do +private reduce194 = \f\i -> do t <- infixop (yyline i) NOP1 (Token.value i) YYM.pure (FixDcl {pos=Pos f i, opid=t, ops=[]}) ; -private reduce194 = \f\i -> do +private reduce195 = \f\i -> do t <- infixop (yyline i) LOP1 (Token.value i) YYM.pure (FixDcl {pos=Pos f i, opid=t, ops=[]}) ; -private reduce195 = \f\i -> do +private reduce196 = \f\i -> do t <- infixop (yyline i) ROP1 (Token.value i) YYM.pure (FixDcl {pos=Pos f i, opid=t, ops=[]}) ; -private reduce196 = Token.value -; private reduce197 = Token.value ; private reduce198 = Token.value ; -private reduce199 = single +private reduce199 = Token.value ; -private reduce200 = (:) +private reduce200 = single ; -private reduce201 = \(def::Def)\o -> def.{ops = o} +private reduce201 = (:) ; -private reduce202 = \as\_\s -> map (annotation s) as +private reduce202 = \(def::FixDcl)\o -> def.{ops = o} ; -private reduce204 = \_\a\_ -> do unqualified a +private reduce203 = \as\_\s -> map (annotation s) as ; -private reduce205 = \_\a\_ -> a +private reduce205 = \_\a\_ -> do unqualified a ; private reduce206 = \_\a\_ -> a ; -private reduce207 = single +private reduce207 = \_\a\_ -> a +; +private reduce208 = single ; -private reduce208 = liste +private reduce209 = liste ; -private reduce209 = \_\(d::Def) -> d.{isPure = true} +private reduce210 = \_\(d::NatDcl) -> d.{isPure = true} ; -private reduce214 = \o -> do unqualified o +private reduce215 = \o -> do unqualified o ; -private reduce216 = \o -> do unqualified o >>= pure . _.value +private reduce217 = \o -> do unqualified o >>= pure . _.value ; -private reduce217 = Token.value +private reduce218 = Token.value ; -private reduce218 = \f\j\g -> (f,j,Just g) +private reduce219 = \f\j\g -> (f,j,Just g) ; -private reduce219 = \f\j -> (f,j,Nothing) +private reduce220 = \f\j -> (f,j,Nothing) ; -private reduce220 = \f\g -> (f,Token.value f, Just g) +private reduce221 = \f\g -> (f,Token.value f, Just g) ; -private reduce221 = \f -> (f,Token.value f, Nothing) +private reduce222 = \f -> (f,Token.value f, Nothing) ; -private reduce222 = \a\_\c -> (a, c) +private reduce223 = \a\_\c -> (a, c) ; -private reduce223 = \a -> (a, []) +private reduce224 = \a -> (a, []) ; -private reduce224 = single +private reduce225 = single ; -private reduce225 = liste +private reduce226 = liste ; -private reduce226 = \_\(fr,jv,ga)\col\t -> +private reduce227 = \_\(fr,jv,ga)\col\t -> NatDcl {pos=yyline fr, vis=Public, name=fr.value, meth=jv, txs=t, isPure=false, gargs = ga, doc=Nothing} ; -private reduce228 = ForAll [] +private reduce229 = ForAll [] ; -private reduce229 = \_\vs\_\r -> ForAll vs r +private reduce230 = \_\vs\_\r -> ForAll vs r ; -private reduce231 = \dot -> do +private reduce232 = \dot -> do when (Token.value dot != "•") do yyerror (yyline dot) ("'.' expected instead of " ++ show dot.value) YYM.pure dot ; -private reduce232 = \tau\t\rho -> do +private reduce233 = \tau\t\rho -> do context <- tauToCtx tau YYM.pure (Rho.{context} rho) ; -private reduce234 = RhoTau [] +private reduce235 = RhoTau [] ; -private reduce235 = \a\_\b -> case a of +private reduce236 = \a\_\b -> case a of TSig s -> RhoFun [] s b _ -> RhoFun [] (ForAll [] (RhoTau [] a)) b ; -private reduce237 = TSig +private reduce238 = TSig ; -private reduce238 = \a\f\b -> case a of +private reduce239 = \a\f\b -> case a of TSig s -> TSig (ForAll [] (RhoFun [] s (RhoTau [] b))) _ -> TApp (TApp (TCon (yyline f) (fromBase f.{tokid=CONID, value="->"})) a) b ; -private reduce239 = single +private reduce240 = single ; -private reduce240 = liste +private reduce241 = liste ; -private reduce241 = single +private reduce242 = single ; -private reduce242 = liste +private reduce243 = liste ; -private reduce243 = \taus -> Tau.mkapp (head taus) (tail taus) +private reduce244 = \taus -> Tau.mkapp (head taus) (tail taus) ; -private reduce245 = \(tn::SName) -> TCon (yyline tn.id) tn +private reduce246 = \(tn::SName) -> TCon (yyline tn.id) tn ; -private reduce246 = \_\t\_ -> t +private reduce247 = \_\t\_ -> t ; -private reduce247 = \_\t\(c::Token)\ts\_ -> +private reduce248 = \_\t\(c::Token)\ts\_ -> let tus = t:ts; i = length tus; @@ -5986,33 +6053,33 @@ private reduce247 = \_\t\(c::Token)\ts\_ -> in (TCon (yyline c) tname).mkapp tus ; -private reduce248 = \_\t\e\ts\_ -> mkEither (yyline e) t ts +private reduce249 = \_\t\e\ts\_ -> mkEither (yyline e) t ts ; -private reduce249 = \a\t\_ -> TApp (TCon (yyline a) +private reduce250 = \a\t\_ -> TApp (TCon (yyline a) (fromBase a.{tokid=CONID, value="[]"})) t ; -private reduce250 = \n -> TVar (yyline n) KVar (Token.value n) +private reduce251 = \n -> TVar (yyline n) KVar (Token.value n) ; -private reduce251 = \_\n\_\k\_ -> TVar (yyline n) k (Token.value n) +private reduce252 = \_\n\_\k\_ -> TVar (yyline n) k (Token.value n) ; -private reduce252 = \_\v\x\ks\_ -> TVar (yyline v) (KGen ks) (v.value) +private reduce253 = \_\v\x\ks\_ -> TVar (yyline v) (KGen ks) (v.value) ; -private reduce253 = \_\x\ks\_ -> TVar (yyline x) (KGen ks) ("<") +private reduce254 = \_\x\ks\_ -> TVar (yyline x) (KGen ks) ("<") ; -private reduce254 = \_\x\k\_ -> TVar (yyline x) (KGen [k]) (">") +private reduce255 = \_\x\k\_ -> TVar (yyline x) (KGen [k]) (">") ; -private reduce256 = \(a::Token)\_ -> fromBase a.{tokid=CONID, value="[]"} +private reduce257 = \(a::Token)\_ -> fromBase a.{tokid=CONID, value="[]"} ; -private reduce257 = \(a::Token)\_ -> fromBase a.{tokid=CONID, value="()"} +private reduce258 = \(a::Token)\_ -> fromBase a.{tokid=CONID, value="()"} ; -private reduce258 = \(z::Token)\n\_ -> fromBase z.{tokid=CONID, value=tuple (n+1)} +private reduce259 = \(z::Token)\n\_ -> fromBase z.{tokid=CONID, value=tuple (n+1)} ; -private reduce259 = \_\(a::Token)\_ -> fromBase a.{tokid=CONID, value="->"} +private reduce260 = \_\(a::Token)\_ -> fromBase a.{tokid=CONID, value="->"} ; -private reduce260 = \a\_\c -> KApp a c +private reduce261 = \a\_\c -> KApp a c ; -private reduce262 = \star -> do +private reduce263 = \star -> do let w = Token.value star when (w != "*") do yyerror (yyline star) @@ -6020,21 +6087,21 @@ private reduce262 = \star -> do pure KType ; -private reduce263 = \_\b\_ -> b +private reduce264 = \_\b\_ -> b ; -private reduce264 = \c\v -> Ctx {pos=Pos (SName.id c) v.pos.last, cname=c, tau=v} +private reduce265 = \c\v -> Ctx {pos=Pos (SName.id c) v.pos.last, cname=c, tau=v} ; -private reduce265 = single +private reduce266 = single ; -private reduce266 = \c\_ -> [c] +private reduce267 = \c\_ -> [c] ; -private reduce267 = liste +private reduce268 = liste ; -private reduce268 = single +private reduce269 = single ; -private reduce269 = \_\x\_ -> x +private reduce270 = \_\x\_ -> x ; -private reduce270 = +private reduce271 = \_\ctxs\_\c\v\defs -> do sups <- classContext (Token.value c) ctxs (v::TauS).var pure ClaDcl{ @@ -6047,7 +6114,7 @@ private reduce270 = doc = Nothing} ; -private reduce271 = +private reduce272 = \kw\ctxs\defs -> case ctxs of Ctx{pos,cname,tau}:rest -> do unless (null rest) @@ -6060,19 +6127,19 @@ private reduce271 = _ -> Prelude.error "fatal: empty ccontext (cannot happen)" ; -private reduce272 = \c\t -> Ctx {pos=Pos (SName.id c) t.getpos.last, cname=c, tau=t} +private reduce273 = \c\t -> Ctx {pos=Pos (SName.id c) t.getpos.last, cname=c, tau=t} ; -private reduce273 = single +private reduce274 = single ; -private reduce274 = \c\_ -> [c] +private reduce275 = \c\_ -> [c] ; -private reduce275 = liste +private reduce276 = liste ; -private reduce276 = single +private reduce277 = single ; -private reduce277 = \_\x\_ -> x +private reduce278 = \_\x\_ -> x ; -private reduce278 = +private reduce279 = \ctxs\ea\cls\tau -> InsDcl { pos = yyline ea, vis = Public, @@ -6082,7 +6149,7 @@ private reduce278 = doc = Nothing} ; -private reduce279 = +private reduce280 = \ctxs -> case ctxs of Ctx{pos, cname, tau}:rest -> do unless (null rest) @@ -6096,43 +6163,29 @@ private reduce279 = _ -> Prelude.error "fatal: empty instance context" ; -private reduce280 = - \ins\head\defs -> (head::Def).{defs, pos = yyline ins} +private reduce281 = + \ins\head\defs -> (head::InsDcl).{defs, pos = yyline ins} ; -private reduce281 = - \d\(i::Def) -> DrvDcl {pos = yyline d, vis = Public, clas=i.clas, typ=i.typ, doc=Nothing} +private reduce282 = + \d\(i::InsDcl) -> DrvDcl {pos = yyline d, vis = Public, clas=i.clas, typ=i.typ, doc=Nothing} ; -private reduce282 = \def\defs -> (def::Def).{defs = defs} -; -private reduce283 = \_\_ -> true +private reduce283 = \def\defs -> (def::DatDcl).{defs = defs} ; -private reduce284 = \_ -> false +private reduce284 = \def\defs -> (def::JavDcl).{defs = defs} ; -private reduce285 = \x -> (x, Nothing) +private reduce285 = \_\_ -> true ; -private reduce286 = \x\gs -> (x, Just gs) +private reduce286 = \_ -> false ; -private reduce287 = \_\ts\_ -> ts +private reduce287 = \x -> (x, Nothing) ; -private reduce288 = \_\_ -> [] +private reduce288 = \x\gs -> (x, Just gs) ; -private reduce289 = - \dat\d\docu\pur\(jt,gargs) -> JavDcl {pos=yyline d, vis=Public, name=Token.value d, - jclas=jt, vars=[], defs=[], - gargs, - isPure = pur, - doc=Nothing} - +private reduce289 = \_\ts\_ -> ts ; -private reduce290 = - \dat\d\ds\docu\pur\(jt,gargs) -> JavDcl {pos=yyline d, vis=Public, name=Token.value d, - jclas=jt, vars=ds, defs=[], - gargs, - isPure = pur, - doc=Nothing} - +private reduce290 = \_\_ -> [] ; private reduce291 = \dat\d\ds\docu\alts -> DatDcl {pos=yyline d, vis=Public, name=Token.value d, @@ -6164,249 +6217,261 @@ private reduce295 = vars=[], ctrs=[alt], defs=[], doc=Nothing} ; -private reduce296 = single +private reduce296 = + \dat\d\docu\pur\(jt,gargs) -> JavDcl {pos=yyline d, vis=Public, name=Token.value d, + jclas=jt, vars=[], defs=[], + gargs, + isPure = pur, + doc=Nothing} + ; -private reduce297 = (:) +private reduce297 = + \dat\d\ds\docu\pur\(jt,gargs) -> JavDcl {pos=yyline d, vis=Public, name=Token.value d, + jclas=jt, vars=ds, defs=[], + gargs, + isPure = pur, + doc=Nothing} + ; private reduce298 = single ; -private reduce299 = liste +private reduce299 = (:) +; +private reduce300 = single ; -private reduce301 = \dc\doc -> (dc::DConS).{doc = Just (Token.value doc)} +private reduce301 = liste ; -private reduce302 = \doc\dc -> (dc::DConS).{doc = Just (Token.value doc)} +private reduce303 = \dc\doc -> (dc::DConS).{doc = Just (Token.value doc)} ; -private reduce304 = \_\dc -> (dc::DConS).{vis = Public} +private reduce304 = \doc\dc -> (dc::DConS).{doc = Just (Token.value doc)} ; -private reduce305 = \_\dc -> (dc::DConS).{vis = Private} +private reduce306 = \_\dc -> (dc::DConS).{vis = Public} ; -private reduce306 = \_\dc -> (dc::DConS).{vis = Protected} +private reduce307 = \_\dc -> (dc::DConS).{vis = Private} ; -private reduce307 = \_\dcon -> DCon.{ -- strict=true, +private reduce308 = \_\dc -> (dc::DConS).{vis = Protected} +; +private reduce309 = \_\dcon -> DCon.{ -- strict=true, flds <-map ConField.{strict=true}} dcon ; -private reduce308 = \_\dcon -> DCon.{ -- strict=false, +private reduce310 = \_\dcon -> DCon.{ -- strict=false, flds <-map ConField.{strict=false}} dcon ; -private reduce310 = \c -> DCon {pos=yyline c, vis=Public, -- strict=false, +private reduce312 = \c -> DCon {pos=yyline c, vis=Public, -- strict=false, name=Token.value c, flds=[], doc=Nothing } ; -private reduce311 = \c\_\fs\_ -> DCon {pos=yyline c, vis=Public, -- strict=false, +private reduce313 = \c\_\fs\_ -> DCon {pos=yyline c, vis=Public, -- strict=false, name=Token.value c, flds=fs, doc=Nothing } ; -private reduce312 = \c\fs -> DCon {pos=yyline c, vis=Public, -- strict=false, +private reduce314 = \c\fs -> DCon {pos=yyline c, vis=Public, -- strict=false, name=Token.value c, flds=fs, doc=Nothing } ; -private reduce313 = single +private reduce315 = single ; -private reduce314 = (:) +private reduce316 = (:) ; -private reduce316 = const ConField.{strict=true} +private reduce318 = const ConField.{strict=true} ; -private reduce317 = const ConField.{strict=false} +private reduce319 = const ConField.{strict=false} ; -private reduce318 = \tau -> case tau of +private reduce320 = \tau -> case tau of TSig s -> Field Position.null Nothing Nothing Public false s _ -> Field Position.null Nothing Nothing Public false (ForAll [] (RhoTau [] tau)) ; -private reduce319 = single +private reduce321 = single ; -private reduce320 = (:) +private reduce322 = (:) ; -private reduce322 = const +private reduce324 = const ; -private reduce323 = \cs\(d::Token) -> map ConField.{doc <- addDoc d.value} cs +private reduce325 = \cs\(d::Token) -> map ConField.{doc <- addDoc d.value} cs ; -private reduce324 = \as\c\ls -> as ++ ls +private reduce326 = \as\c\ls -> as ++ ls ; -private reduce325 = \as\(d::Token)\ls -> map ConField.{doc <- addDoc d.value} as ++ ls +private reduce327 = \as\(d::Token)\ls -> map ConField.{doc <- addDoc d.value} as ++ ls ; -private reduce326 = \(d::Maybe String)\vs\_\t -> +private reduce328 = \(d::Maybe String)\vs\_\t -> map (ConField.{doc=d} . ($t)) vs ; -private reduce327 = single +private reduce329 = single ; -private reduce328 = liste +private reduce330 = liste ; -private reduce330 = const (ConField.{vis=Public} .) +private reduce332 = const (ConField.{vis=Public} .) ; -private reduce331 = const (ConField.{vis=Private} .) +private reduce333 = const (ConField.{vis=Private} .) ; -private reduce333 = const (ConField.{strict=true} .) +private reduce335 = const (ConField.{strict=true} .) ; -private reduce334 = const (ConField.{strict=false} .) +private reduce336 = const (ConField.{strict=false} .) ; -private reduce335 = \v -> Field (yyline v) (Just v.value) Nothing Public false +private reduce337 = \v -> Field (yyline v) (Just v.value) Nothing Public false ; -private reduce336 = \t\i \_\r -> TypDcl {pos=yyline i, +private reduce338 = \t\i \_\r -> TypDcl {pos=yyline i, vis=Public, name=Token.value i, vars=[], typ = r, doc=Nothing} ; -private reduce337 = \t\i\vs\_\r -> TypDcl {pos=yyline i, +private reduce339 = \t\i\vs\_\r -> TypDcl {pos=yyline i, vis=Public, name=Token.value i, vars=vs, typ = r, doc=Nothing} ; -private reduce338 = [] -; -private reduce339 = \_\_\_ -> [] -; -private reduce340 = \_\_\defs\_ -> defs +private reduce340 = [] ; private reduce341 = \_\_\_ -> [] ; private reduce342 = \_\_\defs\_ -> defs ; -private reduce343 = \(ex,pats)\eq\expr -> fundef ex pats expr +private reduce343 = \_\_\_ -> [] ; -private reduce344 = \(ex,pats)\gds -> fungds ex pats gds +private reduce344 = \_\_\defs\_ -> defs ; -private reduce345 = \fdefs\defs -> - case fdefs of - [fd] | FunDcl {expr=x} <- fd = YYM.pure [fd.{expr = Let defs x}] - _ = do - yyerror (head fdefs).pos ("illegal function definition, where { ... } after annotation?") - YYM.pure fdefs - +private reduce345 = \(ex,pats)\eq\expr -> fundef ex pats expr +; +private reduce346 = \(ex,pats)\gds -> fungds ex pats gds ; -private reduce346 = \x -> do +private reduce347 = \(fd::FunDcl)\defs -> YYM.pure $ fd.{expr = Let defs fd.expr} +; +private reduce348 = \x -> do x <- funhead x YYM.pure x ; -private reduce347 = \x -> Lit (yyline x) LBool "true" false +private reduce349 = \x -> Lit (yyline x) LBool "true" false ; -private reduce348 = \x -> Lit (yyline x) LBool "false" false +private reduce350 = \x -> Lit (yyline x) LBool "false" false ; -private reduce349 = \x -> do litchar x +private reduce351 = \x -> do litchar x ; -private reduce350 = \x -> Lit (yyline x) LString (Token.value x) false +private reduce352 = \x -> Lit (yyline x) LString (Token.value x) false ; -private reduce351 = \x -> do litint x +private reduce353 = \x -> do litint x ; -private reduce352 = \x -> do litbig x +private reduce354 = \x -> do litbig x ; -private reduce353 = \x -> do litlong x +private reduce355 = \x -> do litlong x ; -private reduce354 = \x -> Lit (yyline x) LFloat (Token.value x) false +private reduce356 = \x -> Lit (yyline x) LFloat (Token.value x) false ; -private reduce355 = \x -> Lit (yyline x) LDouble (Token.value x) false +private reduce357 = \x -> Lit (yyline x) LDouble (Token.value x) false ; -private reduce356 = \x -> do litdec x +private reduce358 = \x -> do litdec x ; -private reduce357 = \x -> do litregexp x +private reduce359 = \x -> do litregexp x ; -private reduce362 = \e\t\x -> do { (ex,pat) <- funhead e; YYM.pure (Right (fundef ex pat x)) } +private reduce364 = \e\t\x -> do + (ex,pat) <- funhead e + YYM.pure $ Right $ single $ LetMemberS.Fun $ fundef ex pat x ; -private reduce363 = \_\_\ds\_ -> Right ds +private reduce365 = \_\_\ds\_ -> Right ds ; -private reduce364 = single +private reduce366 = single ; -private reduce365 = liste +private reduce367 = liste ; -private reduce366 = (const . single) +private reduce368 = (const . single) ; -private reduce367 = single +private reduce369 = single ; -private reduce368 = (const . single) +private reduce370 = (const . single) ; -private reduce369 = liste +private reduce371 = liste ; -private reduce370 = \e -> Left (Nothing, e) +private reduce372 = \e -> Left (Nothing, e) ; -private reduce371 = \p\g\e -> Left (Just p, e) +private reduce373 = \p\g\e -> Left (Just p, e) ; -private reduce372 = single +private reduce374 = single ; -private reduce373 = liste +private reduce375 = liste ; -private reduce374 = (const . single) +private reduce376 = (const . single) ; -private reduce375 = \a\qs\_\x -> (yyline a, qs, x) +private reduce377 = \a\qs\_\x -> (yyline a, qs, x) ; -private reduce376 = single +private reduce378 = single ; -private reduce377 = (:) +private reduce379 = (:) ; -private reduce378 = \p\a\e -> +private reduce380 = \p\a\e -> CAlt {pat=p, ex=e} ; -private reduce379 = \p\gs -> guardedalt p gs +private reduce381 = \p\gs -> guardedalt p gs ; -private reduce380 = \(calt::CAltS)\defs -> +private reduce382 = \(calt::CAltS)\defs -> let nx = Let defs calt.ex; in calt.{ ex = nx } ; -private reduce381 = single -; -private reduce382 = liste +private reduce383 = single ; -private reduce383 = \a\_ -> [a] +private reduce384 = liste ; -private reduce384 = \_\ps\b -> foldr (\p\x -> Lam p x false) b ps +private reduce385 = \a\_ -> [a] ; -private reduce386 = \_\x -> x +private reduce386 = \_\ps\b -> foldr (\p\x -> Lam p x false) b ps ; -private reduce387 = \x\_\t -> Ann {ex = x, typ=t} +private reduce388 = \_\x -> x ; -private reduce389 = flip const +private reduce389 = \x\_\t -> Ann {ex = x, typ=t} ; private reduce391 = flip const ; -private reduce393 = mkapp +private reduce393 = flip const ; -private reduce394 = mkapp +private reduce395 = mkapp ; -private reduce395 = \m\x -> nApp (Vbl (contextName m "negate")) x +private reduce396 = mkapp ; -private reduce397 = \_\c\_\t\_\e -> Ifte c t e +private reduce397 = \m\x -> nApp (Vbl (contextName m "negate")) x ; -private reduce398 = \_\e\_\_\as\_ -> Case CNormal e as +private reduce399 = \_\c\_\t\_\e -> Ifte c t e ; -private reduce399 = \_\_\ds\_\_\e -> Let ds e +private reduce400 = \_\e\_\_\as\_ -> Case CNormal e as ; -private reduce401 = underscore +private reduce401 = \_\_\ds\_\_\e -> Let ds e ; -private reduce403 = nApp +private reduce403 = underscore ; -private reduce405 = \u\p -> nApp (Vbl {name=Simple u}) p +private reduce405 = nApp ; -private reduce406 = single +private reduce407 = \u\p -> nApp (Vbl {name=Simple u}) p ; -private reduce407 = (:) +private reduce408 = single ; -private reduce408 = With1 +private reduce409 = (:) ; -private reduce409 = With2 +private reduce410 = With1 ; -private reduce411 = \d\_\defs\_ -> do mkMonad (yyline d) defs +private reduce411 = With2 ; -private reduce412 = \p\_\(v::Token) -> umem p v id +private reduce413 = \d\_\defs\_ -> do mkMonad (yyline d) defs ; -private reduce413 = \p\_\v -> do {v <- unqualified v; +private reduce414 = \p\_\(v::Token) -> umem p v id +; +private reduce415 = \p\_\v -> do {v <- unqualified v; YYM.pure (umem p v id)} ; -private reduce414 = \p\_\v -> umem p v id +private reduce416 = \p\_\v -> umem p v id ; -private reduce415 = \q\_\(v::Token)\_\_ -> +private reduce417 = \q\_\(v::Token)\_\_ -> Vbl (q v.{value <- ("has$" ++)}) ; -private reduce416 = \q\_\(v::Token)\_\_ -> +private reduce418 = \q\_\(v::Token)\_\_ -> Vbl (q v.{value <- ("upd$" ++)}) ; -private reduce417 = \q\_\(v::Token)\_\_ -> +private reduce419 = \q\_\(v::Token)\_\_ -> Vbl (q v.{value <- ("chg$" ++)}) ; -private reduce418 = \q\(p::Token)\fs\_ -> let { +private reduce420 = \q\(p::Token)\fs\_ -> let { -- n = Simple q; flp = Vbl (wellKnown p "flip"); bul = Vbl (contextName p "•"); @@ -6418,63 +6483,63 @@ private reduce418 = \q\(p::Token)\fs\_ -> let { chup (r, false, e) = flp `nApp` Vbl (q r.{value <- ("upd$"++)}) `nApp` e; }} in c fs ; -private reduce419 = \p\_\_\(v::Token)\_\_ -> umem p v.{value <- ("has$"++)} id +private reduce421 = \p\_\_\(v::Token)\_\_ -> umem p v.{value <- ("has$"++)} id ; -private reduce420 = \p\_\_\(v::Token)\_\_ -> umem p v.{value <- ("upd$"++)} id +private reduce422 = \p\_\_\(v::Token)\_\_ -> umem p v.{value <- ("upd$"++)} id ; -private reduce421 = \p\_\_\(v::Token)\_\_ -> umem p v.{value <- ("chg$"++)} id +private reduce423 = \p\_\_\(v::Token)\_\_ -> umem p v.{value <- ("chg$"++)} id ; -private reduce422 = \x\(p::Token)\_\fs\_ -> +private reduce424 = \x\(p::Token)\_\fs\_ -> let { u x [] = x; u x ((r::Token, true , e):xs) = u (umem x r.{value <- ("chg$" ++)} (`nApp` e)) xs; u x ((r::Token, false, e):xs) = u (umem x r.{value <- ("upd$" ++)} (`nApp` e)) xs; } in u x fs ; -private reduce423 = \p\t\_\v\_ -> +private reduce425 = \p\t\_\v\_ -> let elem = t.{tokid = VARID, value = "elemAt"} in Vbl {name=Simple elem} `nApp` p `nApp` v ; -private reduce424 = \x -> Vbl {name=x} +private reduce426 = \x -> Vbl {name=x} ; -private reduce426 = \t -> Vbl {name = Simple t.{tokid=VARID, value="_"}} +private reduce428 = \t -> Vbl {name = Simple t.{tokid=VARID, value="_"}} ; -private reduce427 = \qc -> Con {name=qc} +private reduce429 = \qc -> Con {name=qc} ; -private reduce428 = \qc\_\z -> ConFS {name=qc, fields=[]} +private reduce430 = \qc\_\z -> ConFS {name=qc, fields=[]} ; -private reduce429 = \qc\_\fs\z -> ConFS {name=qc, fields=fs} +private reduce431 = \qc\_\fs\z -> ConFS {name=qc, fields=fs} ; -private reduce430 = \z\_ -> Con (fromBase z.{tokid=CONID, value="()"}) +private reduce432 = \z\_ -> Con (fromBase z.{tokid=CONID, value="()"}) ; -private reduce431 = \z\n\_ -> Con (fromBase z.{tokid=CONID, value=tuple (n+1)}) +private reduce433 = \z\n\_ -> Con (fromBase z.{tokid=CONID, value=tuple (n+1)}) ; -private reduce432 = \_\x\_ -> Vbl {name=Simple x} +private reduce434 = \_\x\_ -> Vbl {name=Simple x} ; -private reduce433 = \a\o\z -> Enclosed{firstT=a, lastT=z, ex=(varcon o) (opSname o)} +private reduce435 = \a\o\z -> Enclosed{firstT=a, lastT=z, ex=(varcon o) (opSname o)} ; -private reduce434 = \_\m\_ -> (Vbl (fromBase m)) +private reduce436 = \_\m\_ -> (Vbl (fromBase m)) ; -private reduce435 = \z\o\x\_ -> let -- (+1) --> flip (+) 1 +private reduce437 = \z\o\x\_ -> let -- (+1) --> flip (+) 1 flp = Vbl (contextName z "flip") op = (varcon o) (opSname o) ex = nApp (nApp flp op) x in ex ; -private reduce436 = \_\x\o\_ -> -- (1+) --> (+) 1 +private reduce438 = \_\x\o\_ -> -- (1+) --> (+) 1 nApp ((varcon o) (opSname o)) x ; -private reduce437 = \_\x\o\_ -> -- (1+) --> (+) 1 +private reduce439 = \_\x\o\_ -> -- (1+) --> (+) 1 nApp ((varcon o) (Simple o)) x ; -private reduce438 = \a\e\x\es\_ -> fold nApp (Con +private reduce440 = \a\e\x\es\_ -> fold nApp (Con (fromBase x.{tokid=CONID, value=tuple (1+length es)}) ) (e:es) ; -private reduce439 = \a\e\(x::Token)\es\_ -> do +private reduce441 = \a\e\(x::Token)\es\_ -> do g <- getST E.warn (yyline x) (PP.text "strict tuples are deprecated, use ',' to separate elements") pure ( @@ -6486,32 +6551,32 @@ private reduce439 = \a\e\(x::Token)\es\_ -> do ) ; -private reduce440 = \_\x\_ -> Term x +private reduce442 = \_\x\_ -> Term x ; -private reduce441 = \a\z -> Con (fromBase z.{tokid=CONID, value="[]"}) +private reduce443 = \a\z -> Con (fromBase z.{tokid=CONID, value="[]"}) ; -private reduce442 = \b\es\z -> +private reduce444 = \b\es\z -> foldr (\a\as -> nApp (nApp (Con (fromBase b.{tokid=CONID, value=":"})) a) as) (Con (fromBase z.{tokid=CONID, value="[]"})) es ; -private reduce443 = \a\b\c\d -> do mkEnumFrom a b c d +private reduce445 = \a\b\c\d -> do mkEnumFrom a b c d ; -private reduce444 = \a\b\c\d\e -> do mkEnumFromTo a b c d e +private reduce446 = \a\b\c\d\e -> do mkEnumFromTo a b c d e ; -private reduce445 = \(a::Token)\e\b\qs\(z::Token) -> do { +private reduce447 = \(a::Token)\e\b\qs\(z::Token) -> do { let {nil = z.{tokid=CONID, value="[]"}}; listComprehension (yyline b) e qs (Con {name = fromBase nil}) } ; -private reduce446 = const 1 +private reduce448 = const 1 ; -private reduce447 = ((+) . const 1) +private reduce449 = ((+) . const 1) ; -private reduce448 = single +private reduce450 = single ; -private reduce449 = \a\c\ls -> +private reduce451 = \a\c\ls -> if elemBy (using fst) a ls then do { E.warn (yyline c) (msgdoc ("field `" ++ fst a ++ "` should appear only once.")); @@ -6520,35 +6585,35 @@ private reduce449 = \a\c\ls -> YYM.pure (a:ls) ; -private reduce450 = (const . single) +private reduce452 = (const . single) ; -private reduce451 = single +private reduce453 = single ; -private reduce452 = liste +private reduce454 = liste ; -private reduce453 = (const . single) +private reduce455 = (const . single) ; -private reduce454 = \s\_\x -> (s, true, x) +private reduce456 = \s\_\x -> (s, true, x) ; -private reduce455 = \s\_\x -> (s, false, x) +private reduce457 = \s\_\x -> (s, false, x) ; -private reduce456 = \s -> (s, false, Vbl (Simple s)) +private reduce458 = \s -> (s, false, Vbl (Simple s)) ; -private reduce457 = \s\_\x -> (Token.value s, x) +private reduce459 = \s\_\x -> (Token.value s, x) ; -private reduce458 = \s -> (s.value, Vbl (Simple s)) +private reduce460 = \s -> (s.value, Vbl (Simple s)) ; -private reduce459 = single +private reduce461 = single ; -private reduce460 = liste +private reduce462 = liste ; -private reduce461 = (const . single) +private reduce463 = (const . single) ; -private reduce462 = single +private reduce464 = single ; -private reduce463 = liste +private reduce465 = liste ; -private reduce464 = (const . single) +private reduce466 = (const . single) ; yyrule 1 = "module: docsO moduleclause ';' definitions"; yyrule 2 = "module: docsO moduleclause WHERE '{' definitions '}'"; @@ -6666,354 +6731,356 @@ yyrule 113 = "jtokens: '{' '}' jtokens"; yyrule 114 = "documentation: DOCUMENTATION"; yyrule 115 = "publicdefinition: typedef"; yyrule 116 = "publicdefinition: datadef"; -yyrule 117 = "publicdefinition: classdef"; -yyrule 118 = "publicdefinition: instdef"; -yyrule 119 = "publicdefinition: derivedef"; -yyrule 120 = "publicdefinition: localdef"; -yyrule 121 = "localdefs: dplocaldef"; -yyrule 122 = "localdefs: dplocaldef ';'"; -yyrule 123 = "localdefs: dplocaldef ';' localdefs"; -yyrule 124 = "localdef: annotation"; -yyrule 125 = "localdef: nativedef"; -yyrule 126 = "localdef: fundef"; -yyrule 127 = "plocaldef: localdef"; -yyrule 128 = "plocaldef: PRIVATE localdef"; -yyrule 129 = "plocaldef: PROTECTED localdef"; -yyrule 130 = "plocaldef: PUBLIC localdef"; -yyrule 131 = "dplocaldef: documentation"; -yyrule 132 = "dplocaldef: documentation dplocaldef"; -yyrule 133 = "dplocaldef: plocaldef"; -yyrule 134 = "letdef: annotation"; -yyrule 135 = "letdef: fundef"; -yyrule 136 = "letdefs: letdef"; -yyrule 137 = "letdefs: letdef ';'"; -yyrule 138 = "letdefs: letdef ';' letdefs"; -yyrule 139 = "import: IMPORT modulename importliste"; -yyrule 140 = "import: IMPORT modulename VARID CONID importliste"; -yyrule 141 = "import: IMPORT modulename CONID importliste"; -yyrule 142 = "importliste: "; -yyrule 143 = "importliste: varid '(' importspecs ')'"; -yyrule 144 = "importliste: '(' ')'"; -yyrule 145 = "importliste: '(' importspecs ')'"; -yyrule 146 = "importliste: PUBLIC importliste"; -yyrule 147 = "importspecs: importspec"; -yyrule 148 = "importspecs: importspec ','"; -yyrule 149 = "importspecs: importspec ',' importspecs"; -yyrule 150 = "importitem: qvarid"; -yyrule 151 = "importitem: CONID '(' memspecs ')'"; -yyrule 152 = "importitem: CONID '(' ')'"; -yyrule 153 = "importitem: qconid"; -yyrule 154 = "importitem: operator"; -yyrule 155 = "importitem: unop"; -yyrule 156 = "importspec: importitem"; -yyrule 157 = "importspec: importitem alias"; -yyrule 158 = "importspec: PUBLIC importspec"; -yyrule 159 = "memspec: alias"; -yyrule 160 = "memspec: alias alias"; -yyrule 161 = "memspec: PUBLIC memspec"; -yyrule 162 = "memspecs: memspec"; -yyrule 163 = "memspecs: memspec ','"; -yyrule 164 = "memspecs: memspec ',' memspecs"; -yyrule 165 = "alias: VARID"; -yyrule 166 = "alias: CONID"; -yyrule 167 = "alias: operator"; -yyrule 168 = "varid: VARID"; -yyrule 169 = "varidkw: VARID"; -yyrule 170 = "varidkw: DATA"; -yyrule 171 = "varidkw: TYPE"; -yyrule 172 = "varidkw: NATIVE"; -yyrule 173 = "varidkw: PURE"; -yyrule 174 = "varidkw: PACKAGE"; -yyrule 175 = "varidkw: IMPORT"; -yyrule 176 = "qvarids: qvarop"; -yyrule 177 = "qvarids: qvarop ',' qvarids"; -yyrule 178 = "qvarid: QUALIFIER QUALIFIER varop"; -yyrule 179 = "qvarid: QUALIFIER varop"; -yyrule 180 = "qvarid: VARID"; -yyrule 181 = "qconid: QUALIFIER QUALIFIER CONID"; -yyrule 182 = "qconid: QUALIFIER CONID"; -yyrule 183 = "qconid: CONID"; -yyrule 184 = "varop: VARID"; -yyrule 185 = "varop: unop"; -yyrule 186 = "qvarop: QUALIFIER QUALIFIER varop"; -yyrule 187 = "qvarop: QUALIFIER varop"; -yyrule 188 = "qvarop: varop"; -yyrule 189 = "qvarop: operator"; -yyrule 190 = "operator: SOMEOP"; -yyrule 191 = "unop: '!'"; -yyrule 192 = "unop: '?'"; -yyrule 193 = "fixity: INFIX INTCONST"; -yyrule 194 = "fixity: INFIXL INTCONST"; -yyrule 195 = "fixity: INFIXR INTCONST"; -yyrule 196 = "opstring: operator"; -yyrule 197 = "opstring: VARID"; -yyrule 198 = "opstring: '-'"; -yyrule 199 = "operators: opstring"; -yyrule 200 = "operators: opstring operators"; -yyrule 201 = "infix: fixity operators"; -yyrule 202 = "annotation: annoitems DCOLON sigma"; -yyrule 203 = "annoitem: varid"; -yyrule 204 = "annoitem: '(' operator ')'"; -yyrule 205 = "annoitem: '(' unop ')'"; -yyrule 206 = "annoitem: '(' '-' ')'"; -yyrule 207 = "annoitems: annoitem"; -yyrule 208 = "annoitems: annoitem ',' annoitems"; -yyrule 209 = "nativedef: PURE impurenativedef"; -yyrule 210 = "nativedef: impurenativedef"; -yyrule 211 = "fitem: annoitem"; -yyrule 212 = "fitem: unop"; -yyrule 213 = "fitem: '-'"; -yyrule 214 = "fitem: operator"; -yyrule 215 = "jitem: nativename"; -yyrule 216 = "jitem: operator"; -yyrule 217 = "jitem: unop"; -yyrule 218 = "methodspec: fitem jitem gargs"; -yyrule 219 = "methodspec: fitem jitem"; -yyrule 220 = "methodspec: fitem gargs"; -yyrule 221 = "methodspec: fitem"; -yyrule 222 = "sigex: sigma THROWS tauSC"; -yyrule 223 = "sigex: sigma"; -yyrule 224 = "sigexs: sigex"; -yyrule 225 = "sigexs: sigex '|' sigexs"; -yyrule 226 = "impurenativedef: NATIVE methodspec DCOLON sigexs"; -yyrule 227 = "sigma: forall"; -yyrule 228 = "sigma: rho"; -yyrule 229 = "forall: FORALL dvars mbdot rho"; -yyrule 230 = "mbdot: '.'"; -yyrule 231 = "mbdot: SOMEOP"; -yyrule 232 = "rho: tapp EARROW rhofun"; -yyrule 233 = "rho: rhofun"; -yyrule 234 = "rhofun: tapp"; -yyrule 235 = "rhofun: tapp ARROW rhofun"; -yyrule 236 = "tau: tapp"; -yyrule 237 = "tau: forall"; -yyrule 238 = "tau: tapp ARROW tau"; -yyrule 239 = "tauSC: tau"; -yyrule 240 = "tauSC: tau ',' tauSC"; -yyrule 241 = "tauSB: tau"; -yyrule 242 = "tauSB: tau '|' tauSB"; -yyrule 243 = "tapp: simpletypes"; -yyrule 244 = "simpletype: tyvar"; -yyrule 245 = "simpletype: tyname"; -yyrule 246 = "simpletype: '(' tau ')'"; -yyrule 247 = "simpletype: '(' tau ',' tauSC ')'"; -yyrule 248 = "simpletype: '(' tau '|' tauSB ')'"; -yyrule 249 = "simpletype: '[' tau ']'"; -yyrule 250 = "tyvar: VARID"; -yyrule 251 = "tyvar: '(' VARID DCOLON kind ')'"; -yyrule 252 = "tyvar: '(' VARID EXTENDS tauSC ')'"; -yyrule 253 = "tyvar: '(' EXTENDS tauSC ')'"; -yyrule 254 = "tyvar: '(' SUPER tapp ')'"; -yyrule 255 = "tyname: qconid"; -yyrule 256 = "tyname: '[' ']'"; -yyrule 257 = "tyname: '(' ')'"; -yyrule 258 = "tyname: '(' commata ')'"; -yyrule 259 = "tyname: '(' ARROW ')'"; -yyrule 260 = "kind: simplekind ARROW kind"; -yyrule 261 = "kind: simplekind"; -yyrule 262 = "simplekind: SOMEOP"; -yyrule 263 = "simplekind: '(' kind ')'"; -yyrule 264 = "scontext: qconid tyvar"; -yyrule 265 = "scontexts: scontext"; -yyrule 266 = "scontexts: scontext ','"; -yyrule 267 = "scontexts: scontext ',' scontexts"; -yyrule 268 = "ccontext: scontext"; -yyrule 269 = "ccontext: '(' scontexts ')'"; -yyrule 270 = "classdef: CLASS ccontext EARROW CONID tyvar wheredef"; -yyrule 271 = "classdef: CLASS ccontext wheredef"; -yyrule 272 = "sicontext: qconid simpletype"; -yyrule 273 = "sicontexts: sicontext"; -yyrule 274 = "sicontexts: sicontext ','"; -yyrule 275 = "sicontexts: sicontext ',' sicontexts"; -yyrule 276 = "icontext: sicontext"; -yyrule 277 = "icontext: '(' sicontexts ')'"; -yyrule 278 = "insthead: icontext EARROW tyname simpletype"; -yyrule 279 = "insthead: icontext"; -yyrule 280 = "instdef: INSTANCE insthead wheredef"; -yyrule 281 = "derivedef: DERIVE insthead"; -yyrule 282 = "datadef: datainit wheredef"; -yyrule 283 = "nativepur: PURE NATIVE"; -yyrule 284 = "nativepur: NATIVE"; -yyrule 285 = "nativespec: nativename"; -yyrule 286 = "nativespec: nativename gargs"; -yyrule 287 = "gargs: '{' tauSC '}'"; -yyrule 288 = "gargs: '{' '}'"; -yyrule 289 = "datainit: DATA CONID '=' nativepur nativespec"; -yyrule 290 = "datainit: DATA CONID dvars '=' nativepur nativespec"; +yyrule 117 = "publicdefinition: datajavadef"; +yyrule 118 = "publicdefinition: classdef"; +yyrule 119 = "publicdefinition: instdef"; +yyrule 120 = "publicdefinition: derivedef"; +yyrule 121 = "publicdefinition: localdef"; +yyrule 122 = "localdefs: dplocaldef"; +yyrule 123 = "localdefs: dplocaldef ';'"; +yyrule 124 = "localdefs: dplocaldef ';' localdefs"; +yyrule 125 = "localdef: annotation"; +yyrule 126 = "localdef: nativedef"; +yyrule 127 = "localdef: fundef"; +yyrule 128 = "plocaldef: localdef"; +yyrule 129 = "plocaldef: PRIVATE localdef"; +yyrule 130 = "plocaldef: PROTECTED localdef"; +yyrule 131 = "plocaldef: PUBLIC localdef"; +yyrule 132 = "dplocaldef: documentation"; +yyrule 133 = "dplocaldef: documentation dplocaldef"; +yyrule 134 = "dplocaldef: plocaldef"; +yyrule 135 = "letdef: annotation"; +yyrule 136 = "letdef: fundef"; +yyrule 137 = "letdefs: letdef"; +yyrule 138 = "letdefs: letdef ';'"; +yyrule 139 = "letdefs: letdef ';' letdefs"; +yyrule 140 = "import: IMPORT modulename importliste"; +yyrule 141 = "import: IMPORT modulename VARID CONID importliste"; +yyrule 142 = "import: IMPORT modulename CONID importliste"; +yyrule 143 = "importliste: "; +yyrule 144 = "importliste: varid '(' importspecs ')'"; +yyrule 145 = "importliste: '(' ')'"; +yyrule 146 = "importliste: '(' importspecs ')'"; +yyrule 147 = "importliste: PUBLIC importliste"; +yyrule 148 = "importspecs: importspec"; +yyrule 149 = "importspecs: importspec ','"; +yyrule 150 = "importspecs: importspec ',' importspecs"; +yyrule 151 = "importitem: qvarid"; +yyrule 152 = "importitem: CONID '(' memspecs ')'"; +yyrule 153 = "importitem: CONID '(' ')'"; +yyrule 154 = "importitem: qconid"; +yyrule 155 = "importitem: operator"; +yyrule 156 = "importitem: unop"; +yyrule 157 = "importspec: importitem"; +yyrule 158 = "importspec: importitem alias"; +yyrule 159 = "importspec: PUBLIC importspec"; +yyrule 160 = "memspec: alias"; +yyrule 161 = "memspec: alias alias"; +yyrule 162 = "memspec: PUBLIC memspec"; +yyrule 163 = "memspecs: memspec"; +yyrule 164 = "memspecs: memspec ','"; +yyrule 165 = "memspecs: memspec ',' memspecs"; +yyrule 166 = "alias: VARID"; +yyrule 167 = "alias: CONID"; +yyrule 168 = "alias: operator"; +yyrule 169 = "varid: VARID"; +yyrule 170 = "varidkw: VARID"; +yyrule 171 = "varidkw: DATA"; +yyrule 172 = "varidkw: TYPE"; +yyrule 173 = "varidkw: NATIVE"; +yyrule 174 = "varidkw: PURE"; +yyrule 175 = "varidkw: PACKAGE"; +yyrule 176 = "varidkw: IMPORT"; +yyrule 177 = "qvarids: qvarop"; +yyrule 178 = "qvarids: qvarop ',' qvarids"; +yyrule 179 = "qvarid: QUALIFIER QUALIFIER varop"; +yyrule 180 = "qvarid: QUALIFIER varop"; +yyrule 181 = "qvarid: VARID"; +yyrule 182 = "qconid: QUALIFIER QUALIFIER CONID"; +yyrule 183 = "qconid: QUALIFIER CONID"; +yyrule 184 = "qconid: CONID"; +yyrule 185 = "varop: VARID"; +yyrule 186 = "varop: unop"; +yyrule 187 = "qvarop: QUALIFIER QUALIFIER varop"; +yyrule 188 = "qvarop: QUALIFIER varop"; +yyrule 189 = "qvarop: varop"; +yyrule 190 = "qvarop: operator"; +yyrule 191 = "operator: SOMEOP"; +yyrule 192 = "unop: '!'"; +yyrule 193 = "unop: '?'"; +yyrule 194 = "fixity: INFIX INTCONST"; +yyrule 195 = "fixity: INFIXL INTCONST"; +yyrule 196 = "fixity: INFIXR INTCONST"; +yyrule 197 = "opstring: operator"; +yyrule 198 = "opstring: VARID"; +yyrule 199 = "opstring: '-'"; +yyrule 200 = "operators: opstring"; +yyrule 201 = "operators: opstring operators"; +yyrule 202 = "infix: fixity operators"; +yyrule 203 = "annotation: annoitems DCOLON sigma"; +yyrule 204 = "annoitem: varid"; +yyrule 205 = "annoitem: '(' operator ')'"; +yyrule 206 = "annoitem: '(' unop ')'"; +yyrule 207 = "annoitem: '(' '-' ')'"; +yyrule 208 = "annoitems: annoitem"; +yyrule 209 = "annoitems: annoitem ',' annoitems"; +yyrule 210 = "nativedef: PURE impurenativedef"; +yyrule 211 = "nativedef: impurenativedef"; +yyrule 212 = "fitem: annoitem"; +yyrule 213 = "fitem: unop"; +yyrule 214 = "fitem: '-'"; +yyrule 215 = "fitem: operator"; +yyrule 216 = "jitem: nativename"; +yyrule 217 = "jitem: operator"; +yyrule 218 = "jitem: unop"; +yyrule 219 = "methodspec: fitem jitem gargs"; +yyrule 220 = "methodspec: fitem jitem"; +yyrule 221 = "methodspec: fitem gargs"; +yyrule 222 = "methodspec: fitem"; +yyrule 223 = "sigex: sigma THROWS tauSC"; +yyrule 224 = "sigex: sigma"; +yyrule 225 = "sigexs: sigex"; +yyrule 226 = "sigexs: sigex '|' sigexs"; +yyrule 227 = "impurenativedef: NATIVE methodspec DCOLON sigexs"; +yyrule 228 = "sigma: forall"; +yyrule 229 = "sigma: rho"; +yyrule 230 = "forall: FORALL dvars mbdot rho"; +yyrule 231 = "mbdot: '.'"; +yyrule 232 = "mbdot: SOMEOP"; +yyrule 233 = "rho: tapp EARROW rhofun"; +yyrule 234 = "rho: rhofun"; +yyrule 235 = "rhofun: tapp"; +yyrule 236 = "rhofun: tapp ARROW rhofun"; +yyrule 237 = "tau: tapp"; +yyrule 238 = "tau: forall"; +yyrule 239 = "tau: tapp ARROW tau"; +yyrule 240 = "tauSC: tau"; +yyrule 241 = "tauSC: tau ',' tauSC"; +yyrule 242 = "tauSB: tau"; +yyrule 243 = "tauSB: tau '|' tauSB"; +yyrule 244 = "tapp: simpletypes"; +yyrule 245 = "simpletype: tyvar"; +yyrule 246 = "simpletype: tyname"; +yyrule 247 = "simpletype: '(' tau ')'"; +yyrule 248 = "simpletype: '(' tau ',' tauSC ')'"; +yyrule 249 = "simpletype: '(' tau '|' tauSB ')'"; +yyrule 250 = "simpletype: '[' tau ']'"; +yyrule 251 = "tyvar: VARID"; +yyrule 252 = "tyvar: '(' VARID DCOLON kind ')'"; +yyrule 253 = "tyvar: '(' VARID EXTENDS tauSC ')'"; +yyrule 254 = "tyvar: '(' EXTENDS tauSC ')'"; +yyrule 255 = "tyvar: '(' SUPER tapp ')'"; +yyrule 256 = "tyname: qconid"; +yyrule 257 = "tyname: '[' ']'"; +yyrule 258 = "tyname: '(' ')'"; +yyrule 259 = "tyname: '(' commata ')'"; +yyrule 260 = "tyname: '(' ARROW ')'"; +yyrule 261 = "kind: simplekind ARROW kind"; +yyrule 262 = "kind: simplekind"; +yyrule 263 = "simplekind: SOMEOP"; +yyrule 264 = "simplekind: '(' kind ')'"; +yyrule 265 = "scontext: qconid tyvar"; +yyrule 266 = "scontexts: scontext"; +yyrule 267 = "scontexts: scontext ','"; +yyrule 268 = "scontexts: scontext ',' scontexts"; +yyrule 269 = "ccontext: scontext"; +yyrule 270 = "ccontext: '(' scontexts ')'"; +yyrule 271 = "classdef: CLASS ccontext EARROW CONID tyvar wheredef"; +yyrule 272 = "classdef: CLASS ccontext wheredef"; +yyrule 273 = "sicontext: qconid simpletype"; +yyrule 274 = "sicontexts: sicontext"; +yyrule 275 = "sicontexts: sicontext ','"; +yyrule 276 = "sicontexts: sicontext ',' sicontexts"; +yyrule 277 = "icontext: sicontext"; +yyrule 278 = "icontext: '(' sicontexts ')'"; +yyrule 279 = "insthead: icontext EARROW tyname simpletype"; +yyrule 280 = "insthead: icontext"; +yyrule 281 = "instdef: INSTANCE insthead wheredef"; +yyrule 282 = "derivedef: DERIVE insthead"; +yyrule 283 = "datadef: datainit wheredef"; +yyrule 284 = "datajavadef: datajavainit wheredef"; +yyrule 285 = "nativepur: PURE NATIVE"; +yyrule 286 = "nativepur: NATIVE"; +yyrule 287 = "nativespec: nativename"; +yyrule 288 = "nativespec: nativename gargs"; +yyrule 289 = "gargs: '{' tauSC '}'"; +yyrule 290 = "gargs: '{' '}'"; yyrule 291 = "datainit: DATA CONID dvars '=' dalts"; yyrule 292 = "datainit: DATA CONID '=' dalts"; yyrule 293 = "datainit: DATA CONID"; yyrule 294 = "datainit: NEWTYPE CONID dvars '=' dalt"; yyrule 295 = "datainit: NEWTYPE CONID '=' dalt"; -yyrule 296 = "dvars: tyvar"; -yyrule 297 = "dvars: tyvar dvars"; -yyrule 298 = "dalts: dalt"; -yyrule 299 = "dalts: dalt '|' dalts"; -yyrule 300 = "dalt: visdalt"; -yyrule 301 = "dalt: visdalt DOCUMENTATION"; -yyrule 302 = "dalt: DOCUMENTATION visdalt"; -yyrule 303 = "visdalt: strictdalt"; -yyrule 304 = "visdalt: PUBLIC strictdalt"; -yyrule 305 = "visdalt: PRIVATE strictdalt"; -yyrule 306 = "visdalt: PROTECTED strictdalt"; -yyrule 307 = "strictdalt: '!' simpledalt"; -yyrule 308 = "strictdalt: '?' simpledalt"; -yyrule 309 = "strictdalt: simpledalt"; -yyrule 310 = "simpledalt: CONID"; -yyrule 311 = "simpledalt: CONID '{' conflds '}'"; -yyrule 312 = "simpledalt: CONID contypes"; -yyrule 313 = "contypes: strictcontype"; -yyrule 314 = "contypes: strictcontype contypes"; -yyrule 315 = "strictcontype: contype"; -yyrule 316 = "strictcontype: '!' contype"; -yyrule 317 = "strictcontype: '?' contype"; -yyrule 318 = "contype: simpletype"; -yyrule 319 = "simpletypes: simpletype"; -yyrule 320 = "simpletypes: simpletype simpletypes"; -yyrule 321 = "conflds: confld"; -yyrule 322 = "conflds: confld ','"; -yyrule 323 = "conflds: confld DOCUMENTATION"; -yyrule 324 = "conflds: confld ',' conflds"; -yyrule 325 = "conflds: confld DOCUMENTATION conflds"; -yyrule 326 = "confld: docsO fldids DCOLON sigma"; -yyrule 327 = "fldids: fldid"; -yyrule 328 = "fldids: fldid ',' fldids"; -yyrule 329 = "fldid: strictfldid"; -yyrule 330 = "fldid: PUBLIC strictfldid"; -yyrule 331 = "fldid: PRIVATE strictfldid"; -yyrule 332 = "strictfldid: plainfldid"; -yyrule 333 = "strictfldid: '!' plainfldid"; -yyrule 334 = "strictfldid: '?' plainfldid"; -yyrule 335 = "plainfldid: varid"; -yyrule 336 = "typedef: TYPE CONID '=' sigma"; -yyrule 337 = "typedef: TYPE CONID dvars '=' sigma"; -yyrule 338 = "wheredef: "; -yyrule 339 = "wheredef: WHERE '{' '}'"; -yyrule 340 = "wheredef: WHERE '{' localdefs '}'"; -yyrule 341 = "wherelet: WHERE '{' '}'"; -yyrule 342 = "wherelet: WHERE '{' letdefs '}'"; -yyrule 343 = "fundef: funhead '=' expr"; -yyrule 344 = "fundef: funhead guards"; -yyrule 345 = "fundef: fundef wherelet"; -yyrule 346 = "funhead: binex"; -yyrule 347 = "literal: TRUE"; -yyrule 348 = "literal: FALSE"; -yyrule 349 = "literal: CHRCONST"; -yyrule 350 = "literal: STRCONST"; -yyrule 351 = "literal: INTCONST"; -yyrule 352 = "literal: BIGCONST"; -yyrule 353 = "literal: LONGCONST"; -yyrule 354 = "literal: FLTCONST"; -yyrule 355 = "literal: DBLCONST"; -yyrule 356 = "literal: DECCONST"; -yyrule 357 = "literal: REGEXP"; -yyrule 358 = "pattern: expr"; -yyrule 359 = "aeq: ARROW"; -yyrule 360 = "aeq: '='"; -yyrule 361 = "lcqual: gqual"; -yyrule 362 = "lcqual: expr '=' expr"; -yyrule 363 = "lcqual: LET '{' letdefs '}'"; -yyrule 364 = "lcquals: lcqual"; -yyrule 365 = "lcquals: lcqual ',' lcquals"; -yyrule 366 = "lcquals: lcqual ','"; -yyrule 367 = "dodefs: lcqual"; -yyrule 368 = "dodefs: lcqual ';'"; -yyrule 369 = "dodefs: lcqual ';' dodefs"; -yyrule 370 = "gqual: expr"; -yyrule 371 = "gqual: expr GETS expr"; -yyrule 372 = "gquals: gqual"; -yyrule 373 = "gquals: gqual ',' gquals"; -yyrule 374 = "gquals: gqual ','"; -yyrule 375 = "guard: '|' gquals aeq expr"; -yyrule 376 = "guards: guard"; -yyrule 377 = "guards: guard guards"; -yyrule 378 = "calt: pattern aeq expr"; -yyrule 379 = "calt: pattern guards"; -yyrule 380 = "calt: calt wherelet"; -yyrule 381 = "calts: calt"; -yyrule 382 = "calts: calt ';' calts"; -yyrule 383 = "calts: calt ';'"; -yyrule 384 = "lambda: '\\' apats lambdabody"; -yyrule 385 = "lambdabody: lambda"; -yyrule 386 = "lambdabody: ARROW expr"; -yyrule 387 = "expr: binex DCOLON sigma"; -yyrule 388 = "expr: binex"; -yyrule 389 = "thenx: ';' THEN"; -yyrule 390 = "thenx: THEN"; -yyrule 391 = "elsex: ';' ELSE"; -yyrule 392 = "elsex: ELSE"; -yyrule 393 = "binex: binex SOMEOP binex"; -yyrule 394 = "binex: binex '-' binex"; -yyrule 395 = "binex: '-' topex"; -yyrule 396 = "binex: topex"; -yyrule 397 = "topex: IF expr thenx expr elsex expr"; -yyrule 398 = "topex: CASE expr OF '{' calts '}'"; -yyrule 399 = "topex: LET '{' letdefs '}' IN expr"; -yyrule 400 = "topex: lambda"; -yyrule 401 = "topex: appex"; -yyrule 402 = "appex: unex"; -yyrule 403 = "appex: appex unex"; -yyrule 404 = "unex: primary"; -yyrule 405 = "unex: unop unex"; -yyrule 406 = "apats: unex"; -yyrule 407 = "apats: unex apats"; -yyrule 408 = "qualifiers: QUALIFIER"; -yyrule 409 = "qualifiers: QUALIFIER QUALIFIER"; -yyrule 410 = "primary: term"; -yyrule 411 = "primary: DO '{' dodefs '}'"; -yyrule 412 = "primary: primary '.' VARID"; -yyrule 413 = "primary: primary '.' operator"; -yyrule 414 = "primary: primary '.' unop"; -yyrule 415 = "primary: qualifiers '{' VARID '?' '}'"; -yyrule 416 = "primary: qualifiers '{' VARID '=' '}'"; -yyrule 417 = "primary: qualifiers '{' VARID GETS '}'"; -yyrule 418 = "primary: qualifiers '{' getfields '}'"; -yyrule 419 = "primary: primary '.' '{' VARID '?' '}'"; -yyrule 420 = "primary: primary '.' '{' VARID '=' '}'"; -yyrule 421 = "primary: primary '.' '{' VARID GETS '}'"; -yyrule 422 = "primary: primary '.' '{' getfields '}'"; -yyrule 423 = "primary: primary '.' '[' expr ']'"; -yyrule 424 = "term: qvarid"; -yyrule 425 = "term: literal"; -yyrule 426 = "term: '_'"; -yyrule 427 = "term: qconid"; -yyrule 428 = "term: qconid '{' '}'"; -yyrule 429 = "term: qconid '{' fields '}'"; -yyrule 430 = "term: '(' ')'"; -yyrule 431 = "term: '(' commata ')'"; -yyrule 432 = "term: '(' unop ')'"; -yyrule 433 = "term: '(' operator ')'"; -yyrule 434 = "term: '(' '-' ')'"; -yyrule 435 = "term: '(' operator expr ')'"; -yyrule 436 = "term: '(' binex operator ')'"; -yyrule 437 = "term: '(' binex '-' ')'"; -yyrule 438 = "term: '(' expr ',' exprSC ')'"; -yyrule 439 = "term: '(' expr ';' exprSS ')'"; -yyrule 440 = "term: '(' expr ')'"; -yyrule 441 = "term: '[' ']'"; -yyrule 442 = "term: '[' exprSC ']'"; -yyrule 443 = "term: '[' exprSC DOTDOT ']'"; -yyrule 444 = "term: '[' exprSC DOTDOT expr ']'"; -yyrule 445 = "term: '[' expr '|' lcquals ']'"; -yyrule 446 = "commata: ','"; -yyrule 447 = "commata: ',' commata"; -yyrule 448 = "fields: field"; -yyrule 449 = "fields: field ',' fields"; -yyrule 450 = "fields: field ','"; -yyrule 451 = "getfields: getfield"; -yyrule 452 = "getfields: getfield ',' getfields"; -yyrule 453 = "getfields: getfield ','"; -yyrule 454 = "getfield: VARID GETS expr"; -yyrule 455 = "getfield: VARID '=' expr"; -yyrule 456 = "getfield: VARID"; -yyrule 457 = "field: varid '=' expr"; -yyrule 458 = "field: varid"; -yyrule 459 = "exprSC: expr"; -yyrule 460 = "exprSC: expr ',' exprSC"; -yyrule 461 = "exprSC: expr ','"; -yyrule 462 = "exprSS: expr"; -yyrule 463 = "exprSS: expr ';' exprSS"; -yyrule 464 = "exprSS: expr ';'"; +yyrule 296 = "datajavainit: DATA CONID '=' nativepur nativespec"; +yyrule 297 = "datajavainit: DATA CONID dvars '=' nativepur nativespec"; +yyrule 298 = "dvars: tyvar"; +yyrule 299 = "dvars: tyvar dvars"; +yyrule 300 = "dalts: dalt"; +yyrule 301 = "dalts: dalt '|' dalts"; +yyrule 302 = "dalt: visdalt"; +yyrule 303 = "dalt: visdalt DOCUMENTATION"; +yyrule 304 = "dalt: DOCUMENTATION visdalt"; +yyrule 305 = "visdalt: strictdalt"; +yyrule 306 = "visdalt: PUBLIC strictdalt"; +yyrule 307 = "visdalt: PRIVATE strictdalt"; +yyrule 308 = "visdalt: PROTECTED strictdalt"; +yyrule 309 = "strictdalt: '!' simpledalt"; +yyrule 310 = "strictdalt: '?' simpledalt"; +yyrule 311 = "strictdalt: simpledalt"; +yyrule 312 = "simpledalt: CONID"; +yyrule 313 = "simpledalt: CONID '{' conflds '}'"; +yyrule 314 = "simpledalt: CONID contypes"; +yyrule 315 = "contypes: strictcontype"; +yyrule 316 = "contypes: strictcontype contypes"; +yyrule 317 = "strictcontype: contype"; +yyrule 318 = "strictcontype: '!' contype"; +yyrule 319 = "strictcontype: '?' contype"; +yyrule 320 = "contype: simpletype"; +yyrule 321 = "simpletypes: simpletype"; +yyrule 322 = "simpletypes: simpletype simpletypes"; +yyrule 323 = "conflds: confld"; +yyrule 324 = "conflds: confld ','"; +yyrule 325 = "conflds: confld DOCUMENTATION"; +yyrule 326 = "conflds: confld ',' conflds"; +yyrule 327 = "conflds: confld DOCUMENTATION conflds"; +yyrule 328 = "confld: docsO fldids DCOLON sigma"; +yyrule 329 = "fldids: fldid"; +yyrule 330 = "fldids: fldid ',' fldids"; +yyrule 331 = "fldid: strictfldid"; +yyrule 332 = "fldid: PUBLIC strictfldid"; +yyrule 333 = "fldid: PRIVATE strictfldid"; +yyrule 334 = "strictfldid: plainfldid"; +yyrule 335 = "strictfldid: '!' plainfldid"; +yyrule 336 = "strictfldid: '?' plainfldid"; +yyrule 337 = "plainfldid: varid"; +yyrule 338 = "typedef: TYPE CONID '=' sigma"; +yyrule 339 = "typedef: TYPE CONID dvars '=' sigma"; +yyrule 340 = "wheredef: "; +yyrule 341 = "wheredef: WHERE '{' '}'"; +yyrule 342 = "wheredef: WHERE '{' localdefs '}'"; +yyrule 343 = "wherelet: WHERE '{' '}'"; +yyrule 344 = "wherelet: WHERE '{' letdefs '}'"; +yyrule 345 = "fundef: funhead '=' expr"; +yyrule 346 = "fundef: funhead guards"; +yyrule 347 = "fundef: fundef wherelet"; +yyrule 348 = "funhead: binex"; +yyrule 349 = "literal: TRUE"; +yyrule 350 = "literal: FALSE"; +yyrule 351 = "literal: CHRCONST"; +yyrule 352 = "literal: STRCONST"; +yyrule 353 = "literal: INTCONST"; +yyrule 354 = "literal: BIGCONST"; +yyrule 355 = "literal: LONGCONST"; +yyrule 356 = "literal: FLTCONST"; +yyrule 357 = "literal: DBLCONST"; +yyrule 358 = "literal: DECCONST"; +yyrule 359 = "literal: REGEXP"; +yyrule 360 = "pattern: expr"; +yyrule 361 = "aeq: ARROW"; +yyrule 362 = "aeq: '='"; +yyrule 363 = "lcqual: gqual"; +yyrule 364 = "lcqual: expr '=' expr"; +yyrule 365 = "lcqual: LET '{' letdefs '}'"; +yyrule 366 = "lcquals: lcqual"; +yyrule 367 = "lcquals: lcqual ',' lcquals"; +yyrule 368 = "lcquals: lcqual ','"; +yyrule 369 = "dodefs: lcqual"; +yyrule 370 = "dodefs: lcqual ';'"; +yyrule 371 = "dodefs: lcqual ';' dodefs"; +yyrule 372 = "gqual: expr"; +yyrule 373 = "gqual: expr GETS expr"; +yyrule 374 = "gquals: gqual"; +yyrule 375 = "gquals: gqual ',' gquals"; +yyrule 376 = "gquals: gqual ','"; +yyrule 377 = "guard: '|' gquals aeq expr"; +yyrule 378 = "guards: guard"; +yyrule 379 = "guards: guard guards"; +yyrule 380 = "calt: pattern aeq expr"; +yyrule 381 = "calt: pattern guards"; +yyrule 382 = "calt: calt wherelet"; +yyrule 383 = "calts: calt"; +yyrule 384 = "calts: calt ';' calts"; +yyrule 385 = "calts: calt ';'"; +yyrule 386 = "lambda: '\\' apats lambdabody"; +yyrule 387 = "lambdabody: lambda"; +yyrule 388 = "lambdabody: ARROW expr"; +yyrule 389 = "expr: binex DCOLON sigma"; +yyrule 390 = "expr: binex"; +yyrule 391 = "thenx: ';' THEN"; +yyrule 392 = "thenx: THEN"; +yyrule 393 = "elsex: ';' ELSE"; +yyrule 394 = "elsex: ELSE"; +yyrule 395 = "binex: binex SOMEOP binex"; +yyrule 396 = "binex: binex '-' binex"; +yyrule 397 = "binex: '-' topex"; +yyrule 398 = "binex: topex"; +yyrule 399 = "topex: IF expr thenx expr elsex expr"; +yyrule 400 = "topex: CASE expr OF '{' calts '}'"; +yyrule 401 = "topex: LET '{' letdefs '}' IN expr"; +yyrule 402 = "topex: lambda"; +yyrule 403 = "topex: appex"; +yyrule 404 = "appex: unex"; +yyrule 405 = "appex: appex unex"; +yyrule 406 = "unex: primary"; +yyrule 407 = "unex: unop unex"; +yyrule 408 = "apats: unex"; +yyrule 409 = "apats: unex apats"; +yyrule 410 = "qualifiers: QUALIFIER"; +yyrule 411 = "qualifiers: QUALIFIER QUALIFIER"; +yyrule 412 = "primary: term"; +yyrule 413 = "primary: DO '{' dodefs '}'"; +yyrule 414 = "primary: primary '.' VARID"; +yyrule 415 = "primary: primary '.' operator"; +yyrule 416 = "primary: primary '.' unop"; +yyrule 417 = "primary: qualifiers '{' VARID '?' '}'"; +yyrule 418 = "primary: qualifiers '{' VARID '=' '}'"; +yyrule 419 = "primary: qualifiers '{' VARID GETS '}'"; +yyrule 420 = "primary: qualifiers '{' getfields '}'"; +yyrule 421 = "primary: primary '.' '{' VARID '?' '}'"; +yyrule 422 = "primary: primary '.' '{' VARID '=' '}'"; +yyrule 423 = "primary: primary '.' '{' VARID GETS '}'"; +yyrule 424 = "primary: primary '.' '{' getfields '}'"; +yyrule 425 = "primary: primary '.' '[' expr ']'"; +yyrule 426 = "term: qvarid"; +yyrule 427 = "term: literal"; +yyrule 428 = "term: '_'"; +yyrule 429 = "term: qconid"; +yyrule 430 = "term: qconid '{' '}'"; +yyrule 431 = "term: qconid '{' fields '}'"; +yyrule 432 = "term: '(' ')'"; +yyrule 433 = "term: '(' commata ')'"; +yyrule 434 = "term: '(' unop ')'"; +yyrule 435 = "term: '(' operator ')'"; +yyrule 436 = "term: '(' '-' ')'"; +yyrule 437 = "term: '(' operator expr ')'"; +yyrule 438 = "term: '(' binex operator ')'"; +yyrule 439 = "term: '(' binex '-' ')'"; +yyrule 440 = "term: '(' expr ',' exprSC ')'"; +yyrule 441 = "term: '(' expr ';' exprSS ')'"; +yyrule 442 = "term: '(' expr ')'"; +yyrule 443 = "term: '[' ']'"; +yyrule 444 = "term: '[' exprSC ']'"; +yyrule 445 = "term: '[' exprSC DOTDOT ']'"; +yyrule 446 = "term: '[' exprSC DOTDOT expr ']'"; +yyrule 447 = "term: '[' expr '|' lcquals ']'"; +yyrule 448 = "commata: ','"; +yyrule 449 = "commata: ',' commata"; +yyrule 450 = "fields: field"; +yyrule 451 = "fields: field ',' fields"; +yyrule 452 = "fields: field ','"; +yyrule 453 = "getfields: getfield"; +yyrule 454 = "getfields: getfield ',' getfields"; +yyrule 455 = "getfields: getfield ','"; +yyrule 456 = "getfield: VARID GETS expr"; +yyrule 457 = "getfield: VARID '=' expr"; +yyrule 458 = "getfield: VARID"; +yyrule 459 = "field: varid '=' expr"; +yyrule 460 = "field: varid"; +yyrule 461 = "exprSC: expr"; +yyrule 462 = "exprSC: expr ',' exprSC"; +yyrule 463 = "exprSC: expr ','"; +yyrule 464 = "exprSS: expr"; +yyrule 465 = "exprSS: expr ';' exprSS"; +yyrule 466 = "exprSS: expr ';'"; yyrule _ = ""; private yyprod1 ((_, (YYNTdefinitions yy4)):(_, (YYTok yy3)):(_, (YYNTmoduleclause yy2)):(_, (YYNTdocsO yy1)):yyvs) = do { yyr <- reduce1 yy1 yy2 yy3 yy4 ;YYM.pure (YYNTmodule yyr, yyvs)}; @@ -7245,112 +7312,112 @@ private yyprod115 ((_, (YYNTtypedef yy1)):yyvs) = do { let {!yyr = reduce115 yy private yyprod115 yyvals = yybadprod 115 yyvals; private yyprod116 ((_, (YYNTdatadef yy1)):yyvs) = do { let {!yyr = reduce116 yy1}; YYM.pure (YYNTpublicdefinition yyr, yyvs)}; private yyprod116 yyvals = yybadprod 116 yyvals; -private yyprod117 ((_, (YYNTclassdef yy1)):yyvs) = do { let {!yyr = reduce117 yy1}; YYM.pure (YYNTpublicdefinition yyr, yyvs)}; +private yyprod117 ((_, (YYNTdatajavadef yy1)):yyvs) = do { let {!yyr = reduce117 yy1}; YYM.pure (YYNTpublicdefinition yyr, yyvs)}; private yyprod117 yyvals = yybadprod 117 yyvals; -private yyprod118 ((_, (YYNTinstdef yy1)):yyvs) = do { let {!yyr = reduce118 yy1}; YYM.pure (YYNTpublicdefinition yyr, yyvs)}; +private yyprod118 ((_, (YYNTclassdef yy1)):yyvs) = do { let {!yyr = reduce118 yy1}; YYM.pure (YYNTpublicdefinition yyr, yyvs)}; private yyprod118 yyvals = yybadprod 118 yyvals; -private yyprod119 ((_, (YYNTderivedef yy1)):yyvs) = do { let {!yyr = reduce119 yy1}; YYM.pure (YYNTpublicdefinition yyr, yyvs)}; +private yyprod119 ((_, (YYNTinstdef yy1)):yyvs) = do { let {!yyr = reduce119 yy1}; YYM.pure (YYNTpublicdefinition yyr, yyvs)}; private yyprod119 yyvals = yybadprod 119 yyvals; -private yyprod120 ((_, (YYNTlocaldef yy1)):yyvs) = YYM.pure (YYNTpublicdefinition (yy1), yyvs); +private yyprod120 ((_, (YYNTderivedef yy1)):yyvs) = do { let {!yyr = reduce120 yy1}; YYM.pure (YYNTpublicdefinition yyr, yyvs)}; private yyprod120 yyvals = yybadprod 120 yyvals; -private yyprod121 ((_, (YYNTdplocaldef yy1)):yyvs) = YYM.pure (YYNTlocaldefs (yy1), yyvs); +private yyprod121 ((_, (YYNTlocaldef yy1)):yyvs) = YYM.pure (YYNTpublicdefinition (yy1), yyvs); private yyprod121 yyvals = yybadprod 121 yyvals; -private yyprod122 ((_, (YYTok yy2)):(_, (YYNTdplocaldef yy1)):yyvs) = do { let {!yyr = reduce122 yy1 yy2}; YYM.pure (YYNTlocaldefs yyr, yyvs)}; +private yyprod122 ((_, (YYNTdplocaldef yy1)):yyvs) = YYM.pure (YYNTlocaldefs (yy1), yyvs); private yyprod122 yyvals = yybadprod 122 yyvals; -private yyprod123 ((_, (YYNTlocaldefs yy3)):(_, (YYTok yy2)):(_, (YYNTdplocaldef yy1)):yyvs) = do { let {!yyr = reduce123 yy1 yy2 yy3}; YYM.pure (YYNTlocaldefs yyr, yyvs)}; +private yyprod123 ((_, (YYTok yy2)):(_, (YYNTdplocaldef yy1)):yyvs) = do { let {!yyr = reduce123 yy1 yy2}; YYM.pure (YYNTlocaldefs yyr, yyvs)}; private yyprod123 yyvals = yybadprod 123 yyvals; -private yyprod124 ((_, (YYNTannotation yy1)):yyvs) = YYM.pure (YYNTlocaldef (yy1), yyvs); +private yyprod124 ((_, (YYNTlocaldefs yy3)):(_, (YYTok yy2)):(_, (YYNTdplocaldef yy1)):yyvs) = do { let {!yyr = reduce124 yy1 yy2 yy3}; YYM.pure (YYNTlocaldefs yyr, yyvs)}; private yyprod124 yyvals = yybadprod 124 yyvals; -private yyprod125 ((_, (YYNTnativedef yy1)):yyvs) = do { let {!yyr = reduce125 yy1}; YYM.pure (YYNTlocaldef yyr, yyvs)}; +private yyprod125 ((_, (YYNTannotation yy1)):yyvs) = do { let {!yyr = reduce125 yy1}; YYM.pure (YYNTlocaldef yyr, yyvs)}; private yyprod125 yyvals = yybadprod 125 yyvals; -private yyprod126 ((_, (YYNTfundef yy1)):yyvs) = YYM.pure (YYNTlocaldef (yy1), yyvs); +private yyprod126 ((_, (YYNTnativedef yy1)):yyvs) = do { let {!yyr = reduce126 yy1}; YYM.pure (YYNTlocaldef yyr, yyvs)}; private yyprod126 yyvals = yybadprod 126 yyvals; -private yyprod127 ((_, (YYNTlocaldef yy1)):yyvs) = YYM.pure (YYNTplocaldef (yy1), yyvs); +private yyprod127 ((_, (YYNTfundef yy1)):yyvs) = do { let {!yyr = reduce127 yy1}; YYM.pure (YYNTlocaldef yyr, yyvs)}; private yyprod127 yyvals = yybadprod 127 yyvals; -private yyprod128 ((_, (YYNTlocaldef yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce128 yy1 yy2}; YYM.pure (YYNTplocaldef yyr, yyvs)}; +private yyprod128 ((_, (YYNTlocaldef yy1)):yyvs) = YYM.pure (YYNTplocaldef (yy1), yyvs); private yyprod128 yyvals = yybadprod 128 yyvals; private yyprod129 ((_, (YYNTlocaldef yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce129 yy1 yy2}; YYM.pure (YYNTplocaldef yyr, yyvs)}; private yyprod129 yyvals = yybadprod 129 yyvals; private yyprod130 ((_, (YYNTlocaldef yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce130 yy1 yy2}; YYM.pure (YYNTplocaldef yyr, yyvs)}; private yyprod130 yyvals = yybadprod 130 yyvals; -private yyprod131 ((_, (YYNTdocumentation yy1)):yyvs) = do { let {!yyr = reduce131 yy1}; YYM.pure (YYNTdplocaldef yyr, yyvs)}; +private yyprod131 ((_, (YYNTlocaldef yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce131 yy1 yy2}; YYM.pure (YYNTplocaldef yyr, yyvs)}; private yyprod131 yyvals = yybadprod 131 yyvals; -private yyprod132 ((_, (YYNTdplocaldef yy2)):(_, (YYNTdocumentation yy1)):yyvs) = do { let {!yyr = reduce132 yy1 yy2}; YYM.pure (YYNTdplocaldef yyr, yyvs)}; +private yyprod132 ((_, (YYNTdocumentation yy1)):yyvs) = do { let {!yyr = reduce132 yy1}; YYM.pure (YYNTdplocaldef yyr, yyvs)}; private yyprod132 yyvals = yybadprod 132 yyvals; -private yyprod133 ((_, (YYNTplocaldef yy1)):yyvs) = YYM.pure (YYNTdplocaldef (yy1), yyvs); +private yyprod133 ((_, (YYNTdplocaldef yy2)):(_, (YYNTdocumentation yy1)):yyvs) = do { let {!yyr = reduce133 yy1 yy2}; YYM.pure (YYNTdplocaldef yyr, yyvs)}; private yyprod133 yyvals = yybadprod 133 yyvals; -private yyprod134 ((_, (YYNTannotation yy1)):yyvs) = YYM.pure (YYNTletdef (yy1), yyvs); +private yyprod134 ((_, (YYNTplocaldef yy1)):yyvs) = YYM.pure (YYNTdplocaldef (yy1), yyvs); private yyprod134 yyvals = yybadprod 134 yyvals; -private yyprod135 ((_, (YYNTfundef yy1)):yyvs) = YYM.pure (YYNTletdef (yy1), yyvs); +private yyprod135 ((_, (YYNTannotation yy1)):yyvs) = do { let {!yyr = reduce135 yy1}; YYM.pure (YYNTletdef yyr, yyvs)}; private yyprod135 yyvals = yybadprod 135 yyvals; -private yyprod136 ((_, (YYNTletdef yy1)):yyvs) = YYM.pure (YYNTletdefs (yy1), yyvs); +private yyprod136 ((_, (YYNTfundef yy1)):yyvs) = do { let {!yyr = reduce136 yy1}; YYM.pure (YYNTletdef yyr, yyvs)}; private yyprod136 yyvals = yybadprod 136 yyvals; -private yyprod137 ((_, (YYTok yy2)):(_, (YYNTletdef yy1)):yyvs) = do { let {!yyr = reduce137 yy1 yy2}; YYM.pure (YYNTletdefs yyr, yyvs)}; +private yyprod137 ((_, (YYNTletdef yy1)):yyvs) = YYM.pure (YYNTletdefs (yy1), yyvs); private yyprod137 yyvals = yybadprod 137 yyvals; -private yyprod138 ((_, (YYNTletdefs yy3)):(_, (YYTok yy2)):(_, (YYNTletdef yy1)):yyvs) = do { let {!yyr = reduce138 yy1 yy2 yy3}; YYM.pure (YYNTletdefs yyr, yyvs)}; +private yyprod138 ((_, (YYTok yy2)):(_, (YYNTletdef yy1)):yyvs) = do { let {!yyr = reduce138 yy1 yy2}; YYM.pure (YYNTletdefs yyr, yyvs)}; private yyprod138 yyvals = yybadprod 138 yyvals; -private yyprod139 ((_, (YYNTimportliste yy3)):(_, (YYNTmodulename yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce139 yy1 yy2 yy3}; YYM.pure (YYNTimport yyr, yyvs)}; +private yyprod139 ((_, (YYNTletdefs yy3)):(_, (YYTok yy2)):(_, (YYNTletdef yy1)):yyvs) = do { let {!yyr = reduce139 yy1 yy2 yy3}; YYM.pure (YYNTletdefs yyr, yyvs)}; private yyprod139 yyvals = yybadprod 139 yyvals; -private yyprod140 ((_, (YYNTimportliste yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYNTmodulename yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce140 yy1 yy2 yy3 yy4 yy5 ;YYM.pure (YYNTimport yyr, yyvs)}; +private yyprod140 ((_, (YYNTimportliste yy3)):(_, (YYNTmodulename yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce140 yy1 yy2 yy3}; YYM.pure (YYNTimport yyr, yyvs)}; private yyprod140 yyvals = yybadprod 140 yyvals; -private yyprod141 ((_, (YYNTimportliste yy4)):(_, (YYTok yy3)):(_, (YYNTmodulename yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce141 yy1 yy2 yy3 yy4 ;YYM.pure (YYNTimport yyr, yyvs)}; +private yyprod141 ((_, (YYNTimportliste yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYNTmodulename yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce141 yy1 yy2 yy3 yy4 yy5 ;YYM.pure (YYNTimport yyr, yyvs)}; private yyprod141 yyvals = yybadprod 141 yyvals; -private yyprod142 yyvs = do { let {!yyr = reduce142 }; YYM.pure (YYNTimportliste yyr, yyvs)}; -private yyprod143 ((_, (YYTok yy4)):(_, (YYNTimportspecs yy3)):(_, (YYTok yy2)):(_, (YYNTvarid yy1)):yyvs) = do { yyr <- reduce143 yy1 yy2 yy3 yy4 ;YYM.pure (YYNTimportliste yyr, yyvs)}; -private yyprod143 yyvals = yybadprod 143 yyvals; -private yyprod144 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce144 yy1 yy2}; YYM.pure (YYNTimportliste yyr, yyvs)}; +private yyprod142 ((_, (YYNTimportliste yy4)):(_, (YYTok yy3)):(_, (YYNTmodulename yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce142 yy1 yy2 yy3 yy4 ;YYM.pure (YYNTimport yyr, yyvs)}; +private yyprod142 yyvals = yybadprod 142 yyvals; +private yyprod143 yyvs = do { let {!yyr = reduce143 }; YYM.pure (YYNTimportliste yyr, yyvs)}; +private yyprod144 ((_, (YYTok yy4)):(_, (YYNTimportspecs yy3)):(_, (YYTok yy2)):(_, (YYNTvarid yy1)):yyvs) = do { yyr <- reduce144 yy1 yy2 yy3 yy4 ;YYM.pure (YYNTimportliste yyr, yyvs)}; private yyprod144 yyvals = yybadprod 144 yyvals; -private yyprod145 ((_, (YYTok yy3)):(_, (YYNTimportspecs yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce145 yy1 yy2 yy3}; YYM.pure (YYNTimportliste yyr, yyvs)}; +private yyprod145 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce145 yy1 yy2}; YYM.pure (YYNTimportliste yyr, yyvs)}; private yyprod145 yyvals = yybadprod 145 yyvals; -private yyprod146 ((_, (YYNTimportliste yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce146 yy1 yy2}; YYM.pure (YYNTimportliste yyr, yyvs)}; +private yyprod146 ((_, (YYTok yy3)):(_, (YYNTimportspecs yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce146 yy1 yy2 yy3}; YYM.pure (YYNTimportliste yyr, yyvs)}; private yyprod146 yyvals = yybadprod 146 yyvals; -private yyprod147 ((_, (YYNTimportspec yy1)):yyvs) = do { let {!yyr = reduce147 yy1}; YYM.pure (YYNTimportspecs yyr, yyvs)}; +private yyprod147 ((_, (YYNTimportliste yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce147 yy1 yy2}; YYM.pure (YYNTimportliste yyr, yyvs)}; private yyprod147 yyvals = yybadprod 147 yyvals; -private yyprod148 ((_, (YYTok yy2)):(_, (YYNTimportspec yy1)):yyvs) = do { let {!yyr = reduce148 yy1 yy2}; YYM.pure (YYNTimportspecs yyr, yyvs)}; +private yyprod148 ((_, (YYNTimportspec yy1)):yyvs) = do { let {!yyr = reduce148 yy1}; YYM.pure (YYNTimportspecs yyr, yyvs)}; private yyprod148 yyvals = yybadprod 148 yyvals; -private yyprod149 ((_, (YYNTimportspecs yy3)):(_, (YYTok yy2)):(_, (YYNTimportspec yy1)):yyvs) = do { let {!yyr = reduce149 yy1 yy2 yy3}; YYM.pure (YYNTimportspecs yyr, yyvs)}; +private yyprod149 ((_, (YYTok yy2)):(_, (YYNTimportspec yy1)):yyvs) = do { let {!yyr = reduce149 yy1 yy2}; YYM.pure (YYNTimportspecs yyr, yyvs)}; private yyprod149 yyvals = yybadprod 149 yyvals; -private yyprod150 ((_, (YYNTqvarid yy1)):yyvs) = do { let {!yyr = reduce150 yy1}; YYM.pure (YYNTimportitem yyr, yyvs)}; +private yyprod150 ((_, (YYNTimportspecs yy3)):(_, (YYTok yy2)):(_, (YYNTimportspec yy1)):yyvs) = do { let {!yyr = reduce150 yy1 yy2 yy3}; YYM.pure (YYNTimportspecs yyr, yyvs)}; private yyprod150 yyvals = yybadprod 150 yyvals; -private yyprod151 ((_, (YYTok yy4)):(_, (YYNTmemspecs yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce151 yy1 yy2 yy3 yy4}; YYM.pure (YYNTimportitem yyr, yyvs)}; +private yyprod151 ((_, (YYNTqvarid yy1)):yyvs) = do { let {!yyr = reduce151 yy1}; YYM.pure (YYNTimportitem yyr, yyvs)}; private yyprod151 yyvals = yybadprod 151 yyvals; -private yyprod152 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce152 yy1 yy2 yy3}; YYM.pure (YYNTimportitem yyr, yyvs)}; +private yyprod152 ((_, (YYTok yy4)):(_, (YYNTmemspecs yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce152 yy1 yy2 yy3 yy4}; YYM.pure (YYNTimportitem yyr, yyvs)}; private yyprod152 yyvals = yybadprod 152 yyvals; -private yyprod153 ((_, (YYNTqconid yy1)):yyvs) = do { let {!yyr = reduce153 yy1}; YYM.pure (YYNTimportitem yyr, yyvs)}; +private yyprod153 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce153 yy1 yy2 yy3}; YYM.pure (YYNTimportitem yyr, yyvs)}; private yyprod153 yyvals = yybadprod 153 yyvals; -private yyprod154 ((_, (YYNToperator yy1)):yyvs) = do { let {!yyr = reduce154 yy1}; YYM.pure (YYNTimportitem yyr, yyvs)}; +private yyprod154 ((_, (YYNTqconid yy1)):yyvs) = do { let {!yyr = reduce154 yy1}; YYM.pure (YYNTimportitem yyr, yyvs)}; private yyprod154 yyvals = yybadprod 154 yyvals; -private yyprod155 ((_, (YYNTunop yy1)):yyvs) = do { let {!yyr = reduce155 yy1}; YYM.pure (YYNTimportitem yyr, yyvs)}; +private yyprod155 ((_, (YYNToperator yy1)):yyvs) = do { let {!yyr = reduce155 yy1}; YYM.pure (YYNTimportitem yyr, yyvs)}; private yyprod155 yyvals = yybadprod 155 yyvals; -private yyprod156 ((_, (YYNTimportitem yy1)):yyvs) = do { let {!yyr = reduce156 yy1}; YYM.pure (YYNTimportspec yyr, yyvs)}; +private yyprod156 ((_, (YYNTunop yy1)):yyvs) = do { let {!yyr = reduce156 yy1}; YYM.pure (YYNTimportitem yyr, yyvs)}; private yyprod156 yyvals = yybadprod 156 yyvals; -private yyprod157 ((_, (YYNTalias yy2)):(_, (YYNTimportitem yy1)):yyvs) = do { let {!yyr = reduce157 yy1 yy2}; YYM.pure (YYNTimportspec yyr, yyvs)}; +private yyprod157 ((_, (YYNTimportitem yy1)):yyvs) = do { let {!yyr = reduce157 yy1}; YYM.pure (YYNTimportspec yyr, yyvs)}; private yyprod157 yyvals = yybadprod 157 yyvals; -private yyprod158 ((_, (YYNTimportspec yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce158 yy1 yy2}; YYM.pure (YYNTimportspec yyr, yyvs)}; +private yyprod158 ((_, (YYNTalias yy2)):(_, (YYNTimportitem yy1)):yyvs) = do { let {!yyr = reduce158 yy1 yy2}; YYM.pure (YYNTimportspec yyr, yyvs)}; private yyprod158 yyvals = yybadprod 158 yyvals; -private yyprod159 ((_, (YYNTalias yy1)):yyvs) = do { let {!yyr = reduce159 yy1}; YYM.pure (YYNTmemspec yyr, yyvs)}; +private yyprod159 ((_, (YYNTimportspec yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce159 yy1 yy2}; YYM.pure (YYNTimportspec yyr, yyvs)}; private yyprod159 yyvals = yybadprod 159 yyvals; -private yyprod160 ((_, (YYNTalias yy2)):(_, (YYNTalias yy1)):yyvs) = do { let {!yyr = reduce160 yy1 yy2}; YYM.pure (YYNTmemspec yyr, yyvs)}; +private yyprod160 ((_, (YYNTalias yy1)):yyvs) = do { let {!yyr = reduce160 yy1}; YYM.pure (YYNTmemspec yyr, yyvs)}; private yyprod160 yyvals = yybadprod 160 yyvals; -private yyprod161 ((_, (YYNTmemspec yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce161 yy1 yy2}; YYM.pure (YYNTmemspec yyr, yyvs)}; +private yyprod161 ((_, (YYNTalias yy2)):(_, (YYNTalias yy1)):yyvs) = do { let {!yyr = reduce161 yy1 yy2}; YYM.pure (YYNTmemspec yyr, yyvs)}; private yyprod161 yyvals = yybadprod 161 yyvals; -private yyprod162 ((_, (YYNTmemspec yy1)):yyvs) = do { let {!yyr = reduce162 yy1}; YYM.pure (YYNTmemspecs yyr, yyvs)}; +private yyprod162 ((_, (YYNTmemspec yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce162 yy1 yy2}; YYM.pure (YYNTmemspec yyr, yyvs)}; private yyprod162 yyvals = yybadprod 162 yyvals; -private yyprod163 ((_, (YYTok yy2)):(_, (YYNTmemspec yy1)):yyvs) = do { let {!yyr = reduce163 yy1 yy2}; YYM.pure (YYNTmemspecs yyr, yyvs)}; +private yyprod163 ((_, (YYNTmemspec yy1)):yyvs) = do { let {!yyr = reduce163 yy1}; YYM.pure (YYNTmemspecs yyr, yyvs)}; private yyprod163 yyvals = yybadprod 163 yyvals; -private yyprod164 ((_, (YYNTmemspecs yy3)):(_, (YYTok yy2)):(_, (YYNTmemspec yy1)):yyvs) = do { let {!yyr = reduce164 yy1 yy2 yy3}; YYM.pure (YYNTmemspecs yyr, yyvs)}; +private yyprod164 ((_, (YYTok yy2)):(_, (YYNTmemspec yy1)):yyvs) = do { let {!yyr = reduce164 yy1 yy2}; YYM.pure (YYNTmemspecs yyr, yyvs)}; private yyprod164 yyvals = yybadprod 164 yyvals; -private yyprod165 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTalias (yy1), yyvs); +private yyprod165 ((_, (YYNTmemspecs yy3)):(_, (YYTok yy2)):(_, (YYNTmemspec yy1)):yyvs) = do { let {!yyr = reduce165 yy1 yy2 yy3}; YYM.pure (YYNTmemspecs yyr, yyvs)}; private yyprod165 yyvals = yybadprod 165 yyvals; private yyprod166 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTalias (yy1), yyvs); private yyprod166 yyvals = yybadprod 166 yyvals; -private yyprod167 ((_, (YYNToperator yy1)):yyvs) = do { yyr <- reduce167 yy1 ;YYM.pure (YYNTalias yyr, yyvs)}; +private yyprod167 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTalias (yy1), yyvs); private yyprod167 yyvals = yybadprod 167 yyvals; -private yyprod168 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTvarid (yy1), yyvs); +private yyprod168 ((_, (YYNToperator yy1)):yyvs) = do { yyr <- reduce168 yy1 ;YYM.pure (YYNTalias yyr, yyvs)}; private yyprod168 yyvals = yybadprod 168 yyvals; -private yyprod169 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTvaridkw (yy1), yyvs); +private yyprod169 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTvarid (yy1), yyvs); private yyprod169 yyvals = yybadprod 169 yyvals; -private yyprod170 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce170 yy1}; YYM.pure (YYNTvaridkw yyr, yyvs)}; +private yyprod170 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTvaridkw (yy1), yyvs); private yyprod170 yyvals = yybadprod 170 yyvals; private yyprod171 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce171 yy1}; YYM.pure (YYNTvaridkw yyr, yyvs)}; private yyprod171 yyvals = yybadprod 171 yyvals; @@ -7362,235 +7429,235 @@ private yyprod174 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce174 yy1}; YY private yyprod174 yyvals = yybadprod 174 yyvals; private yyprod175 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce175 yy1}; YYM.pure (YYNTvaridkw yyr, yyvs)}; private yyprod175 yyvals = yybadprod 175 yyvals; -private yyprod176 ((_, (YYNTqvarop yy1)):yyvs) = do { let {!yyr = reduce176 yy1}; YYM.pure (YYNTqvarids yyr, yyvs)}; +private yyprod176 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce176 yy1}; YYM.pure (YYNTvaridkw yyr, yyvs)}; private yyprod176 yyvals = yybadprod 176 yyvals; -private yyprod177 ((_, (YYNTqvarids yy3)):(_, (YYTok yy2)):(_, (YYNTqvarop yy1)):yyvs) = do { let {!yyr = reduce177 yy1 yy2 yy3}; YYM.pure (YYNTqvarids yyr, yyvs)}; +private yyprod177 ((_, (YYNTqvarop yy1)):yyvs) = do { let {!yyr = reduce177 yy1}; YYM.pure (YYNTqvarids yyr, yyvs)}; private yyprod177 yyvals = yybadprod 177 yyvals; -private yyprod178 ((_, (YYNTvarop yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce178 yy1 yy2 yy3}; YYM.pure (YYNTqvarid yyr, yyvs)}; +private yyprod178 ((_, (YYNTqvarids yy3)):(_, (YYTok yy2)):(_, (YYNTqvarop yy1)):yyvs) = do { let {!yyr = reduce178 yy1 yy2 yy3}; YYM.pure (YYNTqvarids yyr, yyvs)}; private yyprod178 yyvals = yybadprod 178 yyvals; -private yyprod179 ((_, (YYNTvarop yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce179 yy1 yy2}; YYM.pure (YYNTqvarid yyr, yyvs)}; +private yyprod179 ((_, (YYNTvarop yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce179 yy1 yy2 yy3}; YYM.pure (YYNTqvarid yyr, yyvs)}; private yyprod179 yyvals = yybadprod 179 yyvals; -private yyprod180 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce180 yy1}; YYM.pure (YYNTqvarid yyr, yyvs)}; +private yyprod180 ((_, (YYNTvarop yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce180 yy1 yy2}; YYM.pure (YYNTqvarid yyr, yyvs)}; private yyprod180 yyvals = yybadprod 180 yyvals; -private yyprod181 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce181 yy1 yy2 yy3}; YYM.pure (YYNTqconid yyr, yyvs)}; +private yyprod181 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce181 yy1}; YYM.pure (YYNTqvarid yyr, yyvs)}; private yyprod181 yyvals = yybadprod 181 yyvals; -private yyprod182 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce182 yy1 yy2}; YYM.pure (YYNTqconid yyr, yyvs)}; +private yyprod182 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce182 yy1 yy2 yy3}; YYM.pure (YYNTqconid yyr, yyvs)}; private yyprod182 yyvals = yybadprod 182 yyvals; -private yyprod183 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce183 yy1}; YYM.pure (YYNTqconid yyr, yyvs)}; +private yyprod183 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce183 yy1 yy2}; YYM.pure (YYNTqconid yyr, yyvs)}; private yyprod183 yyvals = yybadprod 183 yyvals; -private yyprod184 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTvarop (yy1), yyvs); +private yyprod184 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce184 yy1}; YYM.pure (YYNTqconid yyr, yyvs)}; private yyprod184 yyvals = yybadprod 184 yyvals; -private yyprod185 ((_, (YYNTunop yy1)):yyvs) = YYM.pure (YYNTvarop (yy1), yyvs); +private yyprod185 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTvarop (yy1), yyvs); private yyprod185 yyvals = yybadprod 185 yyvals; -private yyprod186 ((_, (YYNTvarop yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce186 yy1 yy2 yy3}; YYM.pure (YYNTqvarop yyr, yyvs)}; +private yyprod186 ((_, (YYNTunop yy1)):yyvs) = YYM.pure (YYNTvarop (yy1), yyvs); private yyprod186 yyvals = yybadprod 186 yyvals; -private yyprod187 ((_, (YYNTvarop yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce187 yy1 yy2}; YYM.pure (YYNTqvarop yyr, yyvs)}; +private yyprod187 ((_, (YYNTvarop yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce187 yy1 yy2 yy3}; YYM.pure (YYNTqvarop yyr, yyvs)}; private yyprod187 yyvals = yybadprod 187 yyvals; -private yyprod188 ((_, (YYNTvarop yy1)):yyvs) = do { let {!yyr = reduce188 yy1}; YYM.pure (YYNTqvarop yyr, yyvs)}; +private yyprod188 ((_, (YYNTvarop yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce188 yy1 yy2}; YYM.pure (YYNTqvarop yyr, yyvs)}; private yyprod188 yyvals = yybadprod 188 yyvals; -private yyprod189 ((_, (YYNToperator yy1)):yyvs) = do { let {!yyr = reduce189 yy1}; YYM.pure (YYNTqvarop yyr, yyvs)}; +private yyprod189 ((_, (YYNTvarop yy1)):yyvs) = do { let {!yyr = reduce189 yy1}; YYM.pure (YYNTqvarop yyr, yyvs)}; private yyprod189 yyvals = yybadprod 189 yyvals; -private yyprod190 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNToperator (yy1), yyvs); +private yyprod190 ((_, (YYNToperator yy1)):yyvs) = do { let {!yyr = reduce190 yy1}; YYM.pure (YYNTqvarop yyr, yyvs)}; private yyprod190 yyvals = yybadprod 190 yyvals; -private yyprod191 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTunop (yy1), yyvs); +private yyprod191 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNToperator (yy1), yyvs); private yyprod191 yyvals = yybadprod 191 yyvals; private yyprod192 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTunop (yy1), yyvs); private yyprod192 yyvals = yybadprod 192 yyvals; -private yyprod193 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce193 yy1 yy2 ;YYM.pure (YYNTfixity yyr, yyvs)}; +private yyprod193 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTunop (yy1), yyvs); private yyprod193 yyvals = yybadprod 193 yyvals; private yyprod194 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce194 yy1 yy2 ;YYM.pure (YYNTfixity yyr, yyvs)}; private yyprod194 yyvals = yybadprod 194 yyvals; private yyprod195 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce195 yy1 yy2 ;YYM.pure (YYNTfixity yyr, yyvs)}; private yyprod195 yyvals = yybadprod 195 yyvals; -private yyprod196 ((_, (YYNToperator yy1)):yyvs) = do { let {!yyr = reduce196 yy1}; YYM.pure (YYNTopstring yyr, yyvs)}; +private yyprod196 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce196 yy1 yy2 ;YYM.pure (YYNTfixity yyr, yyvs)}; private yyprod196 yyvals = yybadprod 196 yyvals; -private yyprod197 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce197 yy1}; YYM.pure (YYNTopstring yyr, yyvs)}; +private yyprod197 ((_, (YYNToperator yy1)):yyvs) = do { let {!yyr = reduce197 yy1}; YYM.pure (YYNTopstring yyr, yyvs)}; private yyprod197 yyvals = yybadprod 197 yyvals; private yyprod198 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce198 yy1}; YYM.pure (YYNTopstring yyr, yyvs)}; private yyprod198 yyvals = yybadprod 198 yyvals; -private yyprod199 ((_, (YYNTopstring yy1)):yyvs) = do { let {!yyr = reduce199 yy1}; YYM.pure (YYNToperators yyr, yyvs)}; +private yyprod199 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce199 yy1}; YYM.pure (YYNTopstring yyr, yyvs)}; private yyprod199 yyvals = yybadprod 199 yyvals; -private yyprod200 ((_, (YYNToperators yy2)):(_, (YYNTopstring yy1)):yyvs) = do { let {!yyr = reduce200 yy1 yy2}; YYM.pure (YYNToperators yyr, yyvs)}; +private yyprod200 ((_, (YYNTopstring yy1)):yyvs) = do { let {!yyr = reduce200 yy1}; YYM.pure (YYNToperators yyr, yyvs)}; private yyprod200 yyvals = yybadprod 200 yyvals; -private yyprod201 ((_, (YYNToperators yy2)):(_, (YYNTfixity yy1)):yyvs) = do { let {!yyr = reduce201 yy1 yy2}; YYM.pure (YYNTinfix yyr, yyvs)}; +private yyprod201 ((_, (YYNToperators yy2)):(_, (YYNTopstring yy1)):yyvs) = do { let {!yyr = reduce201 yy1 yy2}; YYM.pure (YYNToperators yyr, yyvs)}; private yyprod201 yyvals = yybadprod 201 yyvals; -private yyprod202 ((_, (YYNTsigma yy3)):(_, (YYTok yy2)):(_, (YYNTannoitems yy1)):yyvs) = do { let {!yyr = reduce202 yy1 yy2 yy3}; YYM.pure (YYNTannotation yyr, yyvs)}; +private yyprod202 ((_, (YYNToperators yy2)):(_, (YYNTfixity yy1)):yyvs) = do { let {!yyr = reduce202 yy1 yy2}; YYM.pure (YYNTinfix yyr, yyvs)}; private yyprod202 yyvals = yybadprod 202 yyvals; -private yyprod203 ((_, (YYNTvarid yy1)):yyvs) = YYM.pure (YYNTannoitem (yy1), yyvs); +private yyprod203 ((_, (YYNTsigma yy3)):(_, (YYTok yy2)):(_, (YYNTannoitems yy1)):yyvs) = do { let {!yyr = reduce203 yy1 yy2 yy3}; YYM.pure (YYNTannotation yyr, yyvs)}; private yyprod203 yyvals = yybadprod 203 yyvals; -private yyprod204 ((_, (YYTok yy3)):(_, (YYNToperator yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce204 yy1 yy2 yy3 ;YYM.pure (YYNTannoitem yyr, yyvs)}; +private yyprod204 ((_, (YYNTvarid yy1)):yyvs) = YYM.pure (YYNTannoitem (yy1), yyvs); private yyprod204 yyvals = yybadprod 204 yyvals; -private yyprod205 ((_, (YYTok yy3)):(_, (YYNTunop yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce205 yy1 yy2 yy3}; YYM.pure (YYNTannoitem yyr, yyvs)}; +private yyprod205 ((_, (YYTok yy3)):(_, (YYNToperator yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce205 yy1 yy2 yy3 ;YYM.pure (YYNTannoitem yyr, yyvs)}; private yyprod205 yyvals = yybadprod 205 yyvals; -private yyprod206 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce206 yy1 yy2 yy3}; YYM.pure (YYNTannoitem yyr, yyvs)}; +private yyprod206 ((_, (YYTok yy3)):(_, (YYNTunop yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce206 yy1 yy2 yy3}; YYM.pure (YYNTannoitem yyr, yyvs)}; private yyprod206 yyvals = yybadprod 206 yyvals; -private yyprod207 ((_, (YYNTannoitem yy1)):yyvs) = do { let {!yyr = reduce207 yy1}; YYM.pure (YYNTannoitems yyr, yyvs)}; +private yyprod207 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce207 yy1 yy2 yy3}; YYM.pure (YYNTannoitem yyr, yyvs)}; private yyprod207 yyvals = yybadprod 207 yyvals; -private yyprod208 ((_, (YYNTannoitems yy3)):(_, (YYTok yy2)):(_, (YYNTannoitem yy1)):yyvs) = do { let {!yyr = reduce208 yy1 yy2 yy3}; YYM.pure (YYNTannoitems yyr, yyvs)}; +private yyprod208 ((_, (YYNTannoitem yy1)):yyvs) = do { let {!yyr = reduce208 yy1}; YYM.pure (YYNTannoitems yyr, yyvs)}; private yyprod208 yyvals = yybadprod 208 yyvals; -private yyprod209 ((_, (YYNTimpurenativedef yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce209 yy1 yy2}; YYM.pure (YYNTnativedef yyr, yyvs)}; +private yyprod209 ((_, (YYNTannoitems yy3)):(_, (YYTok yy2)):(_, (YYNTannoitem yy1)):yyvs) = do { let {!yyr = reduce209 yy1 yy2 yy3}; YYM.pure (YYNTannoitems yyr, yyvs)}; private yyprod209 yyvals = yybadprod 209 yyvals; -private yyprod210 ((_, (YYNTimpurenativedef yy1)):yyvs) = YYM.pure (YYNTnativedef (yy1), yyvs); +private yyprod210 ((_, (YYNTimpurenativedef yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce210 yy1 yy2}; YYM.pure (YYNTnativedef yyr, yyvs)}; private yyprod210 yyvals = yybadprod 210 yyvals; -private yyprod211 ((_, (YYNTannoitem yy1)):yyvs) = YYM.pure (YYNTfitem (yy1), yyvs); +private yyprod211 ((_, (YYNTimpurenativedef yy1)):yyvs) = YYM.pure (YYNTnativedef (yy1), yyvs); private yyprod211 yyvals = yybadprod 211 yyvals; -private yyprod212 ((_, (YYNTunop yy1)):yyvs) = YYM.pure (YYNTfitem (yy1), yyvs); +private yyprod212 ((_, (YYNTannoitem yy1)):yyvs) = YYM.pure (YYNTfitem (yy1), yyvs); private yyprod212 yyvals = yybadprod 212 yyvals; -private yyprod213 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTfitem (yy1), yyvs); +private yyprod213 ((_, (YYNTunop yy1)):yyvs) = YYM.pure (YYNTfitem (yy1), yyvs); private yyprod213 yyvals = yybadprod 213 yyvals; -private yyprod214 ((_, (YYNToperator yy1)):yyvs) = do { yyr <- reduce214 yy1 ;YYM.pure (YYNTfitem yyr, yyvs)}; +private yyprod214 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTfitem (yy1), yyvs); private yyprod214 yyvals = yybadprod 214 yyvals; -private yyprod215 ((_, (YYNTnativename yy1)):yyvs) = YYM.pure (YYNTjitem (yy1), yyvs); +private yyprod215 ((_, (YYNToperator yy1)):yyvs) = do { yyr <- reduce215 yy1 ;YYM.pure (YYNTfitem yyr, yyvs)}; private yyprod215 yyvals = yybadprod 215 yyvals; -private yyprod216 ((_, (YYNToperator yy1)):yyvs) = do { yyr <- reduce216 yy1 ;YYM.pure (YYNTjitem yyr, yyvs)}; +private yyprod216 ((_, (YYNTnativename yy1)):yyvs) = YYM.pure (YYNTjitem (yy1), yyvs); private yyprod216 yyvals = yybadprod 216 yyvals; -private yyprod217 ((_, (YYNTunop yy1)):yyvs) = do { let {!yyr = reduce217 yy1}; YYM.pure (YYNTjitem yyr, yyvs)}; +private yyprod217 ((_, (YYNToperator yy1)):yyvs) = do { yyr <- reduce217 yy1 ;YYM.pure (YYNTjitem yyr, yyvs)}; private yyprod217 yyvals = yybadprod 217 yyvals; -private yyprod218 ((_, (YYNTgargs yy3)):(_, (YYNTjitem yy2)):(_, (YYNTfitem yy1)):yyvs) = do { let {!yyr = reduce218 yy1 yy2 yy3}; YYM.pure (YYNTmethodspec yyr, yyvs)}; +private yyprod218 ((_, (YYNTunop yy1)):yyvs) = do { let {!yyr = reduce218 yy1}; YYM.pure (YYNTjitem yyr, yyvs)}; private yyprod218 yyvals = yybadprod 218 yyvals; -private yyprod219 ((_, (YYNTjitem yy2)):(_, (YYNTfitem yy1)):yyvs) = do { let {!yyr = reduce219 yy1 yy2}; YYM.pure (YYNTmethodspec yyr, yyvs)}; +private yyprod219 ((_, (YYNTgargs yy3)):(_, (YYNTjitem yy2)):(_, (YYNTfitem yy1)):yyvs) = do { let {!yyr = reduce219 yy1 yy2 yy3}; YYM.pure (YYNTmethodspec yyr, yyvs)}; private yyprod219 yyvals = yybadprod 219 yyvals; -private yyprod220 ((_, (YYNTgargs yy2)):(_, (YYNTfitem yy1)):yyvs) = do { let {!yyr = reduce220 yy1 yy2}; YYM.pure (YYNTmethodspec yyr, yyvs)}; +private yyprod220 ((_, (YYNTjitem yy2)):(_, (YYNTfitem yy1)):yyvs) = do { let {!yyr = reduce220 yy1 yy2}; YYM.pure (YYNTmethodspec yyr, yyvs)}; private yyprod220 yyvals = yybadprod 220 yyvals; -private yyprod221 ((_, (YYNTfitem yy1)):yyvs) = do { let {!yyr = reduce221 yy1}; YYM.pure (YYNTmethodspec yyr, yyvs)}; +private yyprod221 ((_, (YYNTgargs yy2)):(_, (YYNTfitem yy1)):yyvs) = do { let {!yyr = reduce221 yy1 yy2}; YYM.pure (YYNTmethodspec yyr, yyvs)}; private yyprod221 yyvals = yybadprod 221 yyvals; -private yyprod222 ((_, (YYNTtauSC yy3)):(_, (YYTok yy2)):(_, (YYNTsigma yy1)):yyvs) = do { let {!yyr = reduce222 yy1 yy2 yy3}; YYM.pure (YYNTsigex yyr, yyvs)}; +private yyprod222 ((_, (YYNTfitem yy1)):yyvs) = do { let {!yyr = reduce222 yy1}; YYM.pure (YYNTmethodspec yyr, yyvs)}; private yyprod222 yyvals = yybadprod 222 yyvals; -private yyprod223 ((_, (YYNTsigma yy1)):yyvs) = do { let {!yyr = reduce223 yy1}; YYM.pure (YYNTsigex yyr, yyvs)}; +private yyprod223 ((_, (YYNTtauSC yy3)):(_, (YYTok yy2)):(_, (YYNTsigma yy1)):yyvs) = do { let {!yyr = reduce223 yy1 yy2 yy3}; YYM.pure (YYNTsigex yyr, yyvs)}; private yyprod223 yyvals = yybadprod 223 yyvals; -private yyprod224 ((_, (YYNTsigex yy1)):yyvs) = do { let {!yyr = reduce224 yy1}; YYM.pure (YYNTsigexs yyr, yyvs)}; +private yyprod224 ((_, (YYNTsigma yy1)):yyvs) = do { let {!yyr = reduce224 yy1}; YYM.pure (YYNTsigex yyr, yyvs)}; private yyprod224 yyvals = yybadprod 224 yyvals; -private yyprod225 ((_, (YYNTsigexs yy3)):(_, (YYTok yy2)):(_, (YYNTsigex yy1)):yyvs) = do { let {!yyr = reduce225 yy1 yy2 yy3}; YYM.pure (YYNTsigexs yyr, yyvs)}; +private yyprod225 ((_, (YYNTsigex yy1)):yyvs) = do { let {!yyr = reduce225 yy1}; YYM.pure (YYNTsigexs yyr, yyvs)}; private yyprod225 yyvals = yybadprod 225 yyvals; -private yyprod226 ((_, (YYNTsigexs yy4)):(_, (YYTok yy3)):(_, (YYNTmethodspec yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce226 yy1 yy2 yy3 yy4}; YYM.pure (YYNTimpurenativedef yyr, yyvs)}; +private yyprod226 ((_, (YYNTsigexs yy3)):(_, (YYTok yy2)):(_, (YYNTsigex yy1)):yyvs) = do { let {!yyr = reduce226 yy1 yy2 yy3}; YYM.pure (YYNTsigexs yyr, yyvs)}; private yyprod226 yyvals = yybadprod 226 yyvals; -private yyprod227 ((_, (YYNTforall yy1)):yyvs) = YYM.pure (YYNTsigma (yy1), yyvs); +private yyprod227 ((_, (YYNTsigexs yy4)):(_, (YYTok yy3)):(_, (YYNTmethodspec yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce227 yy1 yy2 yy3 yy4}; YYM.pure (YYNTimpurenativedef yyr, yyvs)}; private yyprod227 yyvals = yybadprod 227 yyvals; -private yyprod228 ((_, (YYNTrho yy1)):yyvs) = do { let {!yyr = reduce228 yy1}; YYM.pure (YYNTsigma yyr, yyvs)}; +private yyprod228 ((_, (YYNTforall yy1)):yyvs) = YYM.pure (YYNTsigma (yy1), yyvs); private yyprod228 yyvals = yybadprod 228 yyvals; -private yyprod229 ((_, (YYNTrho yy4)):(_, (YYNTmbdot yy3)):(_, (YYNTdvars yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce229 yy1 yy2 yy3 yy4}; YYM.pure (YYNTforall yyr, yyvs)}; +private yyprod229 ((_, (YYNTrho yy1)):yyvs) = do { let {!yyr = reduce229 yy1}; YYM.pure (YYNTsigma yyr, yyvs)}; private yyprod229 yyvals = yybadprod 229 yyvals; -private yyprod230 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTmbdot (yy1), yyvs); +private yyprod230 ((_, (YYNTrho yy4)):(_, (YYNTmbdot yy3)):(_, (YYNTdvars yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce230 yy1 yy2 yy3 yy4}; YYM.pure (YYNTforall yyr, yyvs)}; private yyprod230 yyvals = yybadprod 230 yyvals; -private yyprod231 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce231 yy1 ;YYM.pure (YYNTmbdot yyr, yyvs)}; +private yyprod231 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTmbdot (yy1), yyvs); private yyprod231 yyvals = yybadprod 231 yyvals; -private yyprod232 ((_, (YYNTrhofun yy3)):(_, (YYTok yy2)):(_, (YYNTtapp yy1)):yyvs) = do { yyr <- reduce232 yy1 yy2 yy3 ;YYM.pure (YYNTrho yyr, yyvs)}; +private yyprod232 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce232 yy1 ;YYM.pure (YYNTmbdot yyr, yyvs)}; private yyprod232 yyvals = yybadprod 232 yyvals; -private yyprod233 ((_, (YYNTrhofun yy1)):yyvs) = YYM.pure (YYNTrho (yy1), yyvs); +private yyprod233 ((_, (YYNTrhofun yy3)):(_, (YYTok yy2)):(_, (YYNTtapp yy1)):yyvs) = do { yyr <- reduce233 yy1 yy2 yy3 ;YYM.pure (YYNTrho yyr, yyvs)}; private yyprod233 yyvals = yybadprod 233 yyvals; -private yyprod234 ((_, (YYNTtapp yy1)):yyvs) = do { let {!yyr = reduce234 yy1}; YYM.pure (YYNTrhofun yyr, yyvs)}; +private yyprod234 ((_, (YYNTrhofun yy1)):yyvs) = YYM.pure (YYNTrho (yy1), yyvs); private yyprod234 yyvals = yybadprod 234 yyvals; -private yyprod235 ((_, (YYNTrhofun yy3)):(_, (YYTok yy2)):(_, (YYNTtapp yy1)):yyvs) = do { let {!yyr = reduce235 yy1 yy2 yy3}; YYM.pure (YYNTrhofun yyr, yyvs)}; +private yyprod235 ((_, (YYNTtapp yy1)):yyvs) = do { let {!yyr = reduce235 yy1}; YYM.pure (YYNTrhofun yyr, yyvs)}; private yyprod235 yyvals = yybadprod 235 yyvals; -private yyprod236 ((_, (YYNTtapp yy1)):yyvs) = YYM.pure (YYNTtau (yy1), yyvs); +private yyprod236 ((_, (YYNTrhofun yy3)):(_, (YYTok yy2)):(_, (YYNTtapp yy1)):yyvs) = do { let {!yyr = reduce236 yy1 yy2 yy3}; YYM.pure (YYNTrhofun yyr, yyvs)}; private yyprod236 yyvals = yybadprod 236 yyvals; -private yyprod237 ((_, (YYNTforall yy1)):yyvs) = do { let {!yyr = reduce237 yy1}; YYM.pure (YYNTtau yyr, yyvs)}; +private yyprod237 ((_, (YYNTtapp yy1)):yyvs) = YYM.pure (YYNTtau (yy1), yyvs); private yyprod237 yyvals = yybadprod 237 yyvals; -private yyprod238 ((_, (YYNTtau yy3)):(_, (YYTok yy2)):(_, (YYNTtapp yy1)):yyvs) = do { let {!yyr = reduce238 yy1 yy2 yy3}; YYM.pure (YYNTtau yyr, yyvs)}; +private yyprod238 ((_, (YYNTforall yy1)):yyvs) = do { let {!yyr = reduce238 yy1}; YYM.pure (YYNTtau yyr, yyvs)}; private yyprod238 yyvals = yybadprod 238 yyvals; -private yyprod239 ((_, (YYNTtau yy1)):yyvs) = do { let {!yyr = reduce239 yy1}; YYM.pure (YYNTtauSC yyr, yyvs)}; +private yyprod239 ((_, (YYNTtau yy3)):(_, (YYTok yy2)):(_, (YYNTtapp yy1)):yyvs) = do { let {!yyr = reduce239 yy1 yy2 yy3}; YYM.pure (YYNTtau yyr, yyvs)}; private yyprod239 yyvals = yybadprod 239 yyvals; -private yyprod240 ((_, (YYNTtauSC yy3)):(_, (YYTok yy2)):(_, (YYNTtau yy1)):yyvs) = do { let {!yyr = reduce240 yy1 yy2 yy3}; YYM.pure (YYNTtauSC yyr, yyvs)}; +private yyprod240 ((_, (YYNTtau yy1)):yyvs) = do { let {!yyr = reduce240 yy1}; YYM.pure (YYNTtauSC yyr, yyvs)}; private yyprod240 yyvals = yybadprod 240 yyvals; -private yyprod241 ((_, (YYNTtau yy1)):yyvs) = do { let {!yyr = reduce241 yy1}; YYM.pure (YYNTtauSB yyr, yyvs)}; +private yyprod241 ((_, (YYNTtauSC yy3)):(_, (YYTok yy2)):(_, (YYNTtau yy1)):yyvs) = do { let {!yyr = reduce241 yy1 yy2 yy3}; YYM.pure (YYNTtauSC yyr, yyvs)}; private yyprod241 yyvals = yybadprod 241 yyvals; -private yyprod242 ((_, (YYNTtauSB yy3)):(_, (YYTok yy2)):(_, (YYNTtau yy1)):yyvs) = do { let {!yyr = reduce242 yy1 yy2 yy3}; YYM.pure (YYNTtauSB yyr, yyvs)}; +private yyprod242 ((_, (YYNTtau yy1)):yyvs) = do { let {!yyr = reduce242 yy1}; YYM.pure (YYNTtauSB yyr, yyvs)}; private yyprod242 yyvals = yybadprod 242 yyvals; -private yyprod243 ((_, (YYNTsimpletypes yy1)):yyvs) = do { let {!yyr = reduce243 yy1}; YYM.pure (YYNTtapp yyr, yyvs)}; +private yyprod243 ((_, (YYNTtauSB yy3)):(_, (YYTok yy2)):(_, (YYNTtau yy1)):yyvs) = do { let {!yyr = reduce243 yy1 yy2 yy3}; YYM.pure (YYNTtauSB yyr, yyvs)}; private yyprod243 yyvals = yybadprod 243 yyvals; -private yyprod244 ((_, (YYNTtyvar yy1)):yyvs) = YYM.pure (YYNTsimpletype (yy1), yyvs); +private yyprod244 ((_, (YYNTsimpletypes yy1)):yyvs) = do { let {!yyr = reduce244 yy1}; YYM.pure (YYNTtapp yyr, yyvs)}; private yyprod244 yyvals = yybadprod 244 yyvals; -private yyprod245 ((_, (YYNTtyname yy1)):yyvs) = do { let {!yyr = reduce245 yy1}; YYM.pure (YYNTsimpletype yyr, yyvs)}; +private yyprod245 ((_, (YYNTtyvar yy1)):yyvs) = YYM.pure (YYNTsimpletype (yy1), yyvs); private yyprod245 yyvals = yybadprod 245 yyvals; -private yyprod246 ((_, (YYTok yy3)):(_, (YYNTtau yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce246 yy1 yy2 yy3}; YYM.pure (YYNTsimpletype yyr, yyvs)}; +private yyprod246 ((_, (YYNTtyname yy1)):yyvs) = do { let {!yyr = reduce246 yy1}; YYM.pure (YYNTsimpletype yyr, yyvs)}; private yyprod246 yyvals = yybadprod 246 yyvals; -private yyprod247 ((_, (YYTok yy5)):(_, (YYNTtauSC yy4)):(_, (YYTok yy3)):(_, (YYNTtau yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce247 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTsimpletype yyr, yyvs)}; +private yyprod247 ((_, (YYTok yy3)):(_, (YYNTtau yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce247 yy1 yy2 yy3}; YYM.pure (YYNTsimpletype yyr, yyvs)}; private yyprod247 yyvals = yybadprod 247 yyvals; -private yyprod248 ((_, (YYTok yy5)):(_, (YYNTtauSB yy4)):(_, (YYTok yy3)):(_, (YYNTtau yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce248 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTsimpletype yyr, yyvs)}; +private yyprod248 ((_, (YYTok yy5)):(_, (YYNTtauSC yy4)):(_, (YYTok yy3)):(_, (YYNTtau yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce248 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTsimpletype yyr, yyvs)}; private yyprod248 yyvals = yybadprod 248 yyvals; -private yyprod249 ((_, (YYTok yy3)):(_, (YYNTtau yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce249 yy1 yy2 yy3}; YYM.pure (YYNTsimpletype yyr, yyvs)}; +private yyprod249 ((_, (YYTok yy5)):(_, (YYNTtauSB yy4)):(_, (YYTok yy3)):(_, (YYNTtau yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce249 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTsimpletype yyr, yyvs)}; private yyprod249 yyvals = yybadprod 249 yyvals; -private yyprod250 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce250 yy1}; YYM.pure (YYNTtyvar yyr, yyvs)}; +private yyprod250 ((_, (YYTok yy3)):(_, (YYNTtau yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce250 yy1 yy2 yy3}; YYM.pure (YYNTsimpletype yyr, yyvs)}; private yyprod250 yyvals = yybadprod 250 yyvals; -private yyprod251 ((_, (YYTok yy5)):(_, (YYNTkind yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce251 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTtyvar yyr, yyvs)}; +private yyprod251 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce251 yy1}; YYM.pure (YYNTtyvar yyr, yyvs)}; private yyprod251 yyvals = yybadprod 251 yyvals; -private yyprod252 ((_, (YYTok yy5)):(_, (YYNTtauSC yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce252 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTtyvar yyr, yyvs)}; +private yyprod252 ((_, (YYTok yy5)):(_, (YYNTkind yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce252 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTtyvar yyr, yyvs)}; private yyprod252 yyvals = yybadprod 252 yyvals; -private yyprod253 ((_, (YYTok yy4)):(_, (YYNTtauSC yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce253 yy1 yy2 yy3 yy4}; YYM.pure (YYNTtyvar yyr, yyvs)}; +private yyprod253 ((_, (YYTok yy5)):(_, (YYNTtauSC yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce253 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTtyvar yyr, yyvs)}; private yyprod253 yyvals = yybadprod 253 yyvals; -private yyprod254 ((_, (YYTok yy4)):(_, (YYNTtapp yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce254 yy1 yy2 yy3 yy4}; YYM.pure (YYNTtyvar yyr, yyvs)}; +private yyprod254 ((_, (YYTok yy4)):(_, (YYNTtauSC yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce254 yy1 yy2 yy3 yy4}; YYM.pure (YYNTtyvar yyr, yyvs)}; private yyprod254 yyvals = yybadprod 254 yyvals; -private yyprod255 ((_, (YYNTqconid yy1)):yyvs) = YYM.pure (YYNTtyname (yy1), yyvs); +private yyprod255 ((_, (YYTok yy4)):(_, (YYNTtapp yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce255 yy1 yy2 yy3 yy4}; YYM.pure (YYNTtyvar yyr, yyvs)}; private yyprod255 yyvals = yybadprod 255 yyvals; -private yyprod256 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce256 yy1 yy2}; YYM.pure (YYNTtyname yyr, yyvs)}; +private yyprod256 ((_, (YYNTqconid yy1)):yyvs) = YYM.pure (YYNTtyname (yy1), yyvs); private yyprod256 yyvals = yybadprod 256 yyvals; private yyprod257 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce257 yy1 yy2}; YYM.pure (YYNTtyname yyr, yyvs)}; private yyprod257 yyvals = yybadprod 257 yyvals; -private yyprod258 ((_, (YYTok yy3)):(_, (YYNTcommata yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce258 yy1 yy2 yy3}; YYM.pure (YYNTtyname yyr, yyvs)}; +private yyprod258 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce258 yy1 yy2}; YYM.pure (YYNTtyname yyr, yyvs)}; private yyprod258 yyvals = yybadprod 258 yyvals; -private yyprod259 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce259 yy1 yy2 yy3}; YYM.pure (YYNTtyname yyr, yyvs)}; +private yyprod259 ((_, (YYTok yy3)):(_, (YYNTcommata yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce259 yy1 yy2 yy3}; YYM.pure (YYNTtyname yyr, yyvs)}; private yyprod259 yyvals = yybadprod 259 yyvals; -private yyprod260 ((_, (YYNTkind yy3)):(_, (YYTok yy2)):(_, (YYNTsimplekind yy1)):yyvs) = do { let {!yyr = reduce260 yy1 yy2 yy3}; YYM.pure (YYNTkind yyr, yyvs)}; +private yyprod260 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce260 yy1 yy2 yy3}; YYM.pure (YYNTtyname yyr, yyvs)}; private yyprod260 yyvals = yybadprod 260 yyvals; -private yyprod261 ((_, (YYNTsimplekind yy1)):yyvs) = YYM.pure (YYNTkind (yy1), yyvs); +private yyprod261 ((_, (YYNTkind yy3)):(_, (YYTok yy2)):(_, (YYNTsimplekind yy1)):yyvs) = do { let {!yyr = reduce261 yy1 yy2 yy3}; YYM.pure (YYNTkind yyr, yyvs)}; private yyprod261 yyvals = yybadprod 261 yyvals; -private yyprod262 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce262 yy1 ;YYM.pure (YYNTsimplekind yyr, yyvs)}; +private yyprod262 ((_, (YYNTsimplekind yy1)):yyvs) = YYM.pure (YYNTkind (yy1), yyvs); private yyprod262 yyvals = yybadprod 262 yyvals; -private yyprod263 ((_, (YYTok yy3)):(_, (YYNTkind yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce263 yy1 yy2 yy3}; YYM.pure (YYNTsimplekind yyr, yyvs)}; +private yyprod263 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce263 yy1 ;YYM.pure (YYNTsimplekind yyr, yyvs)}; private yyprod263 yyvals = yybadprod 263 yyvals; -private yyprod264 ((_, (YYNTtyvar yy2)):(_, (YYNTqconid yy1)):yyvs) = do { let {!yyr = reduce264 yy1 yy2}; YYM.pure (YYNTscontext yyr, yyvs)}; +private yyprod264 ((_, (YYTok yy3)):(_, (YYNTkind yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce264 yy1 yy2 yy3}; YYM.pure (YYNTsimplekind yyr, yyvs)}; private yyprod264 yyvals = yybadprod 264 yyvals; -private yyprod265 ((_, (YYNTscontext yy1)):yyvs) = do { let {!yyr = reduce265 yy1}; YYM.pure (YYNTscontexts yyr, yyvs)}; +private yyprod265 ((_, (YYNTtyvar yy2)):(_, (YYNTqconid yy1)):yyvs) = do { let {!yyr = reduce265 yy1 yy2}; YYM.pure (YYNTscontext yyr, yyvs)}; private yyprod265 yyvals = yybadprod 265 yyvals; -private yyprod266 ((_, (YYTok yy2)):(_, (YYNTscontext yy1)):yyvs) = do { let {!yyr = reduce266 yy1 yy2}; YYM.pure (YYNTscontexts yyr, yyvs)}; +private yyprod266 ((_, (YYNTscontext yy1)):yyvs) = do { let {!yyr = reduce266 yy1}; YYM.pure (YYNTscontexts yyr, yyvs)}; private yyprod266 yyvals = yybadprod 266 yyvals; -private yyprod267 ((_, (YYNTscontexts yy3)):(_, (YYTok yy2)):(_, (YYNTscontext yy1)):yyvs) = do { let {!yyr = reduce267 yy1 yy2 yy3}; YYM.pure (YYNTscontexts yyr, yyvs)}; +private yyprod267 ((_, (YYTok yy2)):(_, (YYNTscontext yy1)):yyvs) = do { let {!yyr = reduce267 yy1 yy2}; YYM.pure (YYNTscontexts yyr, yyvs)}; private yyprod267 yyvals = yybadprod 267 yyvals; -private yyprod268 ((_, (YYNTscontext yy1)):yyvs) = do { let {!yyr = reduce268 yy1}; YYM.pure (YYNTccontext yyr, yyvs)}; +private yyprod268 ((_, (YYNTscontexts yy3)):(_, (YYTok yy2)):(_, (YYNTscontext yy1)):yyvs) = do { let {!yyr = reduce268 yy1 yy2 yy3}; YYM.pure (YYNTscontexts yyr, yyvs)}; private yyprod268 yyvals = yybadprod 268 yyvals; -private yyprod269 ((_, (YYTok yy3)):(_, (YYNTscontexts yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce269 yy1 yy2 yy3}; YYM.pure (YYNTccontext yyr, yyvs)}; +private yyprod269 ((_, (YYNTscontext yy1)):yyvs) = do { let {!yyr = reduce269 yy1}; YYM.pure (YYNTccontext yyr, yyvs)}; private yyprod269 yyvals = yybadprod 269 yyvals; -private yyprod270 ((_, (YYNTwheredef yy6)):(_, (YYNTtyvar yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYNTccontext yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce270 yy1 yy2 yy3 yy4 yy5 yy6 ;YYM.pure (YYNTclassdef yyr, yyvs)}; +private yyprod270 ((_, (YYTok yy3)):(_, (YYNTscontexts yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce270 yy1 yy2 yy3}; YYM.pure (YYNTccontext yyr, yyvs)}; private yyprod270 yyvals = yybadprod 270 yyvals; -private yyprod271 ((_, (YYNTwheredef yy3)):(_, (YYNTccontext yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce271 yy1 yy2 yy3 ;YYM.pure (YYNTclassdef yyr, yyvs)}; +private yyprod271 ((_, (YYNTwheredef yy6)):(_, (YYNTtyvar yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYNTccontext yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce271 yy1 yy2 yy3 yy4 yy5 yy6 ;YYM.pure (YYNTclassdef yyr, yyvs)}; private yyprod271 yyvals = yybadprod 271 yyvals; -private yyprod272 ((_, (YYNTsimpletype yy2)):(_, (YYNTqconid yy1)):yyvs) = do { let {!yyr = reduce272 yy1 yy2}; YYM.pure (YYNTsicontext yyr, yyvs)}; +private yyprod272 ((_, (YYNTwheredef yy3)):(_, (YYNTccontext yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce272 yy1 yy2 yy3 ;YYM.pure (YYNTclassdef yyr, yyvs)}; private yyprod272 yyvals = yybadprod 272 yyvals; -private yyprod273 ((_, (YYNTsicontext yy1)):yyvs) = do { let {!yyr = reduce273 yy1}; YYM.pure (YYNTsicontexts yyr, yyvs)}; +private yyprod273 ((_, (YYNTsimpletype yy2)):(_, (YYNTqconid yy1)):yyvs) = do { let {!yyr = reduce273 yy1 yy2}; YYM.pure (YYNTsicontext yyr, yyvs)}; private yyprod273 yyvals = yybadprod 273 yyvals; -private yyprod274 ((_, (YYTok yy2)):(_, (YYNTsicontext yy1)):yyvs) = do { let {!yyr = reduce274 yy1 yy2}; YYM.pure (YYNTsicontexts yyr, yyvs)}; +private yyprod274 ((_, (YYNTsicontext yy1)):yyvs) = do { let {!yyr = reduce274 yy1}; YYM.pure (YYNTsicontexts yyr, yyvs)}; private yyprod274 yyvals = yybadprod 274 yyvals; -private yyprod275 ((_, (YYNTsicontexts yy3)):(_, (YYTok yy2)):(_, (YYNTsicontext yy1)):yyvs) = do { let {!yyr = reduce275 yy1 yy2 yy3}; YYM.pure (YYNTsicontexts yyr, yyvs)}; +private yyprod275 ((_, (YYTok yy2)):(_, (YYNTsicontext yy1)):yyvs) = do { let {!yyr = reduce275 yy1 yy2}; YYM.pure (YYNTsicontexts yyr, yyvs)}; private yyprod275 yyvals = yybadprod 275 yyvals; -private yyprod276 ((_, (YYNTsicontext yy1)):yyvs) = do { let {!yyr = reduce276 yy1}; YYM.pure (YYNTicontext yyr, yyvs)}; +private yyprod276 ((_, (YYNTsicontexts yy3)):(_, (YYTok yy2)):(_, (YYNTsicontext yy1)):yyvs) = do { let {!yyr = reduce276 yy1 yy2 yy3}; YYM.pure (YYNTsicontexts yyr, yyvs)}; private yyprod276 yyvals = yybadprod 276 yyvals; -private yyprod277 ((_, (YYTok yy3)):(_, (YYNTsicontexts yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce277 yy1 yy2 yy3}; YYM.pure (YYNTicontext yyr, yyvs)}; +private yyprod277 ((_, (YYNTsicontext yy1)):yyvs) = do { let {!yyr = reduce277 yy1}; YYM.pure (YYNTicontext yyr, yyvs)}; private yyprod277 yyvals = yybadprod 277 yyvals; -private yyprod278 ((_, (YYNTsimpletype yy4)):(_, (YYNTtyname yy3)):(_, (YYTok yy2)):(_, (YYNTicontext yy1)):yyvs) = do { let {!yyr = reduce278 yy1 yy2 yy3 yy4}; YYM.pure (YYNTinsthead yyr, yyvs)}; +private yyprod278 ((_, (YYTok yy3)):(_, (YYNTsicontexts yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce278 yy1 yy2 yy3}; YYM.pure (YYNTicontext yyr, yyvs)}; private yyprod278 yyvals = yybadprod 278 yyvals; -private yyprod279 ((_, (YYNTicontext yy1)):yyvs) = do { yyr <- reduce279 yy1 ;YYM.pure (YYNTinsthead yyr, yyvs)}; +private yyprod279 ((_, (YYNTsimpletype yy4)):(_, (YYNTtyname yy3)):(_, (YYTok yy2)):(_, (YYNTicontext yy1)):yyvs) = do { let {!yyr = reduce279 yy1 yy2 yy3 yy4}; YYM.pure (YYNTinsthead yyr, yyvs)}; private yyprod279 yyvals = yybadprod 279 yyvals; -private yyprod280 ((_, (YYNTwheredef yy3)):(_, (YYNTinsthead yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce280 yy1 yy2 yy3}; YYM.pure (YYNTinstdef yyr, yyvs)}; +private yyprod280 ((_, (YYNTicontext yy1)):yyvs) = do { yyr <- reduce280 yy1 ;YYM.pure (YYNTinsthead yyr, yyvs)}; private yyprod280 yyvals = yybadprod 280 yyvals; -private yyprod281 ((_, (YYNTinsthead yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce281 yy1 yy2}; YYM.pure (YYNTderivedef yyr, yyvs)}; +private yyprod281 ((_, (YYNTwheredef yy3)):(_, (YYNTinsthead yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce281 yy1 yy2 yy3}; YYM.pure (YYNTinstdef yyr, yyvs)}; private yyprod281 yyvals = yybadprod 281 yyvals; -private yyprod282 ((_, (YYNTwheredef yy2)):(_, (YYNTdatainit yy1)):yyvs) = do { let {!yyr = reduce282 yy1 yy2}; YYM.pure (YYNTdatadef yyr, yyvs)}; +private yyprod282 ((_, (YYNTinsthead yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce282 yy1 yy2}; YYM.pure (YYNTderivedef yyr, yyvs)}; private yyprod282 yyvals = yybadprod 282 yyvals; -private yyprod283 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce283 yy1 yy2}; YYM.pure (YYNTnativepur yyr, yyvs)}; +private yyprod283 ((_, (YYNTwheredef yy2)):(_, (YYNTdatainit yy1)):yyvs) = do { let {!yyr = reduce283 yy1 yy2}; YYM.pure (YYNTdatadef yyr, yyvs)}; private yyprod283 yyvals = yybadprod 283 yyvals; -private yyprod284 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce284 yy1}; YYM.pure (YYNTnativepur yyr, yyvs)}; +private yyprod284 ((_, (YYNTwheredef yy2)):(_, (YYNTdatajavainit yy1)):yyvs) = do { let {!yyr = reduce284 yy1 yy2}; YYM.pure (YYNTdatajavadef yyr, yyvs)}; private yyprod284 yyvals = yybadprod 284 yyvals; -private yyprod285 ((_, (YYNTnativename yy1)):yyvs) = do { let {!yyr = reduce285 yy1}; YYM.pure (YYNTnativespec yyr, yyvs)}; +private yyprod285 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce285 yy1 yy2}; YYM.pure (YYNTnativepur yyr, yyvs)}; private yyprod285 yyvals = yybadprod 285 yyvals; -private yyprod286 ((_, (YYNTgargs yy2)):(_, (YYNTnativename yy1)):yyvs) = do { let {!yyr = reduce286 yy1 yy2}; YYM.pure (YYNTnativespec yyr, yyvs)}; +private yyprod286 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce286 yy1}; YYM.pure (YYNTnativepur yyr, yyvs)}; private yyprod286 yyvals = yybadprod 286 yyvals; -private yyprod287 ((_, (YYTok yy3)):(_, (YYNTtauSC yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce287 yy1 yy2 yy3}; YYM.pure (YYNTgargs yyr, yyvs)}; +private yyprod287 ((_, (YYNTnativename yy1)):yyvs) = do { let {!yyr = reduce287 yy1}; YYM.pure (YYNTnativespec yyr, yyvs)}; private yyprod287 yyvals = yybadprod 287 yyvals; -private yyprod288 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce288 yy1 yy2}; YYM.pure (YYNTgargs yyr, yyvs)}; +private yyprod288 ((_, (YYNTgargs yy2)):(_, (YYNTnativename yy1)):yyvs) = do { let {!yyr = reduce288 yy1 yy2}; YYM.pure (YYNTnativespec yyr, yyvs)}; private yyprod288 yyvals = yybadprod 288 yyvals; -private yyprod289 ((_, (YYNTnativespec yy5)):(_, (YYNTnativepur yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce289 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTdatainit yyr, yyvs)}; +private yyprod289 ((_, (YYTok yy3)):(_, (YYNTtauSC yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce289 yy1 yy2 yy3}; YYM.pure (YYNTgargs yyr, yyvs)}; private yyprod289 yyvals = yybadprod 289 yyvals; -private yyprod290 ((_, (YYNTnativespec yy6)):(_, (YYNTnativepur yy5)):(_, (YYTok yy4)):(_, (YYNTdvars yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce290 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTdatainit yyr, yyvs)}; +private yyprod290 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce290 yy1 yy2}; YYM.pure (YYNTgargs yyr, yyvs)}; private yyprod290 yyvals = yybadprod 290 yyvals; private yyprod291 ((_, (YYNTdalts yy5)):(_, (YYTok yy4)):(_, (YYNTdvars yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce291 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTdatainit yyr, yyvs)}; private yyprod291 yyvals = yybadprod 291 yyvals; @@ -7602,345 +7669,349 @@ private yyprod294 ((_, (YYNTdalt yy5)):(_, (YYTok yy4)):(_, (YYNTdvars yy3)):(_, private yyprod294 yyvals = yybadprod 294 yyvals; private yyprod295 ((_, (YYNTdalt yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce295 yy1 yy2 yy3 yy4}; YYM.pure (YYNTdatainit yyr, yyvs)}; private yyprod295 yyvals = yybadprod 295 yyvals; -private yyprod296 ((_, (YYNTtyvar yy1)):yyvs) = do { let {!yyr = reduce296 yy1}; YYM.pure (YYNTdvars yyr, yyvs)}; +private yyprod296 ((_, (YYNTnativespec yy5)):(_, (YYNTnativepur yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce296 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTdatajavainit yyr, yyvs)}; private yyprod296 yyvals = yybadprod 296 yyvals; -private yyprod297 ((_, (YYNTdvars yy2)):(_, (YYNTtyvar yy1)):yyvs) = do { let {!yyr = reduce297 yy1 yy2}; YYM.pure (YYNTdvars yyr, yyvs)}; +private yyprod297 ((_, (YYNTnativespec yy6)):(_, (YYNTnativepur yy5)):(_, (YYTok yy4)):(_, (YYNTdvars yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce297 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTdatajavainit yyr, yyvs)}; private yyprod297 yyvals = yybadprod 297 yyvals; -private yyprod298 ((_, (YYNTdalt yy1)):yyvs) = do { let {!yyr = reduce298 yy1}; YYM.pure (YYNTdalts yyr, yyvs)}; +private yyprod298 ((_, (YYNTtyvar yy1)):yyvs) = do { let {!yyr = reduce298 yy1}; YYM.pure (YYNTdvars yyr, yyvs)}; private yyprod298 yyvals = yybadprod 298 yyvals; -private yyprod299 ((_, (YYNTdalts yy3)):(_, (YYTok yy2)):(_, (YYNTdalt yy1)):yyvs) = do { let {!yyr = reduce299 yy1 yy2 yy3}; YYM.pure (YYNTdalts yyr, yyvs)}; +private yyprod299 ((_, (YYNTdvars yy2)):(_, (YYNTtyvar yy1)):yyvs) = do { let {!yyr = reduce299 yy1 yy2}; YYM.pure (YYNTdvars yyr, yyvs)}; private yyprod299 yyvals = yybadprod 299 yyvals; -private yyprod300 ((_, (YYNTvisdalt yy1)):yyvs) = YYM.pure (YYNTdalt (yy1), yyvs); +private yyprod300 ((_, (YYNTdalt yy1)):yyvs) = do { let {!yyr = reduce300 yy1}; YYM.pure (YYNTdalts yyr, yyvs)}; private yyprod300 yyvals = yybadprod 300 yyvals; -private yyprod301 ((_, (YYTok yy2)):(_, (YYNTvisdalt yy1)):yyvs) = do { let {!yyr = reduce301 yy1 yy2}; YYM.pure (YYNTdalt yyr, yyvs)}; +private yyprod301 ((_, (YYNTdalts yy3)):(_, (YYTok yy2)):(_, (YYNTdalt yy1)):yyvs) = do { let {!yyr = reduce301 yy1 yy2 yy3}; YYM.pure (YYNTdalts yyr, yyvs)}; private yyprod301 yyvals = yybadprod 301 yyvals; -private yyprod302 ((_, (YYNTvisdalt yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce302 yy1 yy2}; YYM.pure (YYNTdalt yyr, yyvs)}; +private yyprod302 ((_, (YYNTvisdalt yy1)):yyvs) = YYM.pure (YYNTdalt (yy1), yyvs); private yyprod302 yyvals = yybadprod 302 yyvals; -private yyprod303 ((_, (YYNTstrictdalt yy1)):yyvs) = YYM.pure (YYNTvisdalt (yy1), yyvs); +private yyprod303 ((_, (YYTok yy2)):(_, (YYNTvisdalt yy1)):yyvs) = do { let {!yyr = reduce303 yy1 yy2}; YYM.pure (YYNTdalt yyr, yyvs)}; private yyprod303 yyvals = yybadprod 303 yyvals; -private yyprod304 ((_, (YYNTstrictdalt yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce304 yy1 yy2}; YYM.pure (YYNTvisdalt yyr, yyvs)}; +private yyprod304 ((_, (YYNTvisdalt yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce304 yy1 yy2}; YYM.pure (YYNTdalt yyr, yyvs)}; private yyprod304 yyvals = yybadprod 304 yyvals; -private yyprod305 ((_, (YYNTstrictdalt yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce305 yy1 yy2}; YYM.pure (YYNTvisdalt yyr, yyvs)}; +private yyprod305 ((_, (YYNTstrictdalt yy1)):yyvs) = YYM.pure (YYNTvisdalt (yy1), yyvs); private yyprod305 yyvals = yybadprod 305 yyvals; private yyprod306 ((_, (YYNTstrictdalt yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce306 yy1 yy2}; YYM.pure (YYNTvisdalt yyr, yyvs)}; private yyprod306 yyvals = yybadprod 306 yyvals; -private yyprod307 ((_, (YYNTsimpledalt yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce307 yy1 yy2}; YYM.pure (YYNTstrictdalt yyr, yyvs)}; +private yyprod307 ((_, (YYNTstrictdalt yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce307 yy1 yy2}; YYM.pure (YYNTvisdalt yyr, yyvs)}; private yyprod307 yyvals = yybadprod 307 yyvals; -private yyprod308 ((_, (YYNTsimpledalt yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce308 yy1 yy2}; YYM.pure (YYNTstrictdalt yyr, yyvs)}; +private yyprod308 ((_, (YYNTstrictdalt yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce308 yy1 yy2}; YYM.pure (YYNTvisdalt yyr, yyvs)}; private yyprod308 yyvals = yybadprod 308 yyvals; -private yyprod309 ((_, (YYNTsimpledalt yy1)):yyvs) = YYM.pure (YYNTstrictdalt (yy1), yyvs); +private yyprod309 ((_, (YYNTsimpledalt yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce309 yy1 yy2}; YYM.pure (YYNTstrictdalt yyr, yyvs)}; private yyprod309 yyvals = yybadprod 309 yyvals; -private yyprod310 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce310 yy1}; YYM.pure (YYNTsimpledalt yyr, yyvs)}; +private yyprod310 ((_, (YYNTsimpledalt yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce310 yy1 yy2}; YYM.pure (YYNTstrictdalt yyr, yyvs)}; private yyprod310 yyvals = yybadprod 310 yyvals; -private yyprod311 ((_, (YYTok yy4)):(_, (YYNTconflds yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce311 yy1 yy2 yy3 yy4}; YYM.pure (YYNTsimpledalt yyr, yyvs)}; +private yyprod311 ((_, (YYNTsimpledalt yy1)):yyvs) = YYM.pure (YYNTstrictdalt (yy1), yyvs); private yyprod311 yyvals = yybadprod 311 yyvals; -private yyprod312 ((_, (YYNTcontypes yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce312 yy1 yy2}; YYM.pure (YYNTsimpledalt yyr, yyvs)}; +private yyprod312 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce312 yy1}; YYM.pure (YYNTsimpledalt yyr, yyvs)}; private yyprod312 yyvals = yybadprod 312 yyvals; -private yyprod313 ((_, (YYNTstrictcontype yy1)):yyvs) = do { let {!yyr = reduce313 yy1}; YYM.pure (YYNTcontypes yyr, yyvs)}; +private yyprod313 ((_, (YYTok yy4)):(_, (YYNTconflds yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce313 yy1 yy2 yy3 yy4}; YYM.pure (YYNTsimpledalt yyr, yyvs)}; private yyprod313 yyvals = yybadprod 313 yyvals; -private yyprod314 ((_, (YYNTcontypes yy2)):(_, (YYNTstrictcontype yy1)):yyvs) = do { let {!yyr = reduce314 yy1 yy2}; YYM.pure (YYNTcontypes yyr, yyvs)}; +private yyprod314 ((_, (YYNTcontypes yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce314 yy1 yy2}; YYM.pure (YYNTsimpledalt yyr, yyvs)}; private yyprod314 yyvals = yybadprod 314 yyvals; -private yyprod315 ((_, (YYNTcontype yy1)):yyvs) = YYM.pure (YYNTstrictcontype (yy1), yyvs); +private yyprod315 ((_, (YYNTstrictcontype yy1)):yyvs) = do { let {!yyr = reduce315 yy1}; YYM.pure (YYNTcontypes yyr, yyvs)}; private yyprod315 yyvals = yybadprod 315 yyvals; -private yyprod316 ((_, (YYNTcontype yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce316 yy1 yy2}; YYM.pure (YYNTstrictcontype yyr, yyvs)}; +private yyprod316 ((_, (YYNTcontypes yy2)):(_, (YYNTstrictcontype yy1)):yyvs) = do { let {!yyr = reduce316 yy1 yy2}; YYM.pure (YYNTcontypes yyr, yyvs)}; private yyprod316 yyvals = yybadprod 316 yyvals; -private yyprod317 ((_, (YYNTcontype yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce317 yy1 yy2}; YYM.pure (YYNTstrictcontype yyr, yyvs)}; +private yyprod317 ((_, (YYNTcontype yy1)):yyvs) = YYM.pure (YYNTstrictcontype (yy1), yyvs); private yyprod317 yyvals = yybadprod 317 yyvals; -private yyprod318 ((_, (YYNTsimpletype yy1)):yyvs) = do { let {!yyr = reduce318 yy1}; YYM.pure (YYNTcontype yyr, yyvs)}; +private yyprod318 ((_, (YYNTcontype yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce318 yy1 yy2}; YYM.pure (YYNTstrictcontype yyr, yyvs)}; private yyprod318 yyvals = yybadprod 318 yyvals; -private yyprod319 ((_, (YYNTsimpletype yy1)):yyvs) = do { let {!yyr = reduce319 yy1}; YYM.pure (YYNTsimpletypes yyr, yyvs)}; +private yyprod319 ((_, (YYNTcontype yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce319 yy1 yy2}; YYM.pure (YYNTstrictcontype yyr, yyvs)}; private yyprod319 yyvals = yybadprod 319 yyvals; -private yyprod320 ((_, (YYNTsimpletypes yy2)):(_, (YYNTsimpletype yy1)):yyvs) = do { let {!yyr = reduce320 yy1 yy2}; YYM.pure (YYNTsimpletypes yyr, yyvs)}; +private yyprod320 ((_, (YYNTsimpletype yy1)):yyvs) = do { let {!yyr = reduce320 yy1}; YYM.pure (YYNTcontype yyr, yyvs)}; private yyprod320 yyvals = yybadprod 320 yyvals; -private yyprod321 ((_, (YYNTconfld yy1)):yyvs) = YYM.pure (YYNTconflds (yy1), yyvs); +private yyprod321 ((_, (YYNTsimpletype yy1)):yyvs) = do { let {!yyr = reduce321 yy1}; YYM.pure (YYNTsimpletypes yyr, yyvs)}; private yyprod321 yyvals = yybadprod 321 yyvals; -private yyprod322 ((_, (YYTok yy2)):(_, (YYNTconfld yy1)):yyvs) = do { let {!yyr = reduce322 yy1 yy2}; YYM.pure (YYNTconflds yyr, yyvs)}; +private yyprod322 ((_, (YYNTsimpletypes yy2)):(_, (YYNTsimpletype yy1)):yyvs) = do { let {!yyr = reduce322 yy1 yy2}; YYM.pure (YYNTsimpletypes yyr, yyvs)}; private yyprod322 yyvals = yybadprod 322 yyvals; -private yyprod323 ((_, (YYTok yy2)):(_, (YYNTconfld yy1)):yyvs) = do { let {!yyr = reduce323 yy1 yy2}; YYM.pure (YYNTconflds yyr, yyvs)}; +private yyprod323 ((_, (YYNTconfld yy1)):yyvs) = YYM.pure (YYNTconflds (yy1), yyvs); private yyprod323 yyvals = yybadprod 323 yyvals; -private yyprod324 ((_, (YYNTconflds yy3)):(_, (YYTok yy2)):(_, (YYNTconfld yy1)):yyvs) = do { let {!yyr = reduce324 yy1 yy2 yy3}; YYM.pure (YYNTconflds yyr, yyvs)}; +private yyprod324 ((_, (YYTok yy2)):(_, (YYNTconfld yy1)):yyvs) = do { let {!yyr = reduce324 yy1 yy2}; YYM.pure (YYNTconflds yyr, yyvs)}; private yyprod324 yyvals = yybadprod 324 yyvals; -private yyprod325 ((_, (YYNTconflds yy3)):(_, (YYTok yy2)):(_, (YYNTconfld yy1)):yyvs) = do { let {!yyr = reduce325 yy1 yy2 yy3}; YYM.pure (YYNTconflds yyr, yyvs)}; +private yyprod325 ((_, (YYTok yy2)):(_, (YYNTconfld yy1)):yyvs) = do { let {!yyr = reduce325 yy1 yy2}; YYM.pure (YYNTconflds yyr, yyvs)}; private yyprod325 yyvals = yybadprod 325 yyvals; -private yyprod326 ((_, (YYNTsigma yy4)):(_, (YYTok yy3)):(_, (YYNTfldids yy2)):(_, (YYNTdocsO yy1)):yyvs) = do { let {!yyr = reduce326 yy1 yy2 yy3 yy4}; YYM.pure (YYNTconfld yyr, yyvs)}; +private yyprod326 ((_, (YYNTconflds yy3)):(_, (YYTok yy2)):(_, (YYNTconfld yy1)):yyvs) = do { let {!yyr = reduce326 yy1 yy2 yy3}; YYM.pure (YYNTconflds yyr, yyvs)}; private yyprod326 yyvals = yybadprod 326 yyvals; -private yyprod327 ((_, (YYNTfldid yy1)):yyvs) = do { let {!yyr = reduce327 yy1}; YYM.pure (YYNTfldids yyr, yyvs)}; +private yyprod327 ((_, (YYNTconflds yy3)):(_, (YYTok yy2)):(_, (YYNTconfld yy1)):yyvs) = do { let {!yyr = reduce327 yy1 yy2 yy3}; YYM.pure (YYNTconflds yyr, yyvs)}; private yyprod327 yyvals = yybadprod 327 yyvals; -private yyprod328 ((_, (YYNTfldids yy3)):(_, (YYTok yy2)):(_, (YYNTfldid yy1)):yyvs) = do { let {!yyr = reduce328 yy1 yy2 yy3}; YYM.pure (YYNTfldids yyr, yyvs)}; +private yyprod328 ((_, (YYNTsigma yy4)):(_, (YYTok yy3)):(_, (YYNTfldids yy2)):(_, (YYNTdocsO yy1)):yyvs) = do { let {!yyr = reduce328 yy1 yy2 yy3 yy4}; YYM.pure (YYNTconfld yyr, yyvs)}; private yyprod328 yyvals = yybadprod 328 yyvals; -private yyprod329 ((_, (YYNTstrictfldid yy1)):yyvs) = YYM.pure (YYNTfldid (yy1), yyvs); +private yyprod329 ((_, (YYNTfldid yy1)):yyvs) = do { let {!yyr = reduce329 yy1}; YYM.pure (YYNTfldids yyr, yyvs)}; private yyprod329 yyvals = yybadprod 329 yyvals; -private yyprod330 ((_, (YYNTstrictfldid yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce330 yy1 yy2}; YYM.pure (YYNTfldid yyr, yyvs)}; +private yyprod330 ((_, (YYNTfldids yy3)):(_, (YYTok yy2)):(_, (YYNTfldid yy1)):yyvs) = do { let {!yyr = reduce330 yy1 yy2 yy3}; YYM.pure (YYNTfldids yyr, yyvs)}; private yyprod330 yyvals = yybadprod 330 yyvals; -private yyprod331 ((_, (YYNTstrictfldid yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce331 yy1 yy2}; YYM.pure (YYNTfldid yyr, yyvs)}; +private yyprod331 ((_, (YYNTstrictfldid yy1)):yyvs) = YYM.pure (YYNTfldid (yy1), yyvs); private yyprod331 yyvals = yybadprod 331 yyvals; -private yyprod332 ((_, (YYNTplainfldid yy1)):yyvs) = YYM.pure (YYNTstrictfldid (yy1), yyvs); +private yyprod332 ((_, (YYNTstrictfldid yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce332 yy1 yy2}; YYM.pure (YYNTfldid yyr, yyvs)}; private yyprod332 yyvals = yybadprod 332 yyvals; -private yyprod333 ((_, (YYNTplainfldid yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce333 yy1 yy2}; YYM.pure (YYNTstrictfldid yyr, yyvs)}; +private yyprod333 ((_, (YYNTstrictfldid yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce333 yy1 yy2}; YYM.pure (YYNTfldid yyr, yyvs)}; private yyprod333 yyvals = yybadprod 333 yyvals; -private yyprod334 ((_, (YYNTplainfldid yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce334 yy1 yy2}; YYM.pure (YYNTstrictfldid yyr, yyvs)}; +private yyprod334 ((_, (YYNTplainfldid yy1)):yyvs) = YYM.pure (YYNTstrictfldid (yy1), yyvs); private yyprod334 yyvals = yybadprod 334 yyvals; -private yyprod335 ((_, (YYNTvarid yy1)):yyvs) = do { let {!yyr = reduce335 yy1}; YYM.pure (YYNTplainfldid yyr, yyvs)}; +private yyprod335 ((_, (YYNTplainfldid yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce335 yy1 yy2}; YYM.pure (YYNTstrictfldid yyr, yyvs)}; private yyprod335 yyvals = yybadprod 335 yyvals; -private yyprod336 ((_, (YYNTsigma yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce336 yy1 yy2 yy3 yy4}; YYM.pure (YYNTtypedef yyr, yyvs)}; +private yyprod336 ((_, (YYNTplainfldid yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce336 yy1 yy2}; YYM.pure (YYNTstrictfldid yyr, yyvs)}; private yyprod336 yyvals = yybadprod 336 yyvals; -private yyprod337 ((_, (YYNTsigma yy5)):(_, (YYTok yy4)):(_, (YYNTdvars yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce337 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTtypedef yyr, yyvs)}; +private yyprod337 ((_, (YYNTvarid yy1)):yyvs) = do { let {!yyr = reduce337 yy1}; YYM.pure (YYNTplainfldid yyr, yyvs)}; private yyprod337 yyvals = yybadprod 337 yyvals; -private yyprod338 yyvs = do { let {!yyr = reduce338 }; YYM.pure (YYNTwheredef yyr, yyvs)}; -private yyprod339 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce339 yy1 yy2 yy3}; YYM.pure (YYNTwheredef yyr, yyvs)}; +private yyprod338 ((_, (YYNTsigma yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce338 yy1 yy2 yy3 yy4}; YYM.pure (YYNTtypedef yyr, yyvs)}; +private yyprod338 yyvals = yybadprod 338 yyvals; +private yyprod339 ((_, (YYNTsigma yy5)):(_, (YYTok yy4)):(_, (YYNTdvars yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce339 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTtypedef yyr, yyvs)}; private yyprod339 yyvals = yybadprod 339 yyvals; -private yyprod340 ((_, (YYTok yy4)):(_, (YYNTlocaldefs yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce340 yy1 yy2 yy3 yy4}; YYM.pure (YYNTwheredef yyr, yyvs)}; -private yyprod340 yyvals = yybadprod 340 yyvals; -private yyprod341 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce341 yy1 yy2 yy3}; YYM.pure (YYNTwherelet yyr, yyvs)}; +private yyprod340 yyvs = do { let {!yyr = reduce340 }; YYM.pure (YYNTwheredef yyr, yyvs)}; +private yyprod341 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce341 yy1 yy2 yy3}; YYM.pure (YYNTwheredef yyr, yyvs)}; private yyprod341 yyvals = yybadprod 341 yyvals; -private yyprod342 ((_, (YYTok yy4)):(_, (YYNTletdefs yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce342 yy1 yy2 yy3 yy4}; YYM.pure (YYNTwherelet yyr, yyvs)}; +private yyprod342 ((_, (YYTok yy4)):(_, (YYNTlocaldefs yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce342 yy1 yy2 yy3 yy4}; YYM.pure (YYNTwheredef yyr, yyvs)}; private yyprod342 yyvals = yybadprod 342 yyvals; -private yyprod343 ((_, (YYNTexpr yy3)):(_, (YYTok yy2)):(_, (YYNTfunhead yy1)):yyvs) = do { let {!yyr = reduce343 yy1 yy2 yy3}; YYM.pure (YYNTfundef yyr, yyvs)}; +private yyprod343 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce343 yy1 yy2 yy3}; YYM.pure (YYNTwherelet yyr, yyvs)}; private yyprod343 yyvals = yybadprod 343 yyvals; -private yyprod344 ((_, (YYNTguards yy2)):(_, (YYNTfunhead yy1)):yyvs) = do { let {!yyr = reduce344 yy1 yy2}; YYM.pure (YYNTfundef yyr, yyvs)}; +private yyprod344 ((_, (YYTok yy4)):(_, (YYNTletdefs yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce344 yy1 yy2 yy3 yy4}; YYM.pure (YYNTwherelet yyr, yyvs)}; private yyprod344 yyvals = yybadprod 344 yyvals; -private yyprod345 ((_, (YYNTwherelet yy2)):(_, (YYNTfundef yy1)):yyvs) = do { yyr <- reduce345 yy1 yy2 ;YYM.pure (YYNTfundef yyr, yyvs)}; +private yyprod345 ((_, (YYNTexpr yy3)):(_, (YYTok yy2)):(_, (YYNTfunhead yy1)):yyvs) = do { let {!yyr = reduce345 yy1 yy2 yy3}; YYM.pure (YYNTfundef yyr, yyvs)}; private yyprod345 yyvals = yybadprod 345 yyvals; -private yyprod346 ((_, (YYNTbinex yy1)):yyvs) = do { yyr <- reduce346 yy1 ;YYM.pure (YYNTfunhead yyr, yyvs)}; +private yyprod346 ((_, (YYNTguards yy2)):(_, (YYNTfunhead yy1)):yyvs) = do { let {!yyr = reduce346 yy1 yy2}; YYM.pure (YYNTfundef yyr, yyvs)}; private yyprod346 yyvals = yybadprod 346 yyvals; -private yyprod347 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce347 yy1}; YYM.pure (YYNTliteral yyr, yyvs)}; +private yyprod347 ((_, (YYNTwherelet yy2)):(_, (YYNTfundef yy1)):yyvs) = do { yyr <- reduce347 yy1 yy2 ;YYM.pure (YYNTfundef yyr, yyvs)}; private yyprod347 yyvals = yybadprod 347 yyvals; -private yyprod348 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce348 yy1}; YYM.pure (YYNTliteral yyr, yyvs)}; +private yyprod348 ((_, (YYNTbinex yy1)):yyvs) = do { yyr <- reduce348 yy1 ;YYM.pure (YYNTfunhead yyr, yyvs)}; private yyprod348 yyvals = yybadprod 348 yyvals; -private yyprod349 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce349 yy1 ;YYM.pure (YYNTliteral yyr, yyvs)}; +private yyprod349 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce349 yy1}; YYM.pure (YYNTliteral yyr, yyvs)}; private yyprod349 yyvals = yybadprod 349 yyvals; private yyprod350 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce350 yy1}; YYM.pure (YYNTliteral yyr, yyvs)}; private yyprod350 yyvals = yybadprod 350 yyvals; private yyprod351 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce351 yy1 ;YYM.pure (YYNTliteral yyr, yyvs)}; private yyprod351 yyvals = yybadprod 351 yyvals; -private yyprod352 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce352 yy1 ;YYM.pure (YYNTliteral yyr, yyvs)}; +private yyprod352 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce352 yy1}; YYM.pure (YYNTliteral yyr, yyvs)}; private yyprod352 yyvals = yybadprod 352 yyvals; private yyprod353 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce353 yy1 ;YYM.pure (YYNTliteral yyr, yyvs)}; private yyprod353 yyvals = yybadprod 353 yyvals; -private yyprod354 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce354 yy1}; YYM.pure (YYNTliteral yyr, yyvs)}; +private yyprod354 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce354 yy1 ;YYM.pure (YYNTliteral yyr, yyvs)}; private yyprod354 yyvals = yybadprod 354 yyvals; -private yyprod355 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce355 yy1}; YYM.pure (YYNTliteral yyr, yyvs)}; +private yyprod355 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce355 yy1 ;YYM.pure (YYNTliteral yyr, yyvs)}; private yyprod355 yyvals = yybadprod 355 yyvals; -private yyprod356 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce356 yy1 ;YYM.pure (YYNTliteral yyr, yyvs)}; +private yyprod356 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce356 yy1}; YYM.pure (YYNTliteral yyr, yyvs)}; private yyprod356 yyvals = yybadprod 356 yyvals; -private yyprod357 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce357 yy1 ;YYM.pure (YYNTliteral yyr, yyvs)}; +private yyprod357 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce357 yy1}; YYM.pure (YYNTliteral yyr, yyvs)}; private yyprod357 yyvals = yybadprod 357 yyvals; -private yyprod358 ((_, (YYNTexpr yy1)):yyvs) = YYM.pure (YYNTpattern (yy1), yyvs); +private yyprod358 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce358 yy1 ;YYM.pure (YYNTliteral yyr, yyvs)}; private yyprod358 yyvals = yybadprod 358 yyvals; -private yyprod359 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTaeq (yy1), yyvs); +private yyprod359 ((_, (YYTok yy1)):yyvs) = do { yyr <- reduce359 yy1 ;YYM.pure (YYNTliteral yyr, yyvs)}; private yyprod359 yyvals = yybadprod 359 yyvals; -private yyprod360 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTaeq (yy1), yyvs); +private yyprod360 ((_, (YYNTexpr yy1)):yyvs) = YYM.pure (YYNTpattern (yy1), yyvs); private yyprod360 yyvals = yybadprod 360 yyvals; -private yyprod361 ((_, (YYNTgqual yy1)):yyvs) = YYM.pure (YYNTlcqual (yy1), yyvs); +private yyprod361 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTaeq (yy1), yyvs); private yyprod361 yyvals = yybadprod 361 yyvals; -private yyprod362 ((_, (YYNTexpr yy3)):(_, (YYTok yy2)):(_, (YYNTexpr yy1)):yyvs) = do { yyr <- reduce362 yy1 yy2 yy3 ;YYM.pure (YYNTlcqual yyr, yyvs)}; +private yyprod362 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTaeq (yy1), yyvs); private yyprod362 yyvals = yybadprod 362 yyvals; -private yyprod363 ((_, (YYTok yy4)):(_, (YYNTletdefs yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce363 yy1 yy2 yy3 yy4}; YYM.pure (YYNTlcqual yyr, yyvs)}; +private yyprod363 ((_, (YYNTgqual yy1)):yyvs) = YYM.pure (YYNTlcqual (yy1), yyvs); private yyprod363 yyvals = yybadprod 363 yyvals; -private yyprod364 ((_, (YYNTlcqual yy1)):yyvs) = do { let {!yyr = reduce364 yy1}; YYM.pure (YYNTlcquals yyr, yyvs)}; +private yyprod364 ((_, (YYNTexpr yy3)):(_, (YYTok yy2)):(_, (YYNTexpr yy1)):yyvs) = do { yyr <- reduce364 yy1 yy2 yy3 ;YYM.pure (YYNTlcqual yyr, yyvs)}; private yyprod364 yyvals = yybadprod 364 yyvals; -private yyprod365 ((_, (YYNTlcquals yy3)):(_, (YYTok yy2)):(_, (YYNTlcqual yy1)):yyvs) = do { let {!yyr = reduce365 yy1 yy2 yy3}; YYM.pure (YYNTlcquals yyr, yyvs)}; +private yyprod365 ((_, (YYTok yy4)):(_, (YYNTletdefs yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce365 yy1 yy2 yy3 yy4}; YYM.pure (YYNTlcqual yyr, yyvs)}; private yyprod365 yyvals = yybadprod 365 yyvals; -private yyprod366 ((_, (YYTok yy2)):(_, (YYNTlcqual yy1)):yyvs) = do { let {!yyr = reduce366 yy1 yy2}; YYM.pure (YYNTlcquals yyr, yyvs)}; +private yyprod366 ((_, (YYNTlcqual yy1)):yyvs) = do { let {!yyr = reduce366 yy1}; YYM.pure (YYNTlcquals yyr, yyvs)}; private yyprod366 yyvals = yybadprod 366 yyvals; -private yyprod367 ((_, (YYNTlcqual yy1)):yyvs) = do { let {!yyr = reduce367 yy1}; YYM.pure (YYNTdodefs yyr, yyvs)}; +private yyprod367 ((_, (YYNTlcquals yy3)):(_, (YYTok yy2)):(_, (YYNTlcqual yy1)):yyvs) = do { let {!yyr = reduce367 yy1 yy2 yy3}; YYM.pure (YYNTlcquals yyr, yyvs)}; private yyprod367 yyvals = yybadprod 367 yyvals; -private yyprod368 ((_, (YYTok yy2)):(_, (YYNTlcqual yy1)):yyvs) = do { let {!yyr = reduce368 yy1 yy2}; YYM.pure (YYNTdodefs yyr, yyvs)}; +private yyprod368 ((_, (YYTok yy2)):(_, (YYNTlcqual yy1)):yyvs) = do { let {!yyr = reduce368 yy1 yy2}; YYM.pure (YYNTlcquals yyr, yyvs)}; private yyprod368 yyvals = yybadprod 368 yyvals; -private yyprod369 ((_, (YYNTdodefs yy3)):(_, (YYTok yy2)):(_, (YYNTlcqual yy1)):yyvs) = do { let {!yyr = reduce369 yy1 yy2 yy3}; YYM.pure (YYNTdodefs yyr, yyvs)}; +private yyprod369 ((_, (YYNTlcqual yy1)):yyvs) = do { let {!yyr = reduce369 yy1}; YYM.pure (YYNTdodefs yyr, yyvs)}; private yyprod369 yyvals = yybadprod 369 yyvals; -private yyprod370 ((_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce370 yy1}; YYM.pure (YYNTgqual yyr, yyvs)}; +private yyprod370 ((_, (YYTok yy2)):(_, (YYNTlcqual yy1)):yyvs) = do { let {!yyr = reduce370 yy1 yy2}; YYM.pure (YYNTdodefs yyr, yyvs)}; private yyprod370 yyvals = yybadprod 370 yyvals; -private yyprod371 ((_, (YYNTexpr yy3)):(_, (YYTok yy2)):(_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce371 yy1 yy2 yy3}; YYM.pure (YYNTgqual yyr, yyvs)}; +private yyprod371 ((_, (YYNTdodefs yy3)):(_, (YYTok yy2)):(_, (YYNTlcqual yy1)):yyvs) = do { let {!yyr = reduce371 yy1 yy2 yy3}; YYM.pure (YYNTdodefs yyr, yyvs)}; private yyprod371 yyvals = yybadprod 371 yyvals; -private yyprod372 ((_, (YYNTgqual yy1)):yyvs) = do { let {!yyr = reduce372 yy1}; YYM.pure (YYNTgquals yyr, yyvs)}; +private yyprod372 ((_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce372 yy1}; YYM.pure (YYNTgqual yyr, yyvs)}; private yyprod372 yyvals = yybadprod 372 yyvals; -private yyprod373 ((_, (YYNTgquals yy3)):(_, (YYTok yy2)):(_, (YYNTgqual yy1)):yyvs) = do { let {!yyr = reduce373 yy1 yy2 yy3}; YYM.pure (YYNTgquals yyr, yyvs)}; +private yyprod373 ((_, (YYNTexpr yy3)):(_, (YYTok yy2)):(_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce373 yy1 yy2 yy3}; YYM.pure (YYNTgqual yyr, yyvs)}; private yyprod373 yyvals = yybadprod 373 yyvals; -private yyprod374 ((_, (YYTok yy2)):(_, (YYNTgqual yy1)):yyvs) = do { let {!yyr = reduce374 yy1 yy2}; YYM.pure (YYNTgquals yyr, yyvs)}; +private yyprod374 ((_, (YYNTgqual yy1)):yyvs) = do { let {!yyr = reduce374 yy1}; YYM.pure (YYNTgquals yyr, yyvs)}; private yyprod374 yyvals = yybadprod 374 yyvals; -private yyprod375 ((_, (YYNTexpr yy4)):(_, (YYNTaeq yy3)):(_, (YYNTgquals yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce375 yy1 yy2 yy3 yy4}; YYM.pure (YYNTguard yyr, yyvs)}; +private yyprod375 ((_, (YYNTgquals yy3)):(_, (YYTok yy2)):(_, (YYNTgqual yy1)):yyvs) = do { let {!yyr = reduce375 yy1 yy2 yy3}; YYM.pure (YYNTgquals yyr, yyvs)}; private yyprod375 yyvals = yybadprod 375 yyvals; -private yyprod376 ((_, (YYNTguard yy1)):yyvs) = do { let {!yyr = reduce376 yy1}; YYM.pure (YYNTguards yyr, yyvs)}; +private yyprod376 ((_, (YYTok yy2)):(_, (YYNTgqual yy1)):yyvs) = do { let {!yyr = reduce376 yy1 yy2}; YYM.pure (YYNTgquals yyr, yyvs)}; private yyprod376 yyvals = yybadprod 376 yyvals; -private yyprod377 ((_, (YYNTguards yy2)):(_, (YYNTguard yy1)):yyvs) = do { let {!yyr = reduce377 yy1 yy2}; YYM.pure (YYNTguards yyr, yyvs)}; +private yyprod377 ((_, (YYNTexpr yy4)):(_, (YYNTaeq yy3)):(_, (YYNTgquals yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce377 yy1 yy2 yy3 yy4}; YYM.pure (YYNTguard yyr, yyvs)}; private yyprod377 yyvals = yybadprod 377 yyvals; -private yyprod378 ((_, (YYNTexpr yy3)):(_, (YYNTaeq yy2)):(_, (YYNTpattern yy1)):yyvs) = do { let {!yyr = reduce378 yy1 yy2 yy3}; YYM.pure (YYNTcalt yyr, yyvs)}; +private yyprod378 ((_, (YYNTguard yy1)):yyvs) = do { let {!yyr = reduce378 yy1}; YYM.pure (YYNTguards yyr, yyvs)}; private yyprod378 yyvals = yybadprod 378 yyvals; -private yyprod379 ((_, (YYNTguards yy2)):(_, (YYNTpattern yy1)):yyvs) = do { let {!yyr = reduce379 yy1 yy2}; YYM.pure (YYNTcalt yyr, yyvs)}; +private yyprod379 ((_, (YYNTguards yy2)):(_, (YYNTguard yy1)):yyvs) = do { let {!yyr = reduce379 yy1 yy2}; YYM.pure (YYNTguards yyr, yyvs)}; private yyprod379 yyvals = yybadprod 379 yyvals; -private yyprod380 ((_, (YYNTwherelet yy2)):(_, (YYNTcalt yy1)):yyvs) = do { let {!yyr = reduce380 yy1 yy2}; YYM.pure (YYNTcalt yyr, yyvs)}; +private yyprod380 ((_, (YYNTexpr yy3)):(_, (YYNTaeq yy2)):(_, (YYNTpattern yy1)):yyvs) = do { let {!yyr = reduce380 yy1 yy2 yy3}; YYM.pure (YYNTcalt yyr, yyvs)}; private yyprod380 yyvals = yybadprod 380 yyvals; -private yyprod381 ((_, (YYNTcalt yy1)):yyvs) = do { let {!yyr = reduce381 yy1}; YYM.pure (YYNTcalts yyr, yyvs)}; +private yyprod381 ((_, (YYNTguards yy2)):(_, (YYNTpattern yy1)):yyvs) = do { let {!yyr = reduce381 yy1 yy2}; YYM.pure (YYNTcalt yyr, yyvs)}; private yyprod381 yyvals = yybadprod 381 yyvals; -private yyprod382 ((_, (YYNTcalts yy3)):(_, (YYTok yy2)):(_, (YYNTcalt yy1)):yyvs) = do { let {!yyr = reduce382 yy1 yy2 yy3}; YYM.pure (YYNTcalts yyr, yyvs)}; +private yyprod382 ((_, (YYNTwherelet yy2)):(_, (YYNTcalt yy1)):yyvs) = do { let {!yyr = reduce382 yy1 yy2}; YYM.pure (YYNTcalt yyr, yyvs)}; private yyprod382 yyvals = yybadprod 382 yyvals; -private yyprod383 ((_, (YYTok yy2)):(_, (YYNTcalt yy1)):yyvs) = do { let {!yyr = reduce383 yy1 yy2}; YYM.pure (YYNTcalts yyr, yyvs)}; +private yyprod383 ((_, (YYNTcalt yy1)):yyvs) = do { let {!yyr = reduce383 yy1}; YYM.pure (YYNTcalts yyr, yyvs)}; private yyprod383 yyvals = yybadprod 383 yyvals; -private yyprod384 ((_, (YYNTlambdabody yy3)):(_, (YYNTapats yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce384 yy1 yy2 yy3}; YYM.pure (YYNTlambda yyr, yyvs)}; +private yyprod384 ((_, (YYNTcalts yy3)):(_, (YYTok yy2)):(_, (YYNTcalt yy1)):yyvs) = do { let {!yyr = reduce384 yy1 yy2 yy3}; YYM.pure (YYNTcalts yyr, yyvs)}; private yyprod384 yyvals = yybadprod 384 yyvals; -private yyprod385 ((_, (YYNTlambda yy1)):yyvs) = YYM.pure (YYNTlambdabody (yy1), yyvs); +private yyprod385 ((_, (YYTok yy2)):(_, (YYNTcalt yy1)):yyvs) = do { let {!yyr = reduce385 yy1 yy2}; YYM.pure (YYNTcalts yyr, yyvs)}; private yyprod385 yyvals = yybadprod 385 yyvals; -private yyprod386 ((_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce386 yy1 yy2}; YYM.pure (YYNTlambdabody yyr, yyvs)}; +private yyprod386 ((_, (YYNTlambdabody yy3)):(_, (YYNTapats yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce386 yy1 yy2 yy3}; YYM.pure (YYNTlambda yyr, yyvs)}; private yyprod386 yyvals = yybadprod 386 yyvals; -private yyprod387 ((_, (YYNTsigma yy3)):(_, (YYTok yy2)):(_, (YYNTbinex yy1)):yyvs) = do { let {!yyr = reduce387 yy1 yy2 yy3}; YYM.pure (YYNTexpr yyr, yyvs)}; +private yyprod387 ((_, (YYNTlambda yy1)):yyvs) = YYM.pure (YYNTlambdabody (yy1), yyvs); private yyprod387 yyvals = yybadprod 387 yyvals; -private yyprod388 ((_, (YYNTbinex yy1)):yyvs) = YYM.pure (YYNTexpr (yy1), yyvs); +private yyprod388 ((_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce388 yy1 yy2}; YYM.pure (YYNTlambdabody yyr, yyvs)}; private yyprod388 yyvals = yybadprod 388 yyvals; -private yyprod389 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce389 yy1 yy2}; YYM.pure (YYNTthenx yyr, yyvs)}; +private yyprod389 ((_, (YYNTsigma yy3)):(_, (YYTok yy2)):(_, (YYNTbinex yy1)):yyvs) = do { let {!yyr = reduce389 yy1 yy2 yy3}; YYM.pure (YYNTexpr yyr, yyvs)}; private yyprod389 yyvals = yybadprod 389 yyvals; -private yyprod390 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTthenx (yy1), yyvs); +private yyprod390 ((_, (YYNTbinex yy1)):yyvs) = YYM.pure (YYNTexpr (yy1), yyvs); private yyprod390 yyvals = yybadprod 390 yyvals; -private yyprod391 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce391 yy1 yy2}; YYM.pure (YYNTelsex yyr, yyvs)}; +private yyprod391 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce391 yy1 yy2}; YYM.pure (YYNTthenx yyr, yyvs)}; private yyprod391 yyvals = yybadprod 391 yyvals; -private yyprod392 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTelsex (yy1), yyvs); +private yyprod392 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTthenx (yy1), yyvs); private yyprod392 yyvals = yybadprod 392 yyvals; -private yyprod393 ((_, (YYNTbinex yy3)):(_, (YYTok yy2)):(_, (YYNTbinex yy1)):yyvs) = do { let {!yyr = reduce393 yy1 yy2 yy3}; YYM.pure (YYNTbinex yyr, yyvs)}; -private yyprod393 ((_, (YYNTbinex yy1)):yyvs) = YYM.pure (YYNTbinex (yy1), yyvs); +private yyprod393 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce393 yy1 yy2}; YYM.pure (YYNTelsex yyr, yyvs)}; private yyprod393 yyvals = yybadprod 393 yyvals; -private yyprod394 ((_, (YYNTbinex yy3)):(_, (YYTok yy2)):(_, (YYNTbinex yy1)):yyvs) = do { let {!yyr = reduce394 yy1 yy2 yy3}; YYM.pure (YYNTbinex yyr, yyvs)}; -private yyprod394 ((_, (YYNTbinex yy1)):yyvs) = YYM.pure (YYNTbinex (yy1), yyvs); +private yyprod394 ((_, (YYTok yy1)):yyvs) = YYM.pure (YYNTelsex (yy1), yyvs); private yyprod394 yyvals = yybadprod 394 yyvals; -private yyprod395 ((_, (YYNTtopex yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce395 yy1 yy2}; YYM.pure (YYNTbinex yyr, yyvs)}; +private yyprod395 ((_, (YYNTbinex yy3)):(_, (YYTok yy2)):(_, (YYNTbinex yy1)):yyvs) = do { let {!yyr = reduce395 yy1 yy2 yy3}; YYM.pure (YYNTbinex yyr, yyvs)}; +private yyprod395 ((_, (YYNTbinex yy1)):yyvs) = YYM.pure (YYNTbinex (yy1), yyvs); private yyprod395 yyvals = yybadprod 395 yyvals; -private yyprod396 ((_, (YYNTtopex yy1)):yyvs) = YYM.pure (YYNTbinex (yy1), yyvs); +private yyprod396 ((_, (YYNTbinex yy3)):(_, (YYTok yy2)):(_, (YYNTbinex yy1)):yyvs) = do { let {!yyr = reduce396 yy1 yy2 yy3}; YYM.pure (YYNTbinex yyr, yyvs)}; +private yyprod396 ((_, (YYNTbinex yy1)):yyvs) = YYM.pure (YYNTbinex (yy1), yyvs); private yyprod396 yyvals = yybadprod 396 yyvals; -private yyprod397 ((_, (YYNTexpr yy6)):(_, (YYNTelsex yy5)):(_, (YYNTexpr yy4)):(_, (YYNTthenx yy3)):(_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce397 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTtopex yyr, yyvs)}; +private yyprod397 ((_, (YYNTtopex yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce397 yy1 yy2}; YYM.pure (YYNTbinex yyr, yyvs)}; private yyprod397 yyvals = yybadprod 397 yyvals; -private yyprod398 ((_, (YYTok yy6)):(_, (YYNTcalts yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce398 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTtopex yyr, yyvs)}; +private yyprod398 ((_, (YYNTtopex yy1)):yyvs) = YYM.pure (YYNTbinex (yy1), yyvs); private yyprod398 yyvals = yybadprod 398 yyvals; -private yyprod399 ((_, (YYNTexpr yy6)):(_, (YYTok yy5)):(_, (YYTok yy4)):(_, (YYNTletdefs yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce399 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTtopex yyr, yyvs)}; +private yyprod399 ((_, (YYNTexpr yy6)):(_, (YYNTelsex yy5)):(_, (YYNTexpr yy4)):(_, (YYNTthenx yy3)):(_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce399 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTtopex yyr, yyvs)}; private yyprod399 yyvals = yybadprod 399 yyvals; -private yyprod400 ((_, (YYNTlambda yy1)):yyvs) = YYM.pure (YYNTtopex (yy1), yyvs); +private yyprod400 ((_, (YYTok yy6)):(_, (YYNTcalts yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce400 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTtopex yyr, yyvs)}; private yyprod400 yyvals = yybadprod 400 yyvals; -private yyprod401 ((_, (YYNTappex yy1)):yyvs) = do { let {!yyr = reduce401 yy1}; YYM.pure (YYNTtopex yyr, yyvs)}; +private yyprod401 ((_, (YYNTexpr yy6)):(_, (YYTok yy5)):(_, (YYTok yy4)):(_, (YYNTletdefs yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce401 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTtopex yyr, yyvs)}; private yyprod401 yyvals = yybadprod 401 yyvals; -private yyprod402 ((_, (YYNTunex yy1)):yyvs) = YYM.pure (YYNTappex (yy1), yyvs); +private yyprod402 ((_, (YYNTlambda yy1)):yyvs) = YYM.pure (YYNTtopex (yy1), yyvs); private yyprod402 yyvals = yybadprod 402 yyvals; -private yyprod403 ((_, (YYNTunex yy2)):(_, (YYNTappex yy1)):yyvs) = do { let {!yyr = reduce403 yy1 yy2}; YYM.pure (YYNTappex yyr, yyvs)}; +private yyprod403 ((_, (YYNTappex yy1)):yyvs) = do { let {!yyr = reduce403 yy1}; YYM.pure (YYNTtopex yyr, yyvs)}; private yyprod403 yyvals = yybadprod 403 yyvals; -private yyprod404 ((_, (YYNTprimary yy1)):yyvs) = YYM.pure (YYNTunex (yy1), yyvs); +private yyprod404 ((_, (YYNTunex yy1)):yyvs) = YYM.pure (YYNTappex (yy1), yyvs); private yyprod404 yyvals = yybadprod 404 yyvals; -private yyprod405 ((_, (YYNTunex yy2)):(_, (YYNTunop yy1)):yyvs) = do { let {!yyr = reduce405 yy1 yy2}; YYM.pure (YYNTunex yyr, yyvs)}; +private yyprod405 ((_, (YYNTunex yy2)):(_, (YYNTappex yy1)):yyvs) = do { let {!yyr = reduce405 yy1 yy2}; YYM.pure (YYNTappex yyr, yyvs)}; private yyprod405 yyvals = yybadprod 405 yyvals; -private yyprod406 ((_, (YYNTunex yy1)):yyvs) = do { let {!yyr = reduce406 yy1}; YYM.pure (YYNTapats yyr, yyvs)}; +private yyprod406 ((_, (YYNTprimary yy1)):yyvs) = YYM.pure (YYNTunex (yy1), yyvs); private yyprod406 yyvals = yybadprod 406 yyvals; -private yyprod407 ((_, (YYNTapats yy2)):(_, (YYNTunex yy1)):yyvs) = do { let {!yyr = reduce407 yy1 yy2}; YYM.pure (YYNTapats yyr, yyvs)}; +private yyprod407 ((_, (YYNTunex yy2)):(_, (YYNTunop yy1)):yyvs) = do { let {!yyr = reduce407 yy1 yy2}; YYM.pure (YYNTunex yyr, yyvs)}; private yyprod407 yyvals = yybadprod 407 yyvals; -private yyprod408 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce408 yy1}; YYM.pure (YYNTqualifiers yyr, yyvs)}; +private yyprod408 ((_, (YYNTunex yy1)):yyvs) = do { let {!yyr = reduce408 yy1}; YYM.pure (YYNTapats yyr, yyvs)}; private yyprod408 yyvals = yybadprod 408 yyvals; -private yyprod409 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce409 yy1 yy2}; YYM.pure (YYNTqualifiers yyr, yyvs)}; +private yyprod409 ((_, (YYNTapats yy2)):(_, (YYNTunex yy1)):yyvs) = do { let {!yyr = reduce409 yy1 yy2}; YYM.pure (YYNTapats yyr, yyvs)}; private yyprod409 yyvals = yybadprod 409 yyvals; -private yyprod410 ((_, (YYNTterm yy1)):yyvs) = YYM.pure (YYNTprimary (yy1), yyvs); +private yyprod410 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce410 yy1}; YYM.pure (YYNTqualifiers yyr, yyvs)}; private yyprod410 yyvals = yybadprod 410 yyvals; -private yyprod411 ((_, (YYTok yy4)):(_, (YYNTdodefs yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce411 yy1 yy2 yy3 yy4 ;YYM.pure (YYNTprimary yyr, yyvs)}; +private yyprod411 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce411 yy1 yy2}; YYM.pure (YYNTqualifiers yyr, yyvs)}; private yyprod411 yyvals = yybadprod 411 yyvals; -private yyprod412 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce412 yy1 yy2 yy3}; YYM.pure (YYNTprimary yyr, yyvs)}; +private yyprod412 ((_, (YYNTterm yy1)):yyvs) = YYM.pure (YYNTprimary (yy1), yyvs); private yyprod412 yyvals = yybadprod 412 yyvals; -private yyprod413 ((_, (YYNToperator yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { yyr <- reduce413 yy1 yy2 yy3 ;YYM.pure (YYNTprimary yyr, yyvs)}; +private yyprod413 ((_, (YYTok yy4)):(_, (YYNTdodefs yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce413 yy1 yy2 yy3 yy4 ;YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod413 yyvals = yybadprod 413 yyvals; -private yyprod414 ((_, (YYNTunop yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce414 yy1 yy2 yy3}; YYM.pure (YYNTprimary yyr, yyvs)}; +private yyprod414 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce414 yy1 yy2 yy3}; YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod414 yyvals = yybadprod 414 yyvals; -private yyprod415 ((_, (YYTok yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTqualifiers yy1)):yyvs) = do { let {!yyr = reduce415 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTprimary yyr, yyvs)}; +private yyprod415 ((_, (YYNToperator yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { yyr <- reduce415 yy1 yy2 yy3 ;YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod415 yyvals = yybadprod 415 yyvals; -private yyprod416 ((_, (YYTok yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTqualifiers yy1)):yyvs) = do { let {!yyr = reduce416 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTprimary yyr, yyvs)}; +private yyprod416 ((_, (YYNTunop yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce416 yy1 yy2 yy3}; YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod416 yyvals = yybadprod 416 yyvals; private yyprod417 ((_, (YYTok yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTqualifiers yy1)):yyvs) = do { let {!yyr = reduce417 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod417 yyvals = yybadprod 417 yyvals; -private yyprod418 ((_, (YYTok yy4)):(_, (YYNTgetfields yy3)):(_, (YYTok yy2)):(_, (YYNTqualifiers yy1)):yyvs) = do { let {!yyr = reduce418 yy1 yy2 yy3 yy4}; YYM.pure (YYNTprimary yyr, yyvs)}; +private yyprod418 ((_, (YYTok yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTqualifiers yy1)):yyvs) = do { let {!yyr = reduce418 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod418 yyvals = yybadprod 418 yyvals; -private yyprod419 ((_, (YYTok yy6)):(_, (YYTok yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce419 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTprimary yyr, yyvs)}; +private yyprod419 ((_, (YYTok yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTqualifiers yy1)):yyvs) = do { let {!yyr = reduce419 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod419 yyvals = yybadprod 419 yyvals; -private yyprod420 ((_, (YYTok yy6)):(_, (YYTok yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce420 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTprimary yyr, yyvs)}; +private yyprod420 ((_, (YYTok yy4)):(_, (YYNTgetfields yy3)):(_, (YYTok yy2)):(_, (YYNTqualifiers yy1)):yyvs) = do { let {!yyr = reduce420 yy1 yy2 yy3 yy4}; YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod420 yyvals = yybadprod 420 yyvals; private yyprod421 ((_, (YYTok yy6)):(_, (YYTok yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce421 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod421 yyvals = yybadprod 421 yyvals; -private yyprod422 ((_, (YYTok yy5)):(_, (YYNTgetfields yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce422 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTprimary yyr, yyvs)}; +private yyprod422 ((_, (YYTok yy6)):(_, (YYTok yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce422 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod422 yyvals = yybadprod 422 yyvals; -private yyprod423 ((_, (YYTok yy5)):(_, (YYNTexpr yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce423 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTprimary yyr, yyvs)}; +private yyprod423 ((_, (YYTok yy6)):(_, (YYTok yy5)):(_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce423 yy1 yy2 yy3 yy4 yy5 yy6}; YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod423 yyvals = yybadprod 423 yyvals; -private yyprod424 ((_, (YYNTqvarid yy1)):yyvs) = do { let {!yyr = reduce424 yy1}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod424 ((_, (YYTok yy5)):(_, (YYNTgetfields yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce424 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod424 yyvals = yybadprod 424 yyvals; -private yyprod425 ((_, (YYNTliteral yy1)):yyvs) = YYM.pure (YYNTterm (yy1), yyvs); +private yyprod425 ((_, (YYTok yy5)):(_, (YYNTexpr yy4)):(_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTprimary yy1)):yyvs) = do { let {!yyr = reduce425 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTprimary yyr, yyvs)}; private yyprod425 yyvals = yybadprod 425 yyvals; -private yyprod426 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce426 yy1}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod426 ((_, (YYNTqvarid yy1)):yyvs) = do { let {!yyr = reduce426 yy1}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod426 yyvals = yybadprod 426 yyvals; -private yyprod427 ((_, (YYNTqconid yy1)):yyvs) = do { let {!yyr = reduce427 yy1}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod427 ((_, (YYNTliteral yy1)):yyvs) = YYM.pure (YYNTterm (yy1), yyvs); private yyprod427 yyvals = yybadprod 427 yyvals; -private yyprod428 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTqconid yy1)):yyvs) = do { let {!yyr = reduce428 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod428 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce428 yy1}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod428 yyvals = yybadprod 428 yyvals; -private yyprod429 ((_, (YYTok yy4)):(_, (YYNTfields yy3)):(_, (YYTok yy2)):(_, (YYNTqconid yy1)):yyvs) = do { let {!yyr = reduce429 yy1 yy2 yy3 yy4}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod429 ((_, (YYNTqconid yy1)):yyvs) = do { let {!yyr = reduce429 yy1}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod429 yyvals = yybadprod 429 yyvals; -private yyprod430 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce430 yy1 yy2}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod430 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYNTqconid yy1)):yyvs) = do { let {!yyr = reduce430 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod430 yyvals = yybadprod 430 yyvals; -private yyprod431 ((_, (YYTok yy3)):(_, (YYNTcommata yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce431 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod431 ((_, (YYTok yy4)):(_, (YYNTfields yy3)):(_, (YYTok yy2)):(_, (YYNTqconid yy1)):yyvs) = do { let {!yyr = reduce431 yy1 yy2 yy3 yy4}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod431 yyvals = yybadprod 431 yyvals; -private yyprod432 ((_, (YYTok yy3)):(_, (YYNTunop yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce432 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod432 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce432 yy1 yy2}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod432 yyvals = yybadprod 432 yyvals; -private yyprod433 ((_, (YYTok yy3)):(_, (YYNToperator yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce433 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod433 ((_, (YYTok yy3)):(_, (YYNTcommata yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce433 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod433 yyvals = yybadprod 433 yyvals; -private yyprod434 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce434 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod434 ((_, (YYTok yy3)):(_, (YYNTunop yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce434 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod434 yyvals = yybadprod 434 yyvals; -private yyprod435 ((_, (YYTok yy4)):(_, (YYNTexpr yy3)):(_, (YYNToperator yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce435 yy1 yy2 yy3 yy4}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod435 ((_, (YYTok yy3)):(_, (YYNToperator yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce435 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod435 yyvals = yybadprod 435 yyvals; -private yyprod436 ((_, (YYTok yy4)):(_, (YYNToperator yy3)):(_, (YYNTbinex yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce436 yy1 yy2 yy3 yy4}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod436 ((_, (YYTok yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce436 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod436 yyvals = yybadprod 436 yyvals; -private yyprod437 ((_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYNTbinex yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce437 yy1 yy2 yy3 yy4}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod437 ((_, (YYTok yy4)):(_, (YYNTexpr yy3)):(_, (YYNToperator yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce437 yy1 yy2 yy3 yy4}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod437 yyvals = yybadprod 437 yyvals; -private yyprod438 ((_, (YYTok yy5)):(_, (YYNTexprSC yy4)):(_, (YYTok yy3)):(_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce438 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod438 ((_, (YYTok yy4)):(_, (YYNToperator yy3)):(_, (YYNTbinex yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce438 yy1 yy2 yy3 yy4}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod438 yyvals = yybadprod 438 yyvals; -private yyprod439 ((_, (YYTok yy5)):(_, (YYNTexprSS yy4)):(_, (YYTok yy3)):(_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce439 yy1 yy2 yy3 yy4 yy5 ;YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod439 ((_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYNTbinex yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce439 yy1 yy2 yy3 yy4}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod439 yyvals = yybadprod 439 yyvals; -private yyprod440 ((_, (YYTok yy3)):(_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce440 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod440 ((_, (YYTok yy5)):(_, (YYNTexprSC yy4)):(_, (YYTok yy3)):(_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce440 yy1 yy2 yy3 yy4 yy5}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod440 yyvals = yybadprod 440 yyvals; -private yyprod441 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce441 yy1 yy2}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod441 ((_, (YYTok yy5)):(_, (YYNTexprSS yy4)):(_, (YYTok yy3)):(_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce441 yy1 yy2 yy3 yy4 yy5 ;YYM.pure (YYNTterm yyr, yyvs)}; private yyprod441 yyvals = yybadprod 441 yyvals; -private yyprod442 ((_, (YYTok yy3)):(_, (YYNTexprSC yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce442 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod442 ((_, (YYTok yy3)):(_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce442 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod442 yyvals = yybadprod 442 yyvals; -private yyprod443 ((_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYNTexprSC yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce443 yy1 yy2 yy3 yy4 ;YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod443 ((_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce443 yy1 yy2}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod443 yyvals = yybadprod 443 yyvals; -private yyprod444 ((_, (YYTok yy5)):(_, (YYNTexpr yy4)):(_, (YYTok yy3)):(_, (YYNTexprSC yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce444 yy1 yy2 yy3 yy4 yy5 ;YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod444 ((_, (YYTok yy3)):(_, (YYNTexprSC yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce444 yy1 yy2 yy3}; YYM.pure (YYNTterm yyr, yyvs)}; private yyprod444 yyvals = yybadprod 444 yyvals; -private yyprod445 ((_, (YYTok yy5)):(_, (YYNTlcquals yy4)):(_, (YYTok yy3)):(_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce445 yy1 yy2 yy3 yy4 yy5 ;YYM.pure (YYNTterm yyr, yyvs)}; +private yyprod445 ((_, (YYTok yy4)):(_, (YYTok yy3)):(_, (YYNTexprSC yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce445 yy1 yy2 yy3 yy4 ;YYM.pure (YYNTterm yyr, yyvs)}; private yyprod445 yyvals = yybadprod 445 yyvals; -private yyprod446 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce446 yy1}; YYM.pure (YYNTcommata yyr, yyvs)}; +private yyprod446 ((_, (YYTok yy5)):(_, (YYNTexpr yy4)):(_, (YYTok yy3)):(_, (YYNTexprSC yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce446 yy1 yy2 yy3 yy4 yy5 ;YYM.pure (YYNTterm yyr, yyvs)}; private yyprod446 yyvals = yybadprod 446 yyvals; -private yyprod447 ((_, (YYNTcommata yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce447 yy1 yy2}; YYM.pure (YYNTcommata yyr, yyvs)}; +private yyprod447 ((_, (YYTok yy5)):(_, (YYNTlcquals yy4)):(_, (YYTok yy3)):(_, (YYNTexpr yy2)):(_, (YYTok yy1)):yyvs) = do { yyr <- reduce447 yy1 yy2 yy3 yy4 yy5 ;YYM.pure (YYNTterm yyr, yyvs)}; private yyprod447 yyvals = yybadprod 447 yyvals; -private yyprod448 ((_, (YYNTfield yy1)):yyvs) = do { let {!yyr = reduce448 yy1}; YYM.pure (YYNTfields yyr, yyvs)}; +private yyprod448 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce448 yy1}; YYM.pure (YYNTcommata yyr, yyvs)}; private yyprod448 yyvals = yybadprod 448 yyvals; -private yyprod449 ((_, (YYNTfields yy3)):(_, (YYTok yy2)):(_, (YYNTfield yy1)):yyvs) = do { yyr <- reduce449 yy1 yy2 yy3 ;YYM.pure (YYNTfields yyr, yyvs)}; +private yyprod449 ((_, (YYNTcommata yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce449 yy1 yy2}; YYM.pure (YYNTcommata yyr, yyvs)}; private yyprod449 yyvals = yybadprod 449 yyvals; -private yyprod450 ((_, (YYTok yy2)):(_, (YYNTfield yy1)):yyvs) = do { let {!yyr = reduce450 yy1 yy2}; YYM.pure (YYNTfields yyr, yyvs)}; +private yyprod450 ((_, (YYNTfield yy1)):yyvs) = do { let {!yyr = reduce450 yy1}; YYM.pure (YYNTfields yyr, yyvs)}; private yyprod450 yyvals = yybadprod 450 yyvals; -private yyprod451 ((_, (YYNTgetfield yy1)):yyvs) = do { let {!yyr = reduce451 yy1}; YYM.pure (YYNTgetfields yyr, yyvs)}; +private yyprod451 ((_, (YYNTfields yy3)):(_, (YYTok yy2)):(_, (YYNTfield yy1)):yyvs) = do { yyr <- reduce451 yy1 yy2 yy3 ;YYM.pure (YYNTfields yyr, yyvs)}; private yyprod451 yyvals = yybadprod 451 yyvals; -private yyprod452 ((_, (YYNTgetfields yy3)):(_, (YYTok yy2)):(_, (YYNTgetfield yy1)):yyvs) = do { let {!yyr = reduce452 yy1 yy2 yy3}; YYM.pure (YYNTgetfields yyr, yyvs)}; +private yyprod452 ((_, (YYTok yy2)):(_, (YYNTfield yy1)):yyvs) = do { let {!yyr = reduce452 yy1 yy2}; YYM.pure (YYNTfields yyr, yyvs)}; private yyprod452 yyvals = yybadprod 452 yyvals; -private yyprod453 ((_, (YYTok yy2)):(_, (YYNTgetfield yy1)):yyvs) = do { let {!yyr = reduce453 yy1 yy2}; YYM.pure (YYNTgetfields yyr, yyvs)}; +private yyprod453 ((_, (YYNTgetfield yy1)):yyvs) = do { let {!yyr = reduce453 yy1}; YYM.pure (YYNTgetfields yyr, yyvs)}; private yyprod453 yyvals = yybadprod 453 yyvals; -private yyprod454 ((_, (YYNTexpr yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce454 yy1 yy2 yy3}; YYM.pure (YYNTgetfield yyr, yyvs)}; +private yyprod454 ((_, (YYNTgetfields yy3)):(_, (YYTok yy2)):(_, (YYNTgetfield yy1)):yyvs) = do { let {!yyr = reduce454 yy1 yy2 yy3}; YYM.pure (YYNTgetfields yyr, yyvs)}; private yyprod454 yyvals = yybadprod 454 yyvals; -private yyprod455 ((_, (YYNTexpr yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce455 yy1 yy2 yy3}; YYM.pure (YYNTgetfield yyr, yyvs)}; +private yyprod455 ((_, (YYTok yy2)):(_, (YYNTgetfield yy1)):yyvs) = do { let {!yyr = reduce455 yy1 yy2}; YYM.pure (YYNTgetfields yyr, yyvs)}; private yyprod455 yyvals = yybadprod 455 yyvals; -private yyprod456 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce456 yy1}; YYM.pure (YYNTgetfield yyr, yyvs)}; +private yyprod456 ((_, (YYNTexpr yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce456 yy1 yy2 yy3}; YYM.pure (YYNTgetfield yyr, yyvs)}; private yyprod456 yyvals = yybadprod 456 yyvals; -private yyprod457 ((_, (YYNTexpr yy3)):(_, (YYTok yy2)):(_, (YYNTvarid yy1)):yyvs) = do { let {!yyr = reduce457 yy1 yy2 yy3}; YYM.pure (YYNTfield yyr, yyvs)}; +private yyprod457 ((_, (YYNTexpr yy3)):(_, (YYTok yy2)):(_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce457 yy1 yy2 yy3}; YYM.pure (YYNTgetfield yyr, yyvs)}; private yyprod457 yyvals = yybadprod 457 yyvals; -private yyprod458 ((_, (YYNTvarid yy1)):yyvs) = do { let {!yyr = reduce458 yy1}; YYM.pure (YYNTfield yyr, yyvs)}; +private yyprod458 ((_, (YYTok yy1)):yyvs) = do { let {!yyr = reduce458 yy1}; YYM.pure (YYNTgetfield yyr, yyvs)}; private yyprod458 yyvals = yybadprod 458 yyvals; -private yyprod459 ((_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce459 yy1}; YYM.pure (YYNTexprSC yyr, yyvs)}; +private yyprod459 ((_, (YYNTexpr yy3)):(_, (YYTok yy2)):(_, (YYNTvarid yy1)):yyvs) = do { let {!yyr = reduce459 yy1 yy2 yy3}; YYM.pure (YYNTfield yyr, yyvs)}; private yyprod459 yyvals = yybadprod 459 yyvals; -private yyprod460 ((_, (YYNTexprSC yy3)):(_, (YYTok yy2)):(_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce460 yy1 yy2 yy3}; YYM.pure (YYNTexprSC yyr, yyvs)}; +private yyprod460 ((_, (YYNTvarid yy1)):yyvs) = do { let {!yyr = reduce460 yy1}; YYM.pure (YYNTfield yyr, yyvs)}; private yyprod460 yyvals = yybadprod 460 yyvals; -private yyprod461 ((_, (YYTok yy2)):(_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce461 yy1 yy2}; YYM.pure (YYNTexprSC yyr, yyvs)}; +private yyprod461 ((_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce461 yy1}; YYM.pure (YYNTexprSC yyr, yyvs)}; private yyprod461 yyvals = yybadprod 461 yyvals; -private yyprod462 ((_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce462 yy1}; YYM.pure (YYNTexprSS yyr, yyvs)}; +private yyprod462 ((_, (YYNTexprSC yy3)):(_, (YYTok yy2)):(_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce462 yy1 yy2 yy3}; YYM.pure (YYNTexprSC yyr, yyvs)}; private yyprod462 yyvals = yybadprod 462 yyvals; -private yyprod463 ((_, (YYNTexprSS yy3)):(_, (YYTok yy2)):(_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce463 yy1 yy2 yy3}; YYM.pure (YYNTexprSS yyr, yyvs)}; +private yyprod463 ((_, (YYTok yy2)):(_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce463 yy1 yy2}; YYM.pure (YYNTexprSC yyr, yyvs)}; private yyprod463 yyvals = yybadprod 463 yyvals; -private yyprod464 ((_, (YYTok yy2)):(_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce464 yy1 yy2}; YYM.pure (YYNTexprSS yyr, yyvs)}; +private yyprod464 ((_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce464 yy1}; YYM.pure (YYNTexprSS yyr, yyvs)}; private yyprod464 yyvals = yybadprod 464 yyvals; +private yyprod465 ((_, (YYNTexprSS yy3)):(_, (YYTok yy2)):(_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce465 yy1 yy2 yy3}; YYM.pure (YYNTexprSS yyr, yyvs)}; +private yyprod465 yyvals = yybadprod 465 yyvals; +private yyprod466 ((_, (YYTok yy2)):(_, (YYNTexpr yy1)):yyvs) = do { let {!yyr = reduce466 yy1 yy2}; YYM.pure (YYNTexprSS yyr, yyvs)}; +private yyprod466 yyvals = yybadprod 466 yyvals; private yyprods = let @@ -8407,7 +8478,9 @@ private yyprods = let (461, yyprod461), (462, yyprod462), (463, yyprod463), - (464, yyprod464)]; + (464, yyprod464), + (465, yyprod465), + (466, yyprod466)]; in sub1 `seq` sub2 `seq` sub3 `seq` sub4 `seq` sub5 `seq` sub6 `seq` sub7 `seq` sub8 `seq` arrayFromIndexList (sub1 ++ sub2 ++ sub3 ++ sub4 ++ sub5 ++ sub6 ++ sub7 ++ sub8); private yyacts = let sub1 = [ (0, yyaction0), @@ -9136,7 +9209,15 @@ private yyacts = let (723, yyaction723), (724, yyaction724), (725, yyaction725), - (726, yyaction726)]; + (726, yyaction726), + (727, yyaction727), + (728, yyaction728), + (729, yyaction729), + (730, yyaction730), + (731, yyaction731), + (732, yyaction732), + (733, yyaction733), + (734, yyaction734)]; in sub1 `seq` sub2 `seq` sub3 `seq` sub4 `seq` sub5 `seq` sub6 `seq` sub7 `seq` sub8 `seq` sub9 `seq` sub10 `seq` sub11 `seq` sub12 `seq` arrayFromIndexList (sub1 ++ sub2 ++ sub3 ++ sub4 ++ sub5 ++ sub6 ++ sub7 ++ sub8 ++ sub9 ++ sub10 ++ sub11 ++ sub12); private yyrecs = let sub1 = [ (0, yybadstart 0 "a module"), @@ -9219,554 +9300,554 @@ private yyrecs = let (77, yyparsing 77 "a declaration"), (78, yyparsing 78 "a declaration"), (79, yyparsing 79 "a declaration"), - (80, yyparsing 80 "a local declaration"), + (80, yyparsing 80 "a declaration"), (81, yyparsing 81 "a local declaration"), - (82, yybadstart 82 "a where clause"), - (83, yyparsing 83 "an annotated item"), - (84, yyparsing 84 "a term"), + (82, yyparsing 82 "a local declaration"), + (83, yybadstart 83 "a where clause"), + (84, yyparsing 84 "an annotated item"), (85, yyparsing 85 "a term"), - (86, yyparsing 86 "unary expression"), - (87, yyparsing 87 "a fixity declaration"), - (88, yyexpect 88(yyfromId DCOLON)), - (89, yyparsing 89 "a list of items to annotate"), - (90, yyparsing 90 "a declaration of a native item"), - (91, yybadstart 91 "declarations local to a class, instance or type"), - (92, yyparsing 92 "a function or pattern binding"), - (93, yyparsing 93 "left hand side of a function or pattern binding"), - (94, yyparsing 94 "a term"), - (95, yyparsing 95 "a top level expression"), - (96, yyparsing 96 "binary expression"), + (86, yyparsing 86 "a term"), + (87, yyparsing 87 "unary expression"), + (88, yyparsing 88 "a fixity declaration"), + (89, yyexpect 89(yyfromId DCOLON)), + (90, yyparsing 90 "a list of items to annotate"), + (91, yyparsing 91 "a declaration of a native item"), + (92, yybadstart 92 "declarations local to a class, instance or type"), + (93, yybadstart 93 "declarations local to a class, instance or type"), + (94, yyparsing 94 "a function or pattern binding"), + (95, yyparsing 95 "left hand side of a function or pattern binding"), + (96, yyparsing 96 "a term"), (97, yyparsing 97 "a top level expression"), - (98, yyparsing 98 "function application"), - (99, yyparsing 99 "unary expression"), - (100, yyexpect 100(yyfromCh '{')), - (101, yyparsing 101 "a primary expression"), - (102, yyparsing 102 "a word"), - (103, yyexpect 103(yyfromCh '{')), - (104, yyparsing 104 "a module"), - (105, yyexpect 105(yyfromCh '(')), - (106, yyparsing 106 "words"), - (107, yyparsing 107 "a module name"), - (108, yyparsing 108 "a module name"), - (109, yyparsing 109 "a module clause"), - (110, yyparsing 110 "a variable or an operator"), - (111, yyparsing 111 "a qualified constructor or type name"), - (112, yyparsing 112 "a qualified variable name"), - (113, yyparsing 113 "a variable or an operator"), + (98, yyparsing 98 "binary expression"), + (99, yyparsing 99 "a top level expression"), + (100, yyparsing 100 "function application"), + (101, yyparsing 101 "unary expression"), + (102, yyexpect 102(yyfromCh '{')), + (103, yyparsing 103 "a primary expression"), + (104, yyparsing 104 "a word"), + (105, yyexpect 105(yyfromCh '{')), + (106, yyparsing 106 "a module"), + (107, yyexpect 107(yyfromCh '(')), + (108, yyparsing 108 "words"), + (109, yyparsing 109 "a module name"), + (110, yyparsing 110 "a module name"), + (111, yyparsing 111 "a module clause"), + (112, yyparsing 112 "a variable or an operator"), + (113, yyparsing 113 "a qualified constructor or type name"), (114, yyparsing 114 "a qualified variable name"), - (115, yyparsing 115 "a module import"), - (116, yyparsing 116 "the start of a fixity declaration"), - (117, yyparsing 117 "the start of a fixity declaration"), + (115, yyparsing 115 "a variable or an operator"), + (116, yyparsing 116 "a qualified variable name"), + (117, yyparsing 117 "a module import"), (118, yyparsing 118 "the start of a fixity declaration"), - (119, yyparsing 119 "a variable name"), - (120, yybadstart 120 "the type this module derives from"), - (121, yyparsing 121 "an operator"), - (122, yyparsing 122 "the frege name of the native method"), - (123, yyparsing 123 "an annotated item"), + (119, yyparsing 119 "the start of a fixity declaration"), + (120, yyparsing 120 "the start of a fixity declaration"), + (121, yyparsing 121 "a variable name"), + (122, yybadstart 122 "the type this module derives from"), + (123, yyparsing 123 "an operator"), (124, yyparsing 124 "the frege name of the native method"), - (125, yyparsing 125 "the frege name of the native method"), + (125, yyparsing 125 "an annotated item"), (126, yyparsing 126 "the frege name of the native method"), - (127, yyparsing 127 "a specification of a native item")]; - sub3 = [ (128, yyexpect 128(yyfromId DCOLON)), - (129, yyparsing 129 "a data definition"), - (130, yyparsing 130 "a data definition"), - (131, yyparsing 131 "a qualified constructor or type name"), - (132, yyparsing 132 "type class context"), - (133, yybadstart 133 "a type variable"), + (127, yyparsing 127 "the frege name of the native method")]; + sub3 = [ (128, yyparsing 128 "the frege name of the native method"), + (129, yyparsing 129 "a specification of a native item"), + (130, yyexpect 130(yyfromId DCOLON)), + (131, yyparsing 131 "a data definition"), + (132, yyparsing 132 "a data definition"), + (133, yyparsing 133 "a qualified constructor or type name"), (134, yyparsing 134 "type class context"), - (135, yybadstart 135 "declarations local to a class, instance or type"), - (136, yyparsing 136 "instance context"), - (137, yyparsing 137 "instance constraint"), + (135, yybadstart 135 "a type variable"), + (136, yyparsing 136 "type class context"), + (137, yybadstart 137 "declarations local to a class, instance or type"), (138, yyparsing 138 "instance context"), - (139, yyparsing 139 "instance head"), - (140, yybadstart 140 "declarations local to a class, instance or type"), - (141, yyparsing 141 "a protected or private declaration"), - (142, yyparsing 142 "a type declaration"), - (143, yyparsing 143 "a qualified variable name"), - (144, yyparsing 144 "a term"), - (145, yybadstart 145 "then branch"), - (146, yyparsing 146 "an expression"), - (147, yyexpect 147(yyfromId OF)), - (148, yyparsing 148 "an instance derivation"), - (149, yyparsing 149 "a top level expression"), - (150, yyparsing 150 "a primary expression"), - (151, yyparsing 151 "a declaration of a native item"), - (152, yyparsing 152 "a protected or private declaration"), - (153, yyparsing 153 "a protected or private declaration"), - (154, yyparsing 154 "a protected or private declaration"), - (155, yyparsing 155 "a declaration of a native item"), - (156, yyparsing 156 "binary expression"), - (157, yyparsing 157 "an annotated item"), - (158, yyparsing 158 "a term"), - (159, yybadstart 159 "a sequence of one or more ','"), + (139, yyparsing 139 "instance constraint"), + (140, yyparsing 140 "instance context"), + (141, yyparsing 141 "instance head"), + (142, yybadstart 142 "declarations local to a class, instance or type"), + (143, yyexpect 143(yyfromId CONID)), + (144, yyparsing 144 "a protected or private declaration"), + (145, yyparsing 145 "a type declaration"), + (146, yyparsing 146 "a qualified variable name"), + (147, yyparsing 147 "a term"), + (148, yybadstart 148 "then branch"), + (149, yyparsing 149 "an expression"), + (150, yyexpect 150(yyfromId OF)), + (151, yyparsing 151 "an instance derivation"), + (152, yyparsing 152 "a top level expression"), + (153, yyparsing 153 "a primary expression"), + (154, yyparsing 154 "a declaration of a native item"), + (155, yyparsing 155 "a protected or private declaration"), + (156, yyparsing 156 "a protected or private declaration"), + (157, yyparsing 157 "a protected or private declaration"), + (158, yyparsing 158 "a declaration of a native item"), + (159, yyparsing 159 "binary expression"), (160, yyparsing 160 "an annotated item"), - (161, yyparsing 161 "an annotated item"), - (162, yyexpect 162(yyfromCh ')')), - (163, yyparsing 163 "a term"), - (164, yybadstart 164 "an operator"), - (165, yyparsing 165 "a term"), + (161, yyparsing 161 "a term"), + (162, yybadstart 162 "a sequence of one or more ','"), + (163, yyparsing 163 "an annotated item"), + (164, yyparsing 164 "an annotated item"), + (165, yyexpect 165(yyfromCh ')')), (166, yyparsing 166 "a term"), - (167, yyparsing 167 "a term"), - (168, yyparsing 168 "a lambda abstraction"), - (169, yyparsing 169 "lambda patterns"), - (170, yyparsing 170 "a module"), - (171, yyparsing 171 "declarations"), - (172, yyexpect 172(yyfromCh '{')), - (173, yyparsing 173 "a function or pattern binding"), - (174, yyparsing 174 "a term"), - (175, yyparsing 175 "unary expression"), - (176, yyparsing 176 "an operator"), - (177, yyparsing 177 "an operator"), - (178, yyparsing 178 "an operator"), - (179, yyparsing 179 "some operators"), - (180, yyparsing 180 "a fixity declaration"), - (181, yyparsing 181 "an annotation"), - (182, yyparsing 182 "a list of items to annotate"), - (183, yyexpect 183(yyfromCh '{')), - (184, yyparsing 184 "a data definition"), - (185, yyparsing 185 "a guarded expression"), - (186, yyparsing 186 "a function or pattern binding"), - (187, yyparsing 187 "a function or pattern binding"), - (188, yyparsing 188 "guarded expressions"), - (189, yyparsing 189 "binary expression"), - (190, yyparsing 190 "binary expression"), - (191, yyparsing 191 "function application")]; - sub4 = [ (192, yyparsing 192 "a primary expression"), - (193, yyexpect 193(yyfromId VARID)), - (194, yyparsing 194 "a module"), - (195, yyparsing 195 "a module"), - (196, yyparsing 196 "a module clause"), - (197, yyparsing 197 "words"), - (198, yyparsing 198 "a module name"), - (199, yyparsing 199 "a qualified constructor or type name"), - (200, yyparsing 200 "a qualified variable name"), - (201, yyparsing 201 "a module import"), - (202, yyparsing 202 "a module import"), - (203, yyparsing 203 "an import list"), - (204, yyparsing 204 "an import list"), + (167, yybadstart 167 "an operator"), + (168, yyparsing 168 "a term"), + (169, yyparsing 169 "a term"), + (170, yyparsing 170 "a term"), + (171, yyparsing 171 "a lambda abstraction"), + (172, yyparsing 172 "lambda patterns"), + (173, yyparsing 173 "a module"), + (174, yyparsing 174 "declarations"), + (175, yyexpect 175(yyfromCh '{')), + (176, yyparsing 176 "a function or pattern binding"), + (177, yyparsing 177 "a term"), + (178, yyparsing 178 "unary expression"), + (179, yyparsing 179 "an operator"), + (180, yyparsing 180 "an operator"), + (181, yyparsing 181 "an operator"), + (182, yyparsing 182 "some operators"), + (183, yyparsing 183 "a fixity declaration"), + (184, yyparsing 184 "an annotation"), + (185, yyparsing 185 "a list of items to annotate"), + (186, yyexpect 186(yyfromCh '{')), + (187, yyparsing 187 "a data definition"), + (188, yyparsing 188 "a data definition for a native type"), + (189, yyparsing 189 "a guarded expression"), + (190, yyparsing 190 "a function or pattern binding"), + (191, yyparsing 191 "a function or pattern binding")]; + sub4 = [ (192, yyparsing 192 "guarded expressions"), + (193, yyparsing 193 "binary expression"), + (194, yyparsing 194 "binary expression"), + (195, yyparsing 195 "function application"), + (196, yyparsing 196 "a primary expression"), + (197, yyexpect 197(yyfromId VARID)), + (198, yyparsing 198 "a module"), + (199, yyparsing 199 "a module"), + (200, yyparsing 200 "a module clause"), + (201, yyparsing 201 "words"), + (202, yyparsing 202 "a module name"), + (203, yyparsing 203 "a qualified constructor or type name"), + (204, yyparsing 204 "a qualified variable name"), (205, yyparsing 205 "a module import"), - (206, yyexpect 206(yyfromCh '(')), - (207, yyparsing 207 "the type this module derives from"), - (208, yybadstart 208 "the interfaces this module implements"), - (209, yyexpect 209(yyfromCh ')')), - (210, yyexpect 210(yyfromCh ')')), - (211, yyexpect 211(yyfromCh ')')), - (212, yyparsing 212 "a valid java identifier"), - (213, yyparsing 213 "a valid java identifier"), - (214, yybadstart 214 "a valid java identifier"), - (215, yyparsing 215 "a valid java identifier"), + (206, yyparsing 206 "a module import"), + (207, yyparsing 207 "an import list"), + (208, yyparsing 208 "an import list"), + (209, yyparsing 209 "a module import"), + (210, yyexpect 210(yyfromCh '(')), + (211, yyparsing 211 "the type this module derives from"), + (212, yybadstart 212 "the interfaces this module implements"), + (213, yyexpect 213(yyfromCh ')')), + (214, yyexpect 214(yyfromCh ')')), + (215, yyexpect 215(yyfromCh ')')), (216, yyparsing 216 "a valid java identifier"), - (217, yyparsing 217 "native generic type arguments"), - (218, yyparsing 218 "a native item"), + (217, yyparsing 217 "a valid java identifier"), + (218, yybadstart 218 "a valid java identifier"), (219, yyparsing 219 "a valid java identifier"), - (220, yyparsing 220 "a native item"), - (221, yyparsing 221 "a native item"), - (222, yybadstart 222 "native generic type arguments"), - (223, yyparsing 223 "a specification of a native item"), - (224, yyparsing 224 "a declaration of a native item"), - (225, yyparsing 225 "a type variable"), - (226, yyparsing 226 "a type variable"), - (227, yyparsing 227 "a data definition"), - (228, yyexpect 228(yyfromCh '=')), - (229, yyparsing 229 "type variables bound in forall or data/type/newtype"), - (230, yyparsing 230 "a data definition"), - (231, yyexpect 231(yyfromCh '=')), - (232, yyexpect 232(yyfromId CONID)), - (233, yyparsing 233 "simple constraints"), - (234, yyexpect 234(yyfromCh ')')), - (235, yyparsing 235 "simple constraint"), + (220, yyparsing 220 "a valid java identifier"), + (221, yyparsing 221 "native generic type arguments"), + (222, yyparsing 222 "a native item"), + (223, yyparsing 223 "a valid java identifier"), + (224, yyparsing 224 "a native item"), + (225, yyparsing 225 "a native item"), + (226, yybadstart 226 "native generic type arguments"), + (227, yyparsing 227 "a specification of a native item"), + (228, yyparsing 228 "a declaration of a native item"), + (229, yyparsing 229 "a type variable"), + (230, yyparsing 230 "a type variable"), + (231, yyparsing 231 "a data definition"), + (232, yyexpect 232(yyfromCh '=')), + (233, yyparsing 233 "type variables bound in forall or data/type/newtype"), + (234, yyparsing 234 "a data definition"), + (235, yyexpect 235(yyfromCh '=')), (236, yyexpect 236(yyfromId CONID)), - (237, yyparsing 237 "a type class declaration"), - (238, yyparsing 238 "instance constraints"), - (239, yyexpect 239(yyfromCh ')')), - (240, yyparsing 240 "a non function type"), - (241, yyparsing 241 "a non function type"), - (242, yyparsing 242 "a type constructor"), - (243, yyparsing 243 "instance constraint"), + (237, yyparsing 237 "simple constraints"), + (238, yyexpect 238(yyfromCh ')')), + (239, yyparsing 239 "simple constraint"), + (240, yyexpect 240(yyfromId CONID)), + (241, yyparsing 241 "a type class declaration"), + (242, yyparsing 242 "instance constraints"), + (243, yyexpect 243(yyfromCh ')')), (244, yyparsing 244 "a non function type"), (245, yyparsing 245 "a non function type"), - (246, yyparsing 246 "instance head"), - (247, yyparsing 247 "an instance declaration"), - (248, yyparsing 248 "a type declaration"), - (249, yyexpect 249(yyfromCh '=')), - (250, yyparsing 250 "binary expression"), - (251, yyparsing 251 "a term"), - (252, yyparsing 252 "unary expression"), - (253, yyparsing 253 "then branch"), - (254, yyexpect 254(yyfromId THEN)), - (255, yyparsing 255 "a top level expression")]; - sub5 = [ (256, yyparsing 256 "an expression"), - (257, yyexpect 257(yyfromCh '{')), - (258, yyparsing 258 "a function or pattern binding"), - (259, yybadstart 259 "a where clause"), - (260, yyparsing 260 "declarations in a let expression or where clause"), - (261, yyexpect 261(yyfromCh '}')), + (246, yyparsing 246 "a type constructor"), + (247, yyparsing 247 "instance constraint"), + (248, yyparsing 248 "a non function type"), + (249, yyparsing 249 "a non function type"), + (250, yyparsing 250 "instance head"), + (251, yyparsing 251 "an instance declaration"), + (252, yyparsing 252 "a data definition"), + (253, yyparsing 253 "a type declaration"), + (254, yyexpect 254(yyfromCh '=')), + (255, yyparsing 255 "binary expression")]; + sub5 = [ (256, yyparsing 256 "a term"), + (257, yyparsing 257 "unary expression"), + (258, yyparsing 258 "then branch"), + (259, yyexpect 259(yyfromId THEN)), + (260, yyparsing 260 "a top level expression"), + (261, yyparsing 261 "an expression"), (262, yyexpect 262(yyfromCh '{')), - (263, yyparsing 263 "a list comprehension qualifier"), - (264, yyparsing 264 "do expression qualifiers"), - (265, yyparsing 265 "a list comprehension qualifier"), + (263, yyparsing 263 "a function or pattern binding"), + (264, yybadstart 264 "a where clause"), + (265, yyparsing 265 "declarations in a let expression or where clause"), (266, yyexpect 266(yyfromCh '}')), - (267, yyparsing 267 "an annotated item"), - (268, yyparsing 268 "a sequence of one or more ','"), - (269, yyparsing 269 "an annotated item"), - (270, yyexpect 270(yyfromCh ')')), - (271, yyparsing 271 "an annotated item"), - (272, yyparsing 272 "a term"), - (273, yyparsing 273 "a term"), - (274, yyparsing 274 "a term"), - (275, yyparsing 275 "a term"), - (276, yyparsing 276 "an operator"), - (277, yyparsing 277 "binary expression"), - (278, yyexpect 278(yyfromCh ')')), - (279, yyparsing 279 "list of expressions separated by ','"), + (267, yyexpect 267(yyfromCh '{')), + (268, yyparsing 268 "a list comprehension qualifier"), + (269, yyparsing 269 "do expression qualifiers"), + (270, yyparsing 270 "a list comprehension qualifier"), + (271, yyexpect 271(yyfromCh '}')), + (272, yyparsing 272 "an annotated item"), + (273, yyparsing 273 "a sequence of one or more ','"), + (274, yyparsing 274 "an annotated item"), + (275, yyexpect 275(yyfromCh ')')), + (276, yyparsing 276 "an annotated item"), + (277, yyparsing 277 "a term"), + (278, yyparsing 278 "a term"), + (279, yyparsing 279 "a term"), (280, yyparsing 280 "a term"), - (281, yyparsing 281 "a term"), - (282, yyparsing 282 "a term"), - (283, yyparsing 283 "a lambda body"), - (284, yyparsing 284 "a lambda body"), - (285, yyparsing 285 "a lambda abstraction"), - (286, yyparsing 286 "lambda patterns"), - (287, yyparsing 287 "declarations"), - (288, yyparsing 288 "a where clause"), - (289, yyparsing 289 "a term"), - (290, yyparsing 290 "field"), - (291, yyexpect 291(yyfromCh '}')), - (292, yyparsing 292 "field list"), - (293, yyparsing 293 "some operators"), - (294, yyparsing 294 "a qualified type"), - (295, yyparsing 295 "an annotation"), - (296, yyparsing 296 "a qualified type"), - (297, yyparsing 297 "a qualified type"), - (298, yyparsing 298 "a constrained type"), - (299, yyparsing 299 "a constrained type"), - (300, yyparsing 300 "a type application"), - (301, yyparsing 301 "non function types"), - (302, yyparsing 302 "a list of items to annotate"), - (303, yyparsing 303 "declarations local to a class, instance or type"), - (304, yyparsing 304 "a guard qualifier"), - (305, yyparsing 305 "guard qualifiers"), - (306, yybadstart 306 "'='"), - (307, yyparsing 307 "a function or pattern binding"), - (308, yyparsing 308 "guarded expressions"), - (309, yyparsing 309 "binary expression"), - (310, yyparsing 310 "binary expression"), - (311, yyparsing 311 "a primary expression"), - (312, yyexpect 312(yyfromId VARID)), - (313, yyparsing 313 "a primary expression"), - (314, yyparsing 314 "a primary expression"), - (315, yyparsing 315 "a primary expression"), + (281, yyparsing 281 "an operator"), + (282, yyparsing 282 "binary expression"), + (283, yyexpect 283(yyfromCh ')')), + (284, yyparsing 284 "list of expressions separated by ','"), + (285, yyparsing 285 "a term"), + (286, yyparsing 286 "a term"), + (287, yyparsing 287 "a term"), + (288, yyparsing 288 "a lambda body"), + (289, yyparsing 289 "a lambda body"), + (290, yyparsing 290 "a lambda abstraction"), + (291, yyparsing 291 "lambda patterns"), + (292, yyparsing 292 "declarations"), + (293, yyparsing 293 "a where clause"), + (294, yyparsing 294 "a term"), + (295, yyparsing 295 "field"), + (296, yyexpect 296(yyfromCh '}')), + (297, yyparsing 297 "field list"), + (298, yyparsing 298 "some operators"), + (299, yyparsing 299 "a qualified type"), + (300, yyparsing 300 "an annotation"), + (301, yyparsing 301 "a qualified type"), + (302, yyparsing 302 "a qualified type"), + (303, yyparsing 303 "a constrained type"), + (304, yyparsing 304 "a constrained type"), + (305, yyparsing 305 "a type application"), + (306, yyparsing 306 "non function types"), + (307, yyparsing 307 "a list of items to annotate"), + (308, yyparsing 308 "declarations local to a class, instance or type"), + (309, yyparsing 309 "a guard qualifier"), + (310, yyparsing 310 "guard qualifiers"), + (311, yybadstart 311 "'='"), + (312, yyparsing 312 "a function or pattern binding"), + (313, yyparsing 313 "guarded expressions"), + (314, yyparsing 314 "binary expression"), + (315, yyparsing 315 "binary expression"), (316, yyparsing 316 "a primary expression"), - (317, yyexpect 317(yyfromCh '}')), - (318, yyparsing 318 "field list"), - (319, yyexpect 319(yyfromCh '}'))]; - sub6 = [ (320, yyparsing 320 "a qualified variable name"), - (321, yyexpect 321(yyfromCh ')')), - (322, yyparsing 322 "a qualified variable name"), - (323, yyparsing 323 "a list of qualified variable names"), - (324, yyparsing 324 "a qualified variable name"), - (325, yyparsing 325 "a module import"), - (326, yyparsing 326 "a module import"), - (327, yyparsing 327 "an import list"), - (328, yyparsing 328 "an import item"), + (317, yyexpect 317(yyfromId VARID)), + (318, yyparsing 318 "a primary expression"), + (319, yyparsing 319 "a primary expression")]; + sub6 = [ (320, yyparsing 320 "a primary expression"), + (321, yyparsing 321 "a primary expression"), + (322, yyexpect 322(yyfromCh '}')), + (323, yyparsing 323 "field list"), + (324, yyexpect 324(yyfromCh '}')), + (325, yyparsing 325 "a qualified variable name"), + (326, yyexpect 326(yyfromCh ')')), + (327, yyparsing 327 "a qualified variable name"), + (328, yyparsing 328 "a list of qualified variable names"), (329, yyparsing 329 "a qualified variable name"), - (330, yyparsing 330 "an import specification"), - (331, yyparsing 331 "an import list"), - (332, yyexpect 332(yyfromCh ')')), - (333, yyparsing 333 "a list of import items"), - (334, yyparsing 334 "an import specification"), - (335, yyparsing 335 "an import item"), - (336, yyparsing 336 "an import item"), - (337, yyparsing 337 "an import item"), - (338, yyparsing 338 "an import item"), - (339, yyparsing 339 "an import list"), - (340, yyparsing 340 "the type this module derives from"), - (341, yyparsing 341 "a non function type"), - (342, yyparsing 342 "a non function type"), - (343, yyparsing 343 "the interfaces this module implements"), - (344, yyexpect 344(yyfromId WHERE)), - (345, yyparsing 345 "an annotated item"), - (346, yyparsing 346 "an annotated item"), - (347, yyparsing 347 "an annotated item"), - (348, yybadstart 348 "a valid java identifier"), - (349, yyparsing 349 "a valid java identifier"), - (350, yybadstart 350 "a valid java identifier"), - (351, yyparsing 351 "native generic type arguments"), - (352, yyparsing 352 "a list of types"), - (353, yyexpect 353(yyfromCh '}')), - (354, yyparsing 354 "a specification of a native item"), - (355, yyparsing 355 "a method type with optional throws clause"), - (356, yyparsing 356 "method types with optional throws clauses"), - (357, yyparsing 357 "a declaration of a native item"), - (358, yyparsing 358 "a type variable"), - (359, yyparsing 359 "a type variable"), - (360, yyparsing 360 "a type variable"), - (361, yyparsing 361 "a variant of an algebraic datatype"), - (362, yyparsing 362 "a variant of an algebraic datatype"), - (363, yyparsing 363 "a variant of an algebraic datatype"), - (364, yyparsing 364 "a variant of an algebraic datatype"), - (365, yyparsing 365 "a variant of an algebraic datatype"), - (366, yyexpect 366(yyfromId CONID)), - (367, yyexpect 367(yyfromId CONID)), - (368, yyparsing 368 "a data definition"), + (330, yyparsing 330 "a module import"), + (331, yyparsing 331 "a module import"), + (332, yyparsing 332 "an import list"), + (333, yyparsing 333 "an import item"), + (334, yyparsing 334 "a qualified variable name"), + (335, yyparsing 335 "an import specification"), + (336, yyparsing 336 "an import list"), + (337, yyexpect 337(yyfromCh ')')), + (338, yyparsing 338 "a list of import items"), + (339, yyparsing 339 "an import specification"), + (340, yyparsing 340 "an import item"), + (341, yyparsing 341 "an import item"), + (342, yyparsing 342 "an import item"), + (343, yyparsing 343 "an import item"), + (344, yyparsing 344 "an import list"), + (345, yyparsing 345 "the type this module derives from"), + (346, yyparsing 346 "a non function type"), + (347, yyparsing 347 "a non function type"), + (348, yyparsing 348 "the interfaces this module implements"), + (349, yyexpect 349(yyfromId WHERE)), + (350, yyparsing 350 "an annotated item"), + (351, yyparsing 351 "an annotated item"), + (352, yyparsing 352 "an annotated item"), + (353, yybadstart 353 "a valid java identifier"), + (354, yyparsing 354 "a valid java identifier"), + (355, yybadstart 355 "a valid java identifier"), + (356, yyparsing 356 "native generic type arguments"), + (357, yyparsing 357 "a list of types"), + (358, yyexpect 358(yyfromCh '}')), + (359, yyparsing 359 "a specification of a native item"), + (360, yyparsing 360 "a method type with optional throws clause"), + (361, yyparsing 361 "method types with optional throws clauses"), + (362, yyparsing 362 "a declaration of a native item"), + (363, yyparsing 363 "a type variable"), + (364, yyparsing 364 "a type variable"), + (365, yyparsing 365 "a type variable"), + (366, yyparsing 366 "a variant of an algebraic datatype"), + (367, yyparsing 367 "a variant of an algebraic datatype"), + (368, yyparsing 368 "a variant of an algebraic datatype"), (369, yyparsing 369 "a variant of an algebraic datatype"), (370, yyparsing 370 "a variant of an algebraic datatype"), - (371, yyparsing 371 "a variant of an algebraic datatype"), - (372, yyparsing 372 "a data definition"), - (373, yyparsing 373 "type variables bound in forall or data/type/newtype"), - (374, yyparsing 374 "a native data type"), - (375, yyexpect 375(yyfromId NATIVE)), - (376, yyparsing 376 "a data definition"), + (371, yyexpect 371(yyfromId CONID)), + (372, yyexpect 372(yyfromId CONID)), + (373, yyparsing 373 "a data definition"), + (374, yyparsing 374 "a variant of an algebraic datatype"), + (375, yyparsing 375 "a variant of an algebraic datatype"), + (376, yyparsing 376 "a variant of an algebraic datatype"), (377, yyparsing 377 "a data definition"), - (378, yyparsing 378 "an algebraic datatype"), - (379, yyparsing 379 "a data definition"), - (380, yyparsing 380 "simple constraints"), - (381, yyparsing 381 "type class context"), - (382, yybadstart 382 "a type variable"), - (383, yyparsing 383 "instance constraints")]; - sub7 = [ (384, yyparsing 384 "instance context"), - (385, yyparsing 385 "a type variable"), - (386, yyexpect 386(yyfromCh ')')), - (387, yyparsing 387 "a type constructor"), - (388, yyparsing 388 "a non function type"), - (389, yyexpect 389(yyfromCh ')')), - (390, yyparsing 390 "a type constructor"), - (391, yyexpect 391(yyfromCh ']')), - (392, yybadstart 392 "a sequence of one or more ','"), - (393, yyexpect 393(yyfromCh ']')), - (394, yyparsing 394 "instance head"), - (395, yyparsing 395 "a type declaration"), - (396, yyparsing 396 "a type declaration"), - (397, yyparsing 397 "a term"), - (398, yyparsing 398 "a term"), - (399, yyparsing 399 "a term"), - (400, yyparsing 400 "then branch"), - (401, yybadstart 401 "else branch"), - (402, yyparsing 402 "an expression"), - (403, yyparsing 403 "a top level expression"), - (404, yyparsing 404 "declarations in a let expression or where clause"), - (405, yyexpect 405(yyfromId IN)), - (406, yyparsing 406 "a list comprehension qualifier"), - (407, yyparsing 407 "a guard qualifier"), - (408, yyparsing 408 "a list comprehension qualifier"), - (409, yyparsing 409 "do expression qualifiers"), - (410, yyparsing 410 "a primary expression"), - (411, yyparsing 411 "a term"), - (412, yyparsing 412 "list of expressions separated by ';'"), - (413, yyexpect 413(yyfromCh ')')), - (414, yyparsing 414 "list of expressions separated by ','"), - (415, yyexpect 415(yyfromCh ')')), - (416, yyparsing 416 "a term"), - (417, yyparsing 417 "a term"), - (418, yyparsing 418 "list of expressions separated by ','"), - (419, yyparsing 419 "list comprehension qualifiers"), - (420, yyexpect 420(yyfromCh ']')), - (421, yyparsing 421 "a term"), - (422, yyexpect 422(yyfromCh ']')), - (423, yyparsing 423 "a lambda body"), - (424, yyparsing 424 "a where clause"), - (425, yyexpect 425(yyfromCh '}')), - (426, yyparsing 426 "field"), - (427, yyparsing 427 "a term"), - (428, yyparsing 428 "field list"), - (429, yybadstart 429 "'.' or '•'"), - (430, yyparsing 430 "a type"), - (431, yyparsing 431 "a constrained type"), - (432, yyparsing 432 "non function types"), - (433, yyparsing 433 "a protected or private local declaration"), - (434, yyparsing 434 "a protected or private local declaration"), - (435, yyparsing 435 "a protected or private local declaration"), - (436, yyparsing 436 "declarations local to a class, instance or type"), - (437, yyparsing 437 "a commented local declaration"), - (438, yyparsing 438 "a protected or private local declaration"), - (439, yyexpect 439(yyfromCh '}')), - (440, yyparsing 440 "local declarations"), - (441, yyparsing 441 "a commented local declaration"), - (442, yyparsing 442 "guard qualifiers"), - (443, yyparsing 443 "'='"), - (444, yyparsing 444 "'='"), - (445, yyparsing 445 "a guarded expression"), - (446, yyparsing 446 "a primary expression"), - (447, yyexpect 447(yyfromCh '}'))]; - sub8 = [ (448, yyexpect 448(yyfromCh ']')), - (449, yyparsing 449 "a primary expression"), - (450, yyexpect 450(yyfromCh '}')), - (451, yyparsing 451 "a primary expression"), - (452, yyparsing 452 "a primary expression"), - (453, yyparsing 453 "field list"), - (454, yyparsing 454 "a module"), - (455, yyparsing 455 "a qualified variable name"), - (456, yyparsing 456 "a qualified variable name"), - (457, yyparsing 457 "a module clause"), - (458, yyparsing 458 "a list of qualified variable names"), - (459, yyparsing 459 "a module import"), - (460, yyparsing 460 "an import item"), - (461, yyparsing 461 "a qualified variable name"), - (462, yyparsing 462 "an import specification"), - (463, yyparsing 463 "an import list"), - (464, yyparsing 464 "a list of import items"), - (465, yyparsing 465 "a simple name for a member or import item"), - (466, yyparsing 466 "a simple name for a member or import item"), - (467, yyparsing 467 "a simple name for a member or import item"), - (468, yyparsing 468 "an import specification"), - (469, yyexpect 469(yyfromCh ')')), - (470, yyparsing 470 "a non function type"), - (471, yyparsing 471 "the interfaces this module implements"), - (472, yyexpect 472(yyfromCh '{')), - (473, yyparsing 473 "specification for module class "), - (474, yyparsing 474 "a valid java identifier"), - (475, yyparsing 475 "a valid java identifier"), - (476, yyparsing 476 "a list of types"), - (477, yyparsing 477 "native generic type arguments"), - (478, yyparsing 478 "a method type with optional throws clause"), - (479, yyparsing 479 "method types with optional throws clauses"), - (480, yyparsing 480 "a type variable"), - (481, yyparsing 481 "a type variable"), - (482, yyexpect 482(yyfromCh ')')), - (483, yyexpect 483(yyfromCh ')')), - (484, yyparsing 484 "a variant of an algebraic datatype"), - (485, yyparsing 485 "constructor field represented by a type"), - (486, yyparsing 486 "constructor field represented by a type"), - (487, yyparsing 487 "constructor field represented by a type"), - (488, yyparsing 488 "a variant of an algebraic datatype"), - (489, yyparsing 489 "constructor fields represented by types"), - (490, yyparsing 490 "constructor field represented by a type"), + (378, yyparsing 378 "type variables bound in forall or data/type/newtype"), + (379, yyparsing 379 "a native data type"), + (380, yyexpect 380(yyfromId NATIVE)), + (381, yyparsing 381 "a data definition for a native type"), + (382, yyparsing 382 "a data definition"), + (383, yyparsing 383 "an algebraic datatype")]; + sub7 = [ (384, yyparsing 384 "a data definition"), + (385, yyparsing 385 "simple constraints"), + (386, yyparsing 386 "type class context"), + (387, yybadstart 387 "a type variable"), + (388, yyparsing 388 "instance constraints"), + (389, yyparsing 389 "instance context"), + (390, yyparsing 390 "a type variable"), + (391, yyexpect 391(yyfromCh ')')), + (392, yyparsing 392 "a type constructor"), + (393, yyparsing 393 "a non function type"), + (394, yyexpect 394(yyfromCh ')')), + (395, yyparsing 395 "a type constructor"), + (396, yyexpect 396(yyfromCh ']')), + (397, yybadstart 397 "a sequence of one or more ','"), + (398, yyexpect 398(yyfromCh ']')), + (399, yyparsing 399 "instance head"), + (400, yyparsing 400 "a data definition"), + (401, yyexpect 401(yyfromCh '=')), + (402, yyparsing 402 "a type declaration"), + (403, yyparsing 403 "a type declaration"), + (404, yyparsing 404 "a term"), + (405, yyparsing 405 "a term"), + (406, yyparsing 406 "a term"), + (407, yyparsing 407 "then branch"), + (408, yybadstart 408 "else branch"), + (409, yyparsing 409 "an expression"), + (410, yyparsing 410 "a top level expression"), + (411, yyparsing 411 "declarations in a let expression or where clause"), + (412, yyexpect 412(yyfromId IN)), + (413, yyparsing 413 "a list comprehension qualifier"), + (414, yyparsing 414 "a guard qualifier"), + (415, yyparsing 415 "a list comprehension qualifier"), + (416, yyparsing 416 "do expression qualifiers"), + (417, yyparsing 417 "a primary expression"), + (418, yyparsing 418 "a term"), + (419, yyparsing 419 "list of expressions separated by ';'"), + (420, yyexpect 420(yyfromCh ')')), + (421, yyparsing 421 "list of expressions separated by ','"), + (422, yyexpect 422(yyfromCh ')')), + (423, yyparsing 423 "a term"), + (424, yyparsing 424 "a term"), + (425, yyparsing 425 "list of expressions separated by ','"), + (426, yyparsing 426 "list comprehension qualifiers"), + (427, yyexpect 427(yyfromCh ']')), + (428, yyparsing 428 "a term"), + (429, yyexpect 429(yyfromCh ']')), + (430, yyparsing 430 "a lambda body"), + (431, yyparsing 431 "a where clause"), + (432, yyexpect 432(yyfromCh '}')), + (433, yyparsing 433 "field"), + (434, yyparsing 434 "a term"), + (435, yyparsing 435 "field list"), + (436, yybadstart 436 "'.' or '•'"), + (437, yyparsing 437 "a type"), + (438, yyparsing 438 "a constrained type"), + (439, yyparsing 439 "non function types"), + (440, yyparsing 440 "a protected or private local declaration"), + (441, yyparsing 441 "a protected or private local declaration"), + (442, yyparsing 442 "a protected or private local declaration"), + (443, yyparsing 443 "declarations local to a class, instance or type"), + (444, yyparsing 444 "a commented local declaration"), + (445, yyparsing 445 "a protected or private local declaration"), + (446, yyexpect 446(yyfromCh '}')), + (447, yyparsing 447 "local declarations")]; + sub8 = [ (448, yyparsing 448 "a commented local declaration"), + (449, yyparsing 449 "guard qualifiers"), + (450, yyparsing 450 "'='"), + (451, yyparsing 451 "'='"), + (452, yyparsing 452 "a guarded expression"), + (453, yyparsing 453 "a primary expression"), + (454, yyexpect 454(yyfromCh '}')), + (455, yyexpect 455(yyfromCh ']')), + (456, yyparsing 456 "a primary expression"), + (457, yyexpect 457(yyfromCh '}')), + (458, yyparsing 458 "a primary expression"), + (459, yyparsing 459 "a primary expression"), + (460, yyparsing 460 "field list"), + (461, yyparsing 461 "a module"), + (462, yyparsing 462 "a qualified variable name"), + (463, yyparsing 463 "a qualified variable name"), + (464, yyparsing 464 "a module clause"), + (465, yyparsing 465 "a list of qualified variable names"), + (466, yyparsing 466 "a module import"), + (467, yyparsing 467 "an import item"), + (468, yyparsing 468 "a qualified variable name"), + (469, yyparsing 469 "an import specification"), + (470, yyparsing 470 "an import list"), + (471, yyparsing 471 "a list of import items"), + (472, yyparsing 472 "a simple name for a member or import item"), + (473, yyparsing 473 "a simple name for a member or import item"), + (474, yyparsing 474 "a simple name for a member or import item"), + (475, yyparsing 475 "an import specification"), + (476, yyexpect 476(yyfromCh ')')), + (477, yyparsing 477 "a non function type"), + (478, yyparsing 478 "the interfaces this module implements"), + (479, yyexpect 479(yyfromCh '{')), + (480, yyparsing 480 "specification for module class "), + (481, yyparsing 481 "a valid java identifier"), + (482, yyparsing 482 "a valid java identifier"), + (483, yyparsing 483 "a list of types"), + (484, yyparsing 484 "native generic type arguments"), + (485, yyparsing 485 "a method type with optional throws clause"), + (486, yyparsing 486 "method types with optional throws clauses"), + (487, yyparsing 487 "a type variable"), + (488, yyparsing 488 "a type variable"), + (489, yyexpect 489(yyfromCh ')')), + (490, yyexpect 490(yyfromCh ')')), (491, yyparsing 491 "a variant of an algebraic datatype"), - (492, yyparsing 492 "a variant of an algebraic datatype"), - (493, yyparsing 493 "a variant of an algebraic datatype"), - (494, yyparsing 494 "a variant of an algebraic datatype"), + (492, yyparsing 492 "constructor field represented by a type"), + (493, yyparsing 493 "constructor field represented by a type"), + (494, yyparsing 494 "constructor field represented by a type"), (495, yyparsing 495 "a variant of an algebraic datatype"), - (496, yyparsing 496 "a variant of an algebraic datatype"), - (497, yyparsing 497 "a variant of an algebraic datatype"), - (498, yyparsing 498 "a data definition"), - (499, yyparsing 499 "a native data type"), - (500, yybadstart 500 "native generic type arguments"), - (501, yyparsing 501 "a data definition"), - (502, yyparsing 502 "an algebraic datatype"), - (503, yyparsing 503 "a data definition"), - (504, yyparsing 504 "a data definition"), - (505, yyparsing 505 "simple constraints"), - (506, yybadstart 506 "declarations local to a class, instance or type"), - (507, yyparsing 507 "instance constraints"), - (508, yyparsing 508 "a type constructor"), - (509, yyparsing 509 "a non function type"), - (510, yyparsing 510 "a non function type"), - (511, yyparsing 511 "a non function type")]; - sub9 = [ (512, yyparsing 512 "a type constructor"), - (513, yyparsing 513 "a non function type"), - (514, yyparsing 514 "instance head"), - (515, yyparsing 515 "a type declaration"), - (516, yyparsing 516 "else branch"), - (517, yyexpect 517(yyfromId ELSE)), - (518, yyparsing 518 "a top level expression"), - (519, yyparsing 519 "a pattern"), - (520, yyparsing 520 "case alternative"), - (521, yybadstart 521 "a where clause"), - (522, yyexpect 522(yyfromCh '}')), - (523, yyparsing 523 "declarations in a let expression or where clause"), - (524, yyparsing 524 "a top level expression"), - (525, yyexpect 525(yyfromCh '}')), - (526, yyparsing 526 "a guard qualifier"), - (527, yyparsing 527 "a list comprehension qualifier"), - (528, yyparsing 528 "do expression qualifiers"), - (529, yyparsing 529 "list of expressions separated by ';'"), - (530, yyparsing 530 "a term"), - (531, yyparsing 531 "a term"), - (532, yyparsing 532 "list comprehension qualifiers"), - (533, yyparsing 533 "a term"), - (534, yyparsing 534 "a term"), - (535, yyparsing 535 "a where clause"), - (536, yyparsing 536 "field"), - (537, yyparsing 537 "field list"), - (538, yyparsing 538 "'.' or '•'"), - (539, yyparsing 539 "'.' or '•'"), - (540, yyparsing 540 "a qualified type"), - (541, yyparsing 541 "a type"), - (542, yyparsing 542 "a type"), - (543, yyparsing 543 "a constrained type"), - (544, yyparsing 544 "a protected or private local declaration"), - (545, yyparsing 545 "a protected or private local declaration"), - (546, yyparsing 546 "a protected or private local declaration"), - (547, yyparsing 547 "a commented local declaration"), - (548, yyparsing 548 "declarations local to a class, instance or type"), - (549, yyparsing 549 "local declarations"), - (550, yyparsing 550 "guard qualifiers"), - (551, yyparsing 551 "a guarded expression"), - (552, yyparsing 552 "a primary expression"), - (553, yyexpect 553(yyfromCh '}')), - (554, yyparsing 554 "a primary expression"), - (555, yyparsing 555 "a primary expression"), - (556, yyparsing 556 "a primary expression"), - (557, yyparsing 557 "a primary expression"), - (558, yyparsing 558 "field"), - (559, yyparsing 559 "a primary expression"), + (496, yyparsing 496 "constructor fields represented by types"), + (497, yyparsing 497 "constructor field represented by a type"), + (498, yyparsing 498 "a variant of an algebraic datatype"), + (499, yyparsing 499 "a variant of an algebraic datatype"), + (500, yyparsing 500 "a variant of an algebraic datatype"), + (501, yyparsing 501 "a variant of an algebraic datatype"), + (502, yyparsing 502 "a variant of an algebraic datatype"), + (503, yyparsing 503 "a variant of an algebraic datatype"), + (504, yyparsing 504 "a variant of an algebraic datatype"), + (505, yyparsing 505 "a data definition"), + (506, yyparsing 506 "a native data type"), + (507, yybadstart 507 "native generic type arguments"), + (508, yyparsing 508 "a data definition for a native type"), + (509, yyparsing 509 "an algebraic datatype"), + (510, yyparsing 510 "a data definition for a native type"), + (511, yyparsing 511 "a data definition")]; + sub9 = [ (512, yyparsing 512 "simple constraints"), + (513, yybadstart 513 "declarations local to a class, instance or type"), + (514, yyparsing 514 "instance constraints"), + (515, yyparsing 515 "a type constructor"), + (516, yyparsing 516 "a non function type"), + (517, yyparsing 517 "a non function type"), + (518, yyparsing 518 "a non function type"), + (519, yyparsing 519 "a type constructor"), + (520, yyparsing 520 "a non function type"), + (521, yyparsing 521 "instance head"), + (522, yyparsing 522 "a data definition"), + (523, yyparsing 523 "a type declaration"), + (524, yyparsing 524 "else branch"), + (525, yyexpect 525(yyfromId ELSE)), + (526, yyparsing 526 "a top level expression"), + (527, yyparsing 527 "a pattern"), + (528, yyparsing 528 "case alternative"), + (529, yybadstart 529 "a where clause"), + (530, yyexpect 530(yyfromCh '}')), + (531, yyparsing 531 "declarations in a let expression or where clause"), + (532, yyparsing 532 "a top level expression"), + (533, yyexpect 533(yyfromCh '}')), + (534, yyparsing 534 "a guard qualifier"), + (535, yyparsing 535 "a list comprehension qualifier"), + (536, yyparsing 536 "do expression qualifiers"), + (537, yyparsing 537 "list of expressions separated by ';'"), + (538, yyparsing 538 "a term"), + (539, yyparsing 539 "a term"), + (540, yyparsing 540 "list comprehension qualifiers"), + (541, yyparsing 541 "a term"), + (542, yyparsing 542 "a term"), + (543, yyparsing 543 "a where clause"), + (544, yyparsing 544 "field"), + (545, yyparsing 545 "field list"), + (546, yyparsing 546 "'.' or '•'"), + (547, yyparsing 547 "'.' or '•'"), + (548, yyparsing 548 "a qualified type"), + (549, yyparsing 549 "a type"), + (550, yyparsing 550 "a type"), + (551, yyparsing 551 "a constrained type"), + (552, yyparsing 552 "a protected or private local declaration"), + (553, yyparsing 553 "a protected or private local declaration"), + (554, yyparsing 554 "a protected or private local declaration"), + (555, yyparsing 555 "a commented local declaration"), + (556, yyparsing 556 "declarations local to a class, instance or type"), + (557, yyparsing 557 "local declarations"), + (558, yyparsing 558 "guard qualifiers"), + (559, yyparsing 559 "a guarded expression"), (560, yyparsing 560 "a primary expression"), - (561, yyparsing 561 "field"), - (562, yyparsing 562 "field"), - (563, yyparsing 563 "field list"), - (564, yyparsing 564 "a qualified variable name"), - (565, yyparsing 565 "a list of qualified variable names"), - (566, yyparsing 566 "a member import specification"), - (567, yyparsing 567 "an import item"), - (568, yyexpect 568(yyfromCh ')')), - (569, yyparsing 569 "a member import specification"), - (570, yyparsing 570 "a list of member imports"), - (571, yyparsing 571 "a list of import items"), - (572, yyparsing 572 "an import list"), - (573, yyparsing 573 "a non function type"), - (574, yyparsing 574 "java code"), - (575, yyparsing 575 "a list of types")]; - sub10 = [ (576, yyparsing 576 "a method type with optional throws clause"), - (577, yyparsing 577 "method types with optional throws clauses"), - (578, yyexpect 578(yyfromCh ')')), - (579, yyparsing 579 "a type kind"), - (580, yyparsing 580 "a type kind"), - (581, yyexpect 581(yyfromCh ')')), - (582, yyparsing 582 "a type kind"), - (583, yyparsing 583 "a type variable"), - (584, yyparsing 584 "a type variable"), - (585, yyparsing 585 "a constructor field"), - (586, yyexpect 586(yyfromCh '}')), - (587, yyparsing 587 "constructor fields"), - (588, yyparsing 588 "constructor field represented by a type"), - (589, yyparsing 589 "constructor field represented by a type"), - (590, yyparsing 590 "constructor fields represented by types"), - (591, yyparsing 591 "a native generic type"), - (592, yyparsing 592 "an algebraic datatype"), - (593, yyparsing 593 "a data definition"), - (594, yyparsing 594 "a type class declaration"), - (595, yyexpect 595(yyfromCh ')')), - (596, yyparsing 596 "a list of types separated by '|'"), - (597, yyexpect 597(yyfromCh ')')), - (598, yyparsing 598 "else branch"), - (599, yyparsing 599 "a top level expression"), - (600, yyparsing 600 "case alternative"), - (601, yyparsing 601 "case alternative"), - (602, yyparsing 602 "list of case alternatives"), - (603, yyparsing 603 "case alternative"), - (604, yyparsing 604 "a top level expression"), - (605, yyparsing 605 "a top level expression"), - (606, yyparsing 606 "a list comprehension qualifier"), - (607, yyparsing 607 "list of expressions separated by ';'"), - (608, yyparsing 608 "list comprehension qualifiers"), - (609, yyparsing 609 "a qualified type"), - (610, yyparsing 610 "local declarations"), - (611, yyparsing 611 "a primary expression"), - (612, yyparsing 612 "a primary expression"), - (613, yyparsing 613 "a primary expression"), - (614, yyparsing 614 "field"), - (615, yyparsing 615 "field"), - (616, yyparsing 616 "a member import specification"), - (617, yyparsing 617 "an import item"), - (618, yyparsing 618 "a member import specification"), - (619, yyparsing 619 "a list of member imports"), - (620, yyparsing 620 "java token"), - (621, yyparsing 621 "java token"), - (622, yyparsing 622 "java token"), - (623, yyparsing 623 "java token"), - (624, yyparsing 624 "java token"), - (625, yyparsing 625 "java token"), - (626, yyparsing 626 "java token"), - (627, yyparsing 627 "java token"), + (561, yyexpect 561(yyfromCh '}')), + (562, yyparsing 562 "a primary expression"), + (563, yyparsing 563 "a primary expression"), + (564, yyparsing 564 "a primary expression"), + (565, yyparsing 565 "a primary expression"), + (566, yyparsing 566 "field"), + (567, yyparsing 567 "a primary expression"), + (568, yyparsing 568 "a primary expression"), + (569, yyparsing 569 "field"), + (570, yyparsing 570 "field"), + (571, yyparsing 571 "field list"), + (572, yyparsing 572 "a qualified variable name"), + (573, yyparsing 573 "a list of qualified variable names"), + (574, yyparsing 574 "a member import specification"), + (575, yyparsing 575 "an import item")]; + sub10 = [ (576, yyexpect 576(yyfromCh ')')), + (577, yyparsing 577 "a member import specification"), + (578, yyparsing 578 "a list of member imports"), + (579, yyparsing 579 "a list of import items"), + (580, yyparsing 580 "an import list"), + (581, yyparsing 581 "a non function type"), + (582, yyparsing 582 "java code"), + (583, yyparsing 583 "a list of types"), + (584, yyparsing 584 "a method type with optional throws clause"), + (585, yyparsing 585 "method types with optional throws clauses"), + (586, yyexpect 586(yyfromCh ')')), + (587, yyparsing 587 "a type kind"), + (588, yyparsing 588 "a type kind"), + (589, yyexpect 589(yyfromCh ')')), + (590, yyparsing 590 "a type kind"), + (591, yyparsing 591 "a type variable"), + (592, yyparsing 592 "a type variable"), + (593, yyparsing 593 "a constructor field"), + (594, yyexpect 594(yyfromCh '}')), + (595, yyparsing 595 "constructor fields"), + (596, yyparsing 596 "constructor field represented by a type"), + (597, yyparsing 597 "constructor field represented by a type"), + (598, yyparsing 598 "constructor fields represented by types"), + (599, yyparsing 599 "a native generic type"), + (600, yyparsing 600 "an algebraic datatype"), + (601, yyparsing 601 "a data definition for a native type"), + (602, yyparsing 602 "a type class declaration"), + (603, yyexpect 603(yyfromCh ')')), + (604, yyparsing 604 "a list of types separated by '|'"), + (605, yyexpect 605(yyfromCh ')')), + (606, yyparsing 606 "else branch"), + (607, yyparsing 607 "a top level expression"), + (608, yyparsing 608 "case alternative"), + (609, yyparsing 609 "case alternative"), + (610, yyparsing 610 "list of case alternatives"), + (611, yyparsing 611 "case alternative"), + (612, yyparsing 612 "a top level expression"), + (613, yyparsing 613 "a top level expression"), + (614, yyparsing 614 "a list comprehension qualifier"), + (615, yyparsing 615 "list of expressions separated by ';'"), + (616, yyparsing 616 "list comprehension qualifiers"), + (617, yyparsing 617 "a qualified type"), + (618, yyparsing 618 "local declarations"), + (619, yyparsing 619 "a primary expression"), + (620, yyparsing 620 "a primary expression"), + (621, yyparsing 621 "a primary expression"), + (622, yyparsing 622 "field"), + (623, yyparsing 623 "field"), + (624, yyparsing 624 "a member import specification"), + (625, yyparsing 625 "an import item"), + (626, yyparsing 626 "a member import specification"), + (627, yyparsing 627 "a list of member imports"), (628, yyparsing 628 "java token"), (629, yyparsing 629 "java token"), (630, yyparsing 630 "java token"), @@ -9809,94 +9890,102 @@ private yyrecs = let (667, yyparsing 667 "java token"), (668, yyparsing 668 "java token"), (669, yyparsing 669 "java token"), - (670, yyparsing 670 "java tokens"), - (671, yyparsing 671 "java code"), + (670, yyparsing 670 "java token"), + (671, yyparsing 671 "java token"), (672, yyparsing 672 "java token"), (673, yyparsing 673 "java token"), (674, yyparsing 674 "java token"), (675, yyparsing 675 "java token"), (676, yyparsing 676 "java token"), (677, yyparsing 677 "java token"), - (678, yyparsing 678 "java token"), - (679, yyparsing 679 "java token"), + (678, yyparsing 678 "java tokens"), + (679, yyparsing 679 "java code"), (680, yyparsing 680 "java token"), (681, yyparsing 681 "java token"), (682, yyparsing 682 "java token"), - (683, yyexpect 683(yyfromCh '}')), - (684, yyparsing 684 "java tokens"), - (685, yyparsing 685 "a type variable"), - (686, yyexpect 686(yyfromCh ')')), - (687, yyparsing 687 "a type variable"), - (688, yyparsing 688 "a type kind"), - (689, yyparsing 689 "a field specification"), - (690, yyparsing 690 "a field specification"), - (691, yyexpect 691(yyfromId VARID)), - (692, yyexpect 692(yyfromId VARID)), - (693, yyparsing 693 "a field specification"), - (694, yyexpect 694(yyfromId DCOLON)), - (695, yyparsing 695 "field specifications"), - (696, yyparsing 696 "a field specification"), + (683, yyparsing 683 "java token"), + (684, yyparsing 684 "java token"), + (685, yyparsing 685 "java token"), + (686, yyparsing 686 "java token"), + (687, yyparsing 687 "java token"), + (688, yyparsing 688 "java token"), + (689, yyparsing 689 "java token"), + (690, yyparsing 690 "java token"), + (691, yyexpect 691(yyfromCh '}')), + (692, yyparsing 692 "java tokens"), + (693, yyparsing 693 "a type variable"), + (694, yyexpect 694(yyfromCh ')')), + (695, yyparsing 695 "a type variable"), + (696, yyparsing 696 "a type kind"), (697, yyparsing 697 "a field specification"), - (698, yyparsing 698 "a variant of an algebraic datatype"), - (699, yyparsing 699 "constructor fields"), - (700, yyparsing 700 "constructor fields"), - (701, yyparsing 701 "a non function type"), - (702, yyparsing 702 "a list of types separated by '|'"), - (703, yyparsing 703 "a non function type")]; - sub12 = [ (704, yyparsing 704 "case alternative"), - (705, yyparsing 705 "list of case alternatives"), - (706, yyparsing 706 "a list of member imports"), - (707, yyparsing 707 "java tokens"), - (708, yyexpect 708(yyfromCh '}')), - (709, yyparsing 709 "java code"), - (710, yyparsing 710 "java tokens"), - (711, yyparsing 711 "a type kind"), - (712, yyparsing 712 "a type kind"), - (713, yyparsing 713 "a field specification"), - (714, yyparsing 714 "a field specification"), - (715, yyparsing 715 "a field specification"), - (716, yyparsing 716 "a field specification"), - (717, yyparsing 717 "a constructor field"), - (718, yyparsing 718 "field specifications"), - (719, yyparsing 719 "constructor fields"), - (720, yyparsing 720 "constructor fields"), - (721, yyparsing 721 "a list of types separated by '|'"), - (722, yyparsing 722 "java tokens"), - (723, yyparsing 723 "java tokens"), - (724, yyparsing 724 "a constructor field"), - (725, yyparsing 725 "field specifications"), - (726, yyparsing 726 "java tokens")]; + (698, yyparsing 698 "a field specification"), + (699, yyexpect 699(yyfromId VARID)), + (700, yyexpect 700(yyfromId VARID)), + (701, yyparsing 701 "a field specification"), + (702, yyexpect 702(yyfromId DCOLON)), + (703, yyparsing 703 "field specifications")]; + sub12 = [ (704, yyparsing 704 "a field specification"), + (705, yyparsing 705 "a field specification"), + (706, yyparsing 706 "a variant of an algebraic datatype"), + (707, yyparsing 707 "constructor fields"), + (708, yyparsing 708 "constructor fields"), + (709, yyparsing 709 "a non function type"), + (710, yyparsing 710 "a list of types separated by '|'"), + (711, yyparsing 711 "a non function type"), + (712, yyparsing 712 "case alternative"), + (713, yyparsing 713 "list of case alternatives"), + (714, yyparsing 714 "a list of member imports"), + (715, yyparsing 715 "java tokens"), + (716, yyexpect 716(yyfromCh '}')), + (717, yyparsing 717 "java code"), + (718, yyparsing 718 "java tokens"), + (719, yyparsing 719 "a type kind"), + (720, yyparsing 720 "a type kind"), + (721, yyparsing 721 "a field specification"), + (722, yyparsing 722 "a field specification"), + (723, yyparsing 723 "a field specification"), + (724, yyparsing 724 "a field specification"), + (725, yyparsing 725 "a constructor field"), + (726, yyparsing 726 "field specifications"), + (727, yyparsing 727 "constructor fields"), + (728, yyparsing 728 "constructor fields"), + (729, yyparsing 729 "a list of types separated by '|'"), + (730, yyparsing 730 "java tokens"), + (731, yyparsing 731 "java tokens"), + (732, yyparsing 732 "a constructor field"), + (733, yyparsing 733 "field specifications"), + (734, yyparsing 734 "java tokens")]; in sub1 `seq` sub2 `seq` sub3 `seq` sub4 `seq` sub5 `seq` sub6 `seq` sub7 `seq` sub8 `seq` sub9 `seq` sub10 `seq` sub11 `seq` sub12 `seq` arrayFromIndexList (sub1 ++ sub2 ++ sub3 ++ sub4 ++ sub5 ++ sub6 ++ sub7 ++ sub8 ++ sub9 ++ sub10 ++ sub11 ++ sub12); private yyeacts = let sub1 = [ (2, yyAccept), (4, (-19)), (5, (-17)), - (10, (-169)), + (10, (-170)), (11, (-12)), - (13, (-174)), - (14, (-175)), - (15, (-172)), - (16, (-170)), - (17, (-171)), - (18, (-173)), + (13, (-175)), + (14, (-176)), + (15, (-173)), + (16, (-171)), + (17, (-172)), + (18, (-174)), (19, (-15)), (21, (-20)), - (24, (-183)), + (24, (-184)), (26, (-114)), - (38, (-347)), - (39, (-348)), - (49, (-351)), - (50, (-350)), - (51, (-353)), - (52, (-354)), - (53, (-355)), - (54, (-356)), - (55, (-349)), - (56, (-357)), - (57, (-352)), - (61, (-192)), - (62, (-191)), - (64, (-426)), + (38, (-349)), + (39, (-350)), + (49, (-353)), + (50, (-352)), + (51, (-355)), + (52, (-356)), + (53, (-357)), + (54, (-358)), + (55, (-351)), + (56, (-359)), + (57, (-354)), + (61, (-193)), + (62, (-192)), + (64, (-428)), (66, (-26)), (67, (-29)), (68, (-30)), @@ -9911,375 +10000,379 @@ private yyeacts = let (77, (-118)), (78, (-119)), (79, (-120)), - (80, (-124)), + (80, (-121)), (81, (-125)), (82, (-126)), - (83, (-203)), - (84, (-424)), - (85, (-427)), - (90, (-210)), - (91, (-338)), - (94, (-425)), - (95, (-400)), - (96, (-396)), - (97, (-401)), - (98, (-402)), - (99, (-404)), - (101, (-410)), - (102, (-23)), - (107, (-14)), - (109, (-21)), - (110, (-184)), - (111, (-182)), - (113, (-185))]; - sub2 = [ (114, (-179)), - (115, (-142)), - (116, (-193)), - (117, (-195)), + (83, (-127)), + (84, (-204)), + (85, (-426)), + (86, (-429)), + (91, (-211)), + (92, (-340)), + (93, (-340)), + (96, (-427)), + (97, (-402)), + (98, (-398)), + (99, (-403)), + (100, (-404)), + (101, (-406)), + (103, (-412)), + (104, (-23)), + (109, (-14)), + (111, (-21)), + (112, (-185))]; + sub2 = [ (113, (-183)), + (115, (-186)), + (116, (-180)), + (117, (-143)), (118, (-194)), - (119, (-168)), - (121, (-190)), - (122, (-213)), + (119, (-196)), + (120, (-195)), + (121, (-169)), + (123, (-191)), (124, (-214)), - (125, (-212)), - (126, (-211)), - (130, (-293)), - (134, (-268)), - (135, (-338)), - (138, (-276)), - (139, (-279)), - (140, (-338)), - (141, (-35)), - (143, (-180)), - (146, (-388)), - (148, (-281)), - (152, (-32)), - (153, (-33)), - (154, (-34)), - (155, (-209)), - (156, (-395)), - (158, (-430)), - (165, (-441)), - (170, (-3)), - (171, (-27)), - (173, (-345)), - (175, (-405)), - (176, (-197)), - (177, (-198)), - (178, (-196)), - (179, (-199)), - (180, (-201)), - (184, (-282)), - (187, (-344)), - (188, (-376)), - (191, (-403)), - (195, (-1)), - (197, (-25)), - (198, (-13)), - (199, (-181)), - (200, (-178)), - (202, (-142)), - (203, (-142)), - (205, (-139)), - (212, (-5)), - (213, (-6)), - (215, (-7)), - (216, (-11)), - (218, (-215)), - (219, (-4)), - (220, (-216)), - (221, (-217)), - (223, (-220)), - (225, (-250)), - (235, (-264)), - (237, (-271)), - (242, (-255)), - (243, (-272)), - (244, (-244))]; - sub3 = [ (245, (-245)), - (247, (-280)), - (253, (-390)), - (258, (-134)), - (265, (-361)), - (268, (-447)), - (272, (-431)), - (274, (-440)), - (282, (-442)), - (284, (-385)), - (285, (-384)), - (286, (-407)), - (287, (-28)), - (289, (-428)), - (293, (-200)), - (295, (-202)), - (296, (-227)), - (297, (-228)), - (298, (-234)), - (299, (-233)), - (300, (-243)), - (301, (-319)), - (302, (-208)), - (307, (-343)), - (308, (-377)), - (309, (-393)), - (310, (-394)), - (311, (-412)), - (314, (-413)), - (315, (-414)), - (322, (-189)), - (324, (-188)), - (325, (-142)), - (326, (-141)), - (327, (-146)), - (331, (-144)), - (335, (-150)), - (336, (-153)), - (337, (-154)), - (338, (-155)), - (340, (-42)), - (341, (-237)), - (342, (-236)), - (345, (-206)), - (346, (-204)), - (347, (-205)), - (349, (-10)), - (351, (-288)), - (352, (-239)), - (354, (-218)), - (355, (-223)), - (356, (-224)), - (357, (-226)), - (361, (-310)), - (368, (-295)), - (369, (-300)), - (370, (-303)), - (371, (-309)), - (373, (-297)), - (374, (-284)), - (377, (-292)), - (378, (-298)), - (381, (-269)), - (384, (-277))]; - sub4 = [ (387, (-257)), - (390, (-256)), - (395, (-336)), - (397, (-434)), - (398, (-433)), - (399, (-432)), - (400, (-389)), - (402, (-387)), - (410, (-411)), - (411, (-435)), - (416, (-437)), - (417, (-436)), - (418, (-460)), - (421, (-443)), - (423, (-386)), - (424, (-341)), - (427, (-429)), - (432, (-320)), - (436, (-339)), - (438, (-127)), - (441, (-133)), - (443, (-359)), - (444, (-360)), - (452, (-418)), - (454, (-2)), - (456, (-187)), - (457, (-22)), - (459, (-140)), - (462, (-158)), - (463, (-145)), - (465, (-165)), - (466, (-166)), - (467, (-167)), - (468, (-157)), - (471, (-44)), - (473, (-40)), - (474, (-8)), - (475, (-9)), - (477, (-287)), - (487, (-318)), - (488, (-312)), - (489, (-313)), - (490, (-315)), - (491, (-302)), - (492, (-305)), - (493, (-306)), - (494, (-304)), - (495, (-308)), - (496, (-307)), - (497, (-301)), - (498, (-294)), - (499, (-283)), - (500, (-285)), - (501, (-289)), - (504, (-291)), - (505, (-267)), - (506, (-338)), - (507, (-275)), - (508, (-259)), - (509, (-246)), - (512, (-258)), - (513, (-249)), - (514, (-278)), - (515, (-337))]; - sub5 = [ (516, (-392)), - (519, (-358)), - (523, (-138)), - (526, (-371)), - (527, (-362)), - (528, (-369)), - (530, (-439)), - (531, (-438)), - (533, (-445)), - (534, (-444)), - (535, (-342)), - (536, (-457)), - (537, (-449)), - (538, (-231)), - (539, (-230)), - (541, (-234)), - (542, (-235)), - (543, (-232)), - (544, (-128)), - (545, (-129)), - (546, (-130)), - (547, (-132)), - (548, (-340)), - (550, (-373)), - (551, (-375)), - (555, (-422)), - (556, (-423)), - (557, (-417)), - (558, (-454)), - (559, (-415)), - (560, (-416)), - (561, (-455)), - (563, (-452)), - (564, (-186)), - (565, (-177)), - (567, (-152)), - (571, (-149)), - (572, (-143)), - (573, (-238)), - (575, (-240)), - (576, (-222)), - (577, (-225)), - (579, (-262)), - (583, (-253)), - (584, (-254)), - (588, (-317)), - (589, (-316)), - (590, (-314)), - (591, (-286)), - (592, (-299)), - (593, (-290)), - (594, (-270)), - (598, (-391)), - (599, (-397)), - (600, (-379)), - (603, (-380)), - (604, (-398)), - (605, (-399)), - (607, (-463)), - (608, (-365)), - (609, (-229)), - (610, (-123)), - (611, (-421)), - (612, (-419))]; - sub6 = [ (613, (-420)), - (616, (-161)), - (617, (-151)), - (618, (-160)), - (620, (-47)), - (621, (-48)), - (622, (-49)), - (623, (-52)), - (624, (-50)), - (625, (-51)), - (626, (-53)), - (627, (-54)), - (628, (-55)), - (629, (-56)), - (630, (-57)), - (631, (-58)), - (632, (-59)), - (633, (-60)), - (634, (-61)), - (635, (-62)), - (636, (-63)), - (637, (-64)), - (638, (-65)), - (639, (-66)), - (640, (-67)), - (641, (-68)), - (642, (-69)), - (643, (-70)), - (644, (-71)), - (645, (-72)), - (646, (-73)), - (647, (-74)), - (648, (-75)), - (649, (-76)), - (650, (-77)), - (651, (-78)), - (652, (-79)), - (653, (-80)), - (654, (-81)), - (655, (-82)), - (656, (-83)), - (657, (-84)), - (658, (-85)), - (659, (-86)), - (660, (-87)), - (661, (-88)), - (662, (-89)), - (663, (-90)), - (664, (-91)), - (665, (-92)), - (666, (-93)), - (667, (-94)), - (668, (-103)), - (669, (-104)), - (671, (-46)), - (672, (-101)), - (673, (-99)), - (674, (-100)), - (675, (-95)), - (676, (-96)), - (677, (-97)), - (678, (-98)), - (679, (-102)), - (680, (-105))]; - sub7 = [ (681, (-106)), - (682, (-107)), - (685, (-252)), - (687, (-251)), - (693, (-335)), - (696, (-329)), - (697, (-332)), - (698, (-311)), - (701, (-247)), - (703, (-248)), - (704, (-378)), - (705, (-382)), - (706, (-164)), - (709, (-45)), - (710, (-109)), - (711, (-263)), - (712, (-260)), - (713, (-331)), - (714, (-330)), - (715, (-334)), - (716, (-333)), - (719, (-325)), - (720, (-324)), - (721, (-242)), - (722, (-113)), - (724, (-326)), - (725, (-328)), - (726, (-111))]; + (126, (-215)), + (127, (-213)), + (128, (-212)), + (132, (-293)), + (136, (-269)), + (137, (-340)), + (140, (-277)), + (141, (-280)), + (142, (-340)), + (144, (-35)), + (146, (-181)), + (149, (-390)), + (151, (-282)), + (155, (-32)), + (156, (-33)), + (157, (-34)), + (158, (-210)), + (159, (-397)), + (161, (-432)), + (168, (-443)), + (173, (-3)), + (174, (-27)), + (176, (-347)), + (178, (-407)), + (179, (-198)), + (180, (-199)), + (181, (-197)), + (182, (-200)), + (183, (-202)), + (187, (-283)), + (188, (-284)), + (191, (-346)), + (192, (-378)), + (195, (-405)), + (199, (-1)), + (201, (-25)), + (202, (-13)), + (203, (-182)), + (204, (-179)), + (206, (-143)), + (207, (-143)), + (209, (-140)), + (216, (-5)), + (217, (-6)), + (219, (-7)), + (220, (-11)), + (222, (-216)), + (223, (-4)), + (224, (-217)), + (225, (-218)), + (227, (-221)), + (229, (-251)), + (239, (-265)), + (241, (-272))]; + sub3 = [ (246, (-256)), + (247, (-273)), + (248, (-245)), + (249, (-246)), + (251, (-281)), + (252, (-293)), + (258, (-392)), + (263, (-135)), + (270, (-363)), + (273, (-449)), + (277, (-433)), + (279, (-442)), + (287, (-444)), + (289, (-387)), + (290, (-386)), + (291, (-409)), + (292, (-28)), + (294, (-430)), + (298, (-201)), + (300, (-203)), + (301, (-228)), + (302, (-229)), + (303, (-235)), + (304, (-234)), + (305, (-244)), + (306, (-321)), + (307, (-209)), + (312, (-345)), + (313, (-379)), + (314, (-395)), + (315, (-396)), + (316, (-414)), + (319, (-415)), + (320, (-416)), + (327, (-190)), + (329, (-189)), + (330, (-143)), + (331, (-142)), + (332, (-147)), + (336, (-145)), + (340, (-151)), + (341, (-154)), + (342, (-155)), + (343, (-156)), + (345, (-42)), + (346, (-238)), + (347, (-237)), + (350, (-207)), + (351, (-205)), + (352, (-206)), + (354, (-10)), + (356, (-290)), + (357, (-240)), + (359, (-219)), + (360, (-224)), + (361, (-225)), + (362, (-227)), + (366, (-312)), + (373, (-295)), + (374, (-302)), + (375, (-305)), + (376, (-311)), + (378, (-299)), + (379, (-286))]; + sub4 = [ (382, (-292)), + (383, (-300)), + (386, (-270)), + (389, (-278)), + (392, (-258)), + (395, (-257)), + (402, (-338)), + (404, (-436)), + (405, (-435)), + (406, (-434)), + (407, (-391)), + (409, (-389)), + (417, (-413)), + (418, (-437)), + (423, (-439)), + (424, (-438)), + (425, (-462)), + (428, (-445)), + (430, (-388)), + (431, (-343)), + (434, (-431)), + (439, (-322)), + (443, (-341)), + (445, (-128)), + (448, (-134)), + (450, (-361)), + (451, (-362)), + (459, (-420)), + (461, (-2)), + (463, (-188)), + (464, (-22)), + (466, (-141)), + (469, (-159)), + (470, (-146)), + (472, (-166)), + (473, (-167)), + (474, (-168)), + (475, (-158)), + (478, (-44)), + (480, (-40)), + (481, (-8)), + (482, (-9)), + (484, (-289)), + (494, (-320)), + (495, (-314)), + (496, (-315)), + (497, (-317)), + (498, (-304)), + (499, (-307)), + (500, (-308)), + (501, (-306)), + (502, (-310)), + (503, (-309)), + (504, (-303)), + (505, (-294)), + (506, (-285)), + (507, (-287)), + (508, (-296)), + (511, (-291)), + (512, (-268)), + (513, (-340)), + (514, (-276)), + (515, (-260)), + (516, (-247))]; + sub5 = [ (519, (-259)), + (520, (-250)), + (521, (-279)), + (523, (-339)), + (524, (-394)), + (527, (-360)), + (531, (-139)), + (534, (-373)), + (535, (-364)), + (536, (-371)), + (538, (-441)), + (539, (-440)), + (541, (-447)), + (542, (-446)), + (543, (-344)), + (544, (-459)), + (545, (-451)), + (546, (-232)), + (547, (-231)), + (549, (-235)), + (550, (-236)), + (551, (-233)), + (552, (-129)), + (553, (-130)), + (554, (-131)), + (555, (-133)), + (556, (-342)), + (558, (-375)), + (559, (-377)), + (563, (-424)), + (564, (-425)), + (565, (-419)), + (566, (-456)), + (567, (-417)), + (568, (-418)), + (569, (-457)), + (571, (-454)), + (572, (-187)), + (573, (-178)), + (575, (-153)), + (579, (-150)), + (580, (-144)), + (581, (-239)), + (583, (-241)), + (584, (-223)), + (585, (-226)), + (587, (-263)), + (591, (-254)), + (592, (-255)), + (596, (-319)), + (597, (-318)), + (598, (-316)), + (599, (-288)), + (600, (-301)), + (601, (-297)), + (602, (-271)), + (606, (-393)), + (607, (-399)), + (608, (-381)), + (611, (-382)), + (612, (-400)), + (613, (-401)), + (615, (-465)), + (616, (-367))]; + sub6 = [ (617, (-230)), + (618, (-124)), + (619, (-423)), + (620, (-421)), + (621, (-422)), + (624, (-162)), + (625, (-152)), + (626, (-161)), + (628, (-47)), + (629, (-48)), + (630, (-49)), + (631, (-52)), + (632, (-50)), + (633, (-51)), + (634, (-53)), + (635, (-54)), + (636, (-55)), + (637, (-56)), + (638, (-57)), + (639, (-58)), + (640, (-59)), + (641, (-60)), + (642, (-61)), + (643, (-62)), + (644, (-63)), + (645, (-64)), + (646, (-65)), + (647, (-66)), + (648, (-67)), + (649, (-68)), + (650, (-69)), + (651, (-70)), + (652, (-71)), + (653, (-72)), + (654, (-73)), + (655, (-74)), + (656, (-75)), + (657, (-76)), + (658, (-77)), + (659, (-78)), + (660, (-79)), + (661, (-80)), + (662, (-81)), + (663, (-82)), + (664, (-83)), + (665, (-84)), + (666, (-85)), + (667, (-86)), + (668, (-87)), + (669, (-88)), + (670, (-89)), + (671, (-90)), + (672, (-91)), + (673, (-92)), + (674, (-93)), + (675, (-94)), + (676, (-103)), + (677, (-104)), + (679, (-46)), + (680, (-101)), + (681, (-99)), + (682, (-100)), + (683, (-95)), + (684, (-96))]; + sub7 = [ (685, (-97)), + (686, (-98)), + (687, (-102)), + (688, (-105)), + (689, (-106)), + (690, (-107)), + (693, (-253)), + (695, (-252)), + (701, (-337)), + (704, (-331)), + (705, (-334)), + (706, (-313)), + (709, (-248)), + (711, (-249)), + (712, (-380)), + (713, (-384)), + (714, (-165)), + (717, (-45)), + (718, (-109)), + (719, (-264)), + (720, (-261)), + (721, (-333)), + (722, (-332)), + (723, (-336)), + (724, (-335)), + (727, (-327)), + (728, (-326)), + (729, (-243)), + (730, (-113)), + (732, (-328)), + (733, (-330)), + (734, (-111))]; in sub1 `seq` sub2 `seq` sub3 `seq` sub4 `seq` sub5 `seq` sub6 `seq` sub7 `seq` arrayFromIndexList (sub1 ++ sub2 ++ sub3 ++ sub4 ++ sub5 ++ sub6 ++ sub7); @@ -10291,218 +10384,222 @@ decodeArr s1 s2 = arrayFromIndexList (zip (un s1) (un s2)) private yygo0 = decodeArr "\u0001\u0002\u0003\u0010\u0011\u0012\u0013" "\u0002\u0002\u0002\u0004\u0004\u0003\u0003"; private yygo1 = decodeArr "\u0010\u0011" "\u0005\u0005"; private yygo3 = decodeArr "\u0014\u0015\u0016" "\t\t\t"; -private yygo6 = decodeArr "\f\r\u000e\u000f©ª«¬­®¯" "\u0013\u0013\u0013\u0015\u0014\u0014\u0014\u0014\u0014\u0014\u0014"; -private yygo8 = decodeArr "\u001a\u001b\u001c\u001d\u001e\u001f !\"#$%&'(rstuvwx|}~\u008b\u008c\u008d¨²³´µ¶·¿ÀÁÂÃÉÊËÌÍÎÏÐÑÒâĎďĘęĚġĢģĤĥĦħŐőŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "AAABBBEEEEDDDDJCFFFFFFOOOHHHSTTTUUUVVWWWIPYYYYXXQQZLLMNG[[[[[[[KKRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo9 = decodeArr "\u0017\u0018\u0019" "jii"; -private yygo12 = decodeArr "\f\r\u000e©ª«¬­®¯" "kkk\u0014\u0014\u0014\u0014\u0014\u0014\u0014"; -private yygo22 = decodeArr "\f\r\u000e\u000f©ª«¬­®¯" "\u0013\u0013\u0013m\u0014\u0014\u0014\u0014\u0014\u0014\u0014"; -private yygo25 = decodeArr "¸¹¿À" "rrqq"; -private yygo27 = decodeArr "\f\r\u000e\u000f©ª«¬­®¯" "\u0013\u0013\u0013s\u0014\u0014\u0014\u0014\u0014\u0014\u0014"; -private yygo31 = decodeArr "¨¾¿ÀËÌÍÎÓÔÕÖÚÛÜÝ" "S|}}~~~~\u007f\u007f\u007f\u007f\u0080\u0080\u0080\u0080"; -private yygo34 = decodeArr "µ¶·ĈČč" "\u0085\u0085\u0085\u0086\u0087\u0087"; -private yygo35 = decodeArr "µ¶·ĐĔĕĖė" "\u0089\u0089\u0089\u008a\u008b\u008b\u008c\u008c"; -private yygo36 = decodeArr "ĚġĢģĤĥĦħ" "\u008d[[[[[[["; -private yygo40 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_\u0091\u0091\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo41 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_\u0093\u0093\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo42 = decodeArr "µ¶·ĐĔĕĖė" "\u0089\u0089\u0089\u008a\u008b\u008b\u0094\u0094"; -private yygo45 = decodeArr "stuvwx|}~¨²³´µ¶·¿ÀÊËÌÍÎÏÐÑÒâĎďĘęĚġĢģĤĥĦħŐőŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "\u0098\u0098\u0098\u0098\u0098\u0098OOOSTTTUUUVVPYYYYXXQQZLLMNG[[[[[[[KKRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo46 = decodeArr "stuvwx|}~¨²³´µ¶·¿ÀÊËÌÍÎÏÐÑÒâĎďĘęĚġĢģĤĥĦħŐőŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "\u0099\u0099\u0099\u0099\u0099\u0099OOOSTTTUUUVVPYYYYXXQQZLLMNG[[[[[[[KKRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo47 = decodeArr "stuvwx|}~¨²³´µ¶·¿ÀÊËÌÍÎÏÐÑÒâĎďĘęĚġĢģĤĥĦħŐőŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "\u009a\u009a\u009a\u009a\u009a\u009aOOOSTTTUUUVVPYYYYXXQQZLLMNG[[[[[[[KKRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo48 = decodeArr "â" "\u009b"; -private yygo58 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_\u009c\u009c\u009c\u009c\u009caabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo59 = decodeArr "²³´µ¶·¾¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "TTTUUU ¡¡^^^^^^^^^^^_££¤¤¤¤`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee¢¢"; -private yygo60 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽNjnjǍ" "TTTUUUVV^^^^^^^^^^^_¦¦\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee§§§"; -private yygo63 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƔƕƖƗƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^©©¨¨ddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo82 = decodeArr "ŕŖ" "­­"; -private yygo86 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^¯¯ddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo87 = decodeArr "¾ÄÅÆÇÈ" "²³³³´´"; -private yygo91 = decodeArr "ŒœŔ" "¸¸¸"; -private yygo92 = decodeArr "ŷŸŹ" "¼»»"; -private yygo97 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^¿¿ddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo104 = decodeArr "\u001a\u001b\u001c\u001d\u001e\u001f !\"#$%&'(rstuvwx|}~\u008b\u008c\u008d¨²³´µ¶·¿ÀÁÂÃÉÊËÌÍÎÏÐÑÒâĎďĘęĚġĢģĤĥĦħŐőŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ÃÃÃBBBEEEEDDDDJCFFFFFFOOOHHHSTTTUUUVVWWWIPYYYYXXQQZLLMNG[[[[[[[KKRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo106 = decodeArr "\u0017\u0018\u0019" "jÅÅ"; -private yygo108 = decodeArr "\f\r\u000e©ª«¬­®¯" "ÆÆÆ\u0014\u0014\u0014\u0014\u0014\u0014\u0014"; -private yygo112 = decodeArr "¸¹¿À" "ÈÈqq"; -private yygo115 = decodeArr "\u008e\u008f\u0090\u0091\u0092¨" "ÍÍÍÍÍÎ"; -private yygo120 = decodeArr ")*" "ÐÐ"; -private yygo123 = decodeArr "¾¿À" "ÒÓÓ"; -private yygo127 = decodeArr "\u0004\u0005\u0006\u0007\b\t\n\u000b¾¿À×ØÙğĠ" "ÚÛÛÛÛÛÛÛÜÝÝÞÞÞßß"; -private yygo129 = decodeArr "úûüýþĨĩ" "åååååää"; -private yygo130 = decodeArr "úûüýþĨĩ" "åååååçç"; -private yygo132 = decodeArr "µ¶·ĈĉĊċ" "\u0085\u0085\u0085éêêê"; -private yygo133 = decodeArr "úûüýþ" "ëëëëë"; -private yygo135 = decodeArr "ŒœŔ" "ííí"; -private yygo136 = decodeArr "µ¶·ĐđĒē" "\u0089\u0089\u0089îïïï"; -private yygo137 = decodeArr "µ¶·ôõö÷øùúûüýþÿĀāĂă" "òòòóóóóóóôôôôôõõõõõ"; -private yygo140 = decodeArr "ŒœŔ" "÷÷÷"; -private yygo142 = decodeArr "úûüýþĨĩ" "åååååùù"; -private yygo144 = decodeArr "²³´µ¶·¾¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "TTTUUUûüü^^^^^^^^^^^_££¤¤¤¤`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee¢¢"; -private yygo145 = decodeArr "ƅƆ" "ÿÿ"; -private yygo149 = decodeArr "\u0086\u0087\u0088\u0089\u008a¨²³´µ¶·¿ÀÊËÌÍÎÏÐŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ĄĄąąąSTTTUUUVVĂYYYYXXăăă\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo150 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťũŪūůŰűŲųƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^ĈĈĈĊĊĊĉĉ_ćć\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo151 = decodeArr "¨¾¿ÀËÌÍÎÓÔÕÖÚÛÜÝ" "S|}}~~~~\u007f\u007f\u007f\u007f\u0080\u0080\u0080\u0080"; -private yygo157 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_\u009c\u009c\u009c\u009c\u009caabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo159 = decodeArr "ƾƿ" "ČČ"; -private yygo160 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ĎĎ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo161 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^¯¯ddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo164 = decodeArr "¾" "Ė"; -private yygo168 = decodeArr "ƀƁƂ" "Ĝĝĝ"; -private yygo169 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƔƕƖƗƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^©©ĞĞddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo171 = decodeArr "\u001a\u001b\u001c\u001d\u001e\u001f !\"#$%&'(rstuvwx|}~\u008b\u008c\u008d¨²³´µ¶·¿ÀÁÂÃÉÊËÌÍÎÏÐÑÒâĎďĘęĚġĢģĤĥĦħŐőŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ğğğBBBEEEEDDDDJCFFFFFFOOOHHHSTTTUUUVVWWWIPYYYYXXQQZLLMNG[[[[[[[KKRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo174 = decodeArr "¨ǀǁǂljNJ" "ĢģģģĤĤ"; -private yygo179 = decodeArr "¾ÄÅÆÇÈ" "²³³³ĥĥ"; -private yygo181 = decodeArr "µ¶·ãäåèéêëóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòħħĨĩĩīīĪĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo182 = decodeArr "¨ËÌÍÎÏÐ" "SYYYYĮĮ"; -private yygo185 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťŲųŴŵŶƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^ııIJIJIJ_İİ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo186 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ijij\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo188 = decodeArr "ŷŸŹ" "¼ĴĴ"; -private yygo189 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ĵĵĵĵ`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo190 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ĶĶĶĶ`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo192 = decodeArr "¾¿À" "ĺĻĻ"; -private yygo193 = decodeArr "ǃDŽDždžLJLj" "ĽĽĽľľľ"; -private yygo194 = decodeArr "\u001a\u001b\u001c\u001d\u001e\u001f !\"#$%&'(rstuvwx|}~\u008b\u008c\u008d¨²³´µ¶·¿ÀÁÂÃÉÊËÌÍÎÏÐÑÒâĎďĘęĚġĢģĤĥĦħŐőŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ĿĿĿBBBEEEEDDDDJCFFFFFFOOOHHHSTTTUUUVVWWWIPYYYYXXQQZLLMNG[[[[[[[KKRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo196 = decodeArr "°±¸¹º»¼½¾¿À" "ŁŁńńŃŃŃŃłqq"; -private yygo202 = decodeArr "\u008e\u008f\u0090\u0091\u0092¨" "ņņņņņÎ"; -private yygo203 = decodeArr "\u008e\u008f\u0090\u0091\u0092¨" "ŇŇŇŇŇÎ"; -private yygo204 = decodeArr "\u0093\u0094\u0095\u0096\u0097\u0098\u0099\u009a\u009b\u009c\u009d\u009e²³´µ¶·¾¿À" "ŌŌŌŎŎŎŎŎŎōōōŏŏŏŐŐŐőŒŒ"; -private yygo207 = decodeArr "µ¶·åìíîóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòŕŔŔŔŖĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo208 = decodeArr "+," "ŘŘ"; -private yygo214 = decodeArr "\u0005\u0006\u0007\b\t\n\u000b" "ŝŝŝŝŝŝŝ"; -private yygo217 = decodeArr "µ¶·åìíîïðóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòò੩ŠššŖĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo222 = decodeArr "ğĠ" "ŢŢ"; -private yygo224 = decodeArr "µ¶·Þßàáãäåèéêëóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòŤŤťťţţĨĩĩīīĪĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo227 = decodeArr "ĬĭĮįİıIJijĴĵĶķĸ" "ŰŰŰűűűűŲŲŲųųų"; -private yygo229 = decodeArr "úûüýþĨĩ" "åååååŵŵ"; -private yygo230 = decodeArr "ěĜĪīĬĭĮįİıIJijĴĵĶķĸ" "ŸŸŹŹźźźűűűűŲŲŲųųų"; -private yygo240 = decodeArr "µ¶·åìíîóôõö÷øùúûüýþÿĀāĂăĿŀƾƿ" "òòòŕƄƄƄŖĭĭĭĭĭĭôôôôôõõõõõĬĬƅƅ"; -private yygo241 = decodeArr "µ¶·åìíîóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòŕƇƇƇŖĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo246 = decodeArr "µ¶·ÿĀāĂă" "òòòƊƊƊƊƊ"; -private yygo248 = decodeArr "µ¶·ãäåèéêëóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòƋƋĨĩĩīīĪĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo250 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_\u009c\u009c\u009c\u009c\u009caabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo251 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ĎĎ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo252 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^¯¯ddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo255 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ƑƑ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo256 = decodeArr "µ¶·ãäåèéêëóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòƒƒĨĩĩīīĪĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo259 = decodeArr "ŕŖ" "­­"; -private yygo273 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽǎǏǐ" "TTTUUUVV^^^^^^^^^^^_ƜƜ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeeeƝƝƝ"; -private yygo275 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽNjnjǍ" "TTTUUUVV^^^^^^^^^^^_ƞƞ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeeeƟƟƟ"; -private yygo276 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ĵĵĵĵ`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo277 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ĶĶĶĶ`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo279 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽNjnjǍ" "TTTUUUVV^^^^^^^^^^^_ƞƞ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeeeƢƢƢ"; -private yygo280 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťũŪūŬŭŮŲųƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^ƣƣƣƤƤƤĉĉ_ćć\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo281 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ƦƦ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo283 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ƧƧ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo288 = decodeArr "\u0086\u0087\u0088\u0089\u008a¨²³´µ¶·¿ÀÊËÌÍÎÏÐŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ĄĄƩƩƩSTTTUUUVVĂYYYYXXăăă\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo294 = decodeArr "úûüýþĨĩ" "åååååƭƭ"; -private yygo301 = decodeArr "µ¶·ôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòĭĭĭĭĭĭôôôôôõõõõõưư"; -private yygo303 = decodeArr "ryz{|}~\u007f\u0080\u0081\u0082\u0083\u0084\u0085¨²³´µ¶·¿ÀÊËÌÍÎÏÐÑÒâŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ƵƷƷƷƶƶƶƹƹƹƹƸƸƸSTTTUUUVVPYYYYXXQQZRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo306 = decodeArr "ŧŨ" "ƽƽ"; -private yygo312 = decodeArr "ǃDŽDždžLJLj" "ƿƿƿľľľ"; -private yygo313 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ǀǀ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo320 = decodeArr "¸¹¿À" "LjLjqq"; -private yygo325 = decodeArr "\u008e\u008f\u0090\u0091\u0092¨" "NjNjNjNjNjÎ"; -private yygo329 = decodeArr "¸¹¿À" "rrqq"; -private yygo330 = decodeArr "\u0096\u0097\u0098\u0099\u009a\u009b\u009c\u009d\u009e²³´µ¶·¾¿À" "ŎŎŎŎŎŎǎǎǎŏŏŏŐŐŐőŒŒ"; -private yygo334 = decodeArr "¥¦§¾" "ǔǔǔǓ"; -private yygo339 = decodeArr "\u0093\u0094\u0095\u0096\u0097\u0098\u0099\u009a\u009b\u009c\u009d\u009e²³´µ¶·¾¿À" "ǕǕǕŎŎŎŎŎŎōōōŏŏŏŐŐŐőŒŒ"; -private yygo343 = decodeArr "µ¶·åìíîïðóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòò੩ŠǗǗŖĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo344 = decodeArr "-." "ǙǙ"; -private yygo348 = decodeArr "\u0005\u0006\u0007\b\t\n\u000b" "ǚǚǚǚǚǚǚ"; -private yygo350 = decodeArr "\u0005\u0006\u0007\b\t\n\u000b" "ǛǛǛǛǛǛǛ"; -private yygo359 = decodeArr "µ¶·åìíîïðóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòò੩ŠǢǢŖĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo360 = decodeArr "µ¶·óôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòǣĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo361 = decodeArr "µ¶·ôõö÷øùúûüýþÿĀāĂăĹĺĻļĽľ" "òòòǧǧǧǧǧǧôôôôôõõõõõǨǨǩǩǩǪ"; -private yygo362 = decodeArr "įİıIJijĴĵĶķĸ" "ǫǫǫǫŲŲŲųųų"; -private yygo363 = decodeArr "ijĴĵĶķĸ" "ǬǬǬųųų"; -private yygo364 = decodeArr "ijĴĵĶķĸ" "ǭǭǭųųų"; -private yygo365 = decodeArr "ijĴĵĶķĸ" "ǮǮǮųųų"; -private yygo366 = decodeArr "Ķķĸ" "ǯǯǯ"; -private yygo367 = decodeArr "Ķķĸ" "ǰǰǰ"; -private yygo372 = decodeArr "ĬĭĮįİıIJijĴĵĶķĸ" "DzDzDzűűűűŲŲŲųųų"; -private yygo376 = decodeArr "\u0004\u0005\u0006\u0007\b\t\n\u000bĝĞ" "ǴÛÛÛÛÛÛÛǵǵ"; -private yygo379 = decodeArr "ěĜĪīĬĭĮįİıIJijĴĵĶķĸ" "ǷǷǸǸźźźűűűűŲŲŲųųų"; -private yygo380 = decodeArr "µ¶·ĈĉĊċ" "\u0085\u0085\u0085éǹǹǹ"; -private yygo382 = decodeArr "úûüýþ" "ǺǺǺǺǺ"; -private yygo383 = decodeArr "µ¶·ĐđĒē" "\u0089\u0089\u0089îǻǻǻ"; -private yygo392 = decodeArr "ƾƿ" "ƅƅ"; -private yygo394 = decodeArr "µ¶·ôõö÷øùúûüýþÿĀāĂă" "òòòȂȂȂȂȂȂôôôôôõõõõõ"; -private yygo396 = decodeArr "µ¶·ãäåèéêëóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòȃȃĨĩĩīīĪĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo401 = decodeArr "Ƈƈ" "ȆȆ"; -private yygo403 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťŦźŻżŽžſƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^ȈȉȉȉȊȊȊ_ȇȇ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo404 = decodeArr "\u0086\u0087\u0088\u0089\u008a¨²³´µ¶·¿ÀÊËÌÍÎÏÐŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ĄĄȋȋȋSTTTUUUVVĂYYYYXXăăă\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo406 = decodeArr "\u0086\u0087\u0088\u0089\u008a¨²³´µ¶·¿ÀÊËÌÍÎÏÐŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ĄĄȍȍȍSTTTUUUVVĂYYYYXXăăă\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo407 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ȎȎ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo408 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ȏȏ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo409 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťũŪūůŰűŲųƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^ĈĈĈȐȐȐĉĉ_ćć\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo426 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ȘȘ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo428 = decodeArr "¨ǀǁǂljNJ" "ĢșșșĤĤ"; -private yygo429 = decodeArr "æç" "ȜȜ"; -private yygo430 = decodeArr "µ¶·êëóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòȞȞȝĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo431 = decodeArr "µ¶·êëóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòȟȟȝĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo433 = decodeArr "|}~¨²³´µ¶·¿ÀÊËÌÍÎÏÐÑÒâŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ȠȠȠSTTTUUUVVPYYYYXXQQZRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo434 = decodeArr "|}~¨²³´µ¶·¿ÀÊËÌÍÎÏÐÑÒâŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ȡȡȡSTTTUUUVVPYYYYXXQQZRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo435 = decodeArr "|}~¨²³´µ¶·¿ÀÊËÌÍÎÏÐÑÒâŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ȢȢȢSTTTUUUVVPYYYYXXQQZRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo437 = decodeArr "r|}~\u007f\u0080\u0081\u0082\u0083\u0084\u0085¨²³´µ¶·¿ÀÊËÌÍÎÏÐÑÒâŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ƵƶƶƶƹƹƹƹȣȣȣSTTTUUUVVPYYYYXXQQZRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo442 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťŲųŴŵŶƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^ııȦȦȦ_İİ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo445 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ȧȧ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo449 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ȮȮ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo451 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ȱȱ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo453 = decodeArr "ǃDŽDždžLJLj" "ȳȳȳľľľ"; -private yygo455 = decodeArr "¸¹¿À" "ȴȴqq"; -private yygo458 = decodeArr "°±¸¹º»¼½¾¿À" "ȵȵńńŃŃŃŃłqq"; -private yygo460 = decodeArr "\u009f ¡¢£¤¥¦§¾" "ȺȺȺȸȸȸȹȹȹǓ"; -private yygo461 = decodeArr "¸¹¿À" "ÈÈqq"; -private yygo464 = decodeArr "\u0093\u0094\u0095\u0096\u0097\u0098\u0099\u009a\u009b\u009c\u009d\u009e²³´µ¶·¾¿À" "ȻȻȻŎŎŎŎŎŎōōōŏŏŏŐŐŐőŒŒ"; -private yygo470 = decodeArr "µ¶·åìíîóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòŕȽȽȽŖĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo476 = decodeArr "µ¶·åìíîïðóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòò੩ŠȿȿŖĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo478 = decodeArr "µ¶·åìíîïðóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòò੩ŠɀɀŖĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo479 = decodeArr "µ¶·Þßàáãäåèéêëóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòŤŤɁɁţţĨĩĩīīĪĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo480 = decodeArr "µ¶·åìíîïðóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòò੩ŠɂɂŖĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo481 = decodeArr "ĄąĆć" "ɅɅɆɆ"; -private yygo484 = decodeArr "\u0010\u0011\u0012\u0013ŁłŃńŅņ" "\u0004\u0004ɉɉɊɊɊɊɊɋ"; -private yygo485 = decodeArr "µ¶·ôõö÷øùúûüýþÿĀāĂăľ" "òòòǧǧǧǧǧǧôôôôôõõõõõɌ"; -private yygo486 = decodeArr "µ¶·ôõö÷øùúûüýþÿĀāĂăľ" "òòòǧǧǧǧǧǧôôôôôõõõõõɍ"; -private yygo489 = decodeArr "µ¶·ôõö÷øùúûüýþÿĀāĂăĹĺĻļĽľ" "òòòǧǧǧǧǧǧôôôôôõõõõõɎɎǩǩǩǪ"; -private yygo500 = decodeArr "ğĠ" "ɏɏ"; -private yygo502 = decodeArr "ĪīĬĭĮįİıIJijĴĵĶķĸ" "ɐɐźźźűűűűŲŲŲųųų"; -private yygo503 = decodeArr "\u0004\u0005\u0006\u0007\b\t\n\u000bĝĞ" "ǴÛÛÛÛÛÛÛɑɑ"; -private yygo506 = decodeArr "ŒœŔ" "ɒɒɒ"; -private yygo510 = decodeArr "µ¶·åìíîïðóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòò੩ŠɓɓŖĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo511 = decodeArr "µ¶·åìíîñòóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòŕɔɔɔɕɕŖĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo518 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ɗɗ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo520 = decodeArr "ŧŨŷŸŹ" "əə¼ɘɘ"; -private yygo521 = decodeArr "ŕŖ" "ɛɛ"; -private yygo524 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ɝɝ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo529 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽǎǏǐ" "TTTUUUVV^^^^^^^^^^^_ƜƜ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeeeɟɟɟ"; -private yygo532 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťũŪūŬŭŮŲųƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^ƣƣƣɠɠɠĉĉ_ćć\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo540 = decodeArr "µ¶·èéêëóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòɡɡīīĪĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo549 = decodeArr "ryz{|}~\u007f\u0080\u0081\u0082\u0083\u0084\u0085¨²³´µ¶·¿ÀÊËÌÍÎÏÐÑÒâŗŘřŚśŜŝŞşŠšŢţŤťƀƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "ƵɢɢɢƶƶƶƹƹƹƹƸƸƸSTTTUUUVVPYYYYXXQQZRRR\\^^^^^^^^^^^_]]]]`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo552 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ȮȮ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo554 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ȱȱ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo566 = decodeArr "\u009f ¡¥¦§¾" "ɨɨɨȹȹȹǓ"; -private yygo569 = decodeArr "¥¦§¾" "ɪɪɪǓ"; -private yygo574 = decodeArr "/0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopq" "ʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʫʫʫʫʫʫ"; -private yygo580 = decodeArr "ĄąĆć" "ʮʮɆɆ"; -private yygo585 = decodeArr "¨ŇňʼnŊŋŌōŎŏ" "ʵʶʶʷʷʷʸʸʸʹ"; -private yygo601 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ˀˀ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo602 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťŦźŻżŽžſƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^Ȉȉȉȉˁˁˁ_ȇȇ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo614 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ȮȮ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo615 = decodeArr "²³´µ¶·¿ÀśŜŝŞşŠšŢţŤťƀƃƄƉƊƋƌƍƎƏƐƑƒƓƔƕƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽ" "TTTUUUVV^^^^^^^^^^^_ȱȱ\u0092\u0092\u0092\u0092`````aabbddcccccccccccccceeeeeeeeeeeeeeeeeeeeee"; -private yygo619 = decodeArr "\u009f ¡¢£¤¥¦§¾" "ȺȺȺ˂˂˂ȹȹȹǓ"; -private yygo670 = decodeArr "/0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopq" "ʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬ˄˄˄˄˄˄"; -private yygo684 = decodeArr "/0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopq" "ʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬˆˆˆˆˆˆ"; -private yygo688 = decodeArr "ĄąĆć" "ˈˈɆɆ"; -private yygo689 = decodeArr "¨ŌōŎŏ" "ʵˉˉˉʹ"; -private yygo690 = decodeArr "¨ŌōŎŏ" "ʵˊˊˊʹ"; -private yygo691 = decodeArr "¨ŏ" "ʵˋ"; -private yygo692 = decodeArr "¨ŏ" "ʵˌ"; -private yygo699 = decodeArr "\u0010\u0011\u0012\u0013ŁłŃńŅņ" "\u0004\u0004ɉɉˏˏˏˏˏɋ"; -private yygo700 = decodeArr "\u0010\u0011\u0012\u0013ŁłŃńŅņ" "\u0004\u0004ɉɉːːːːːɋ"; -private yygo702 = decodeArr "µ¶·åìíîñòóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòòŕɔɔɔˑˑŖĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo707 = decodeArr "/0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopq" "ʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬ˒˒˒˒˒˒"; -private yygo717 = decodeArr "µ¶·ãäåèéêëóôõö÷øùúûüýþÿĀāĂăĿŀ" "òòò˔˔ĨĩĩīīĪĭĭĭĭĭĭôôôôôõõõõõĬĬ"; -private yygo718 = decodeArr "¨ŇňʼnŊŋŌōŎŏ" "ʵ˕˕ʷʷʷʸʸʸʹ"; -private yygo723 = decodeArr "/0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopq" "ʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬʬ˖˖˖˖˖˖"; +private yygo6 = decodeArr "\f\r\u000e\u000fª«¬­®¯°" "\u0013\u0013\u0013\u0015\u0014\u0014\u0014\u0014\u0014\u0014\u0014"; +private yygo8 = decodeArr "\u001a\u001b\u001c\u001d\u001e\u001f !\"#$%&'(rstuvwxy}~\u007f\u008c\u008d\u008e©³´µ¶·¸ÀÁÂÃÄÊËÌÍÎÏÐÑÒÓãďĐęĚěĜģĤĥĦħĨĩŒœřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "AAABBBEEEEDDDDJCFFFFFFFPPPHHHTUUUVVVWWXXXIQZZZZYYRR[MMNOGL\\\\\\\\\\]]KKSSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo9 = decodeArr "\u0017\u0018\u0019" "lkk"; +private yygo12 = decodeArr "\f\r\u000eª«¬­®¯°" "mmm\u0014\u0014\u0014\u0014\u0014\u0014\u0014"; +private yygo22 = decodeArr "\f\r\u000e\u000fª«¬­®¯°" "\u0013\u0013\u0013o\u0014\u0014\u0014\u0014\u0014\u0014\u0014"; +private yygo25 = decodeArr "¹ºÀÁ" "ttss"; +private yygo27 = decodeArr "\f\r\u000e\u000fª«¬­®¯°" "\u0013\u0013\u0013u\u0014\u0014\u0014\u0014\u0014\u0014\u0014"; +private yygo31 = decodeArr "©¿ÀÁÌÍÎÏÔÕÖ×ÛÜÝÞ" "T~\u007f\u007f\u0080\u0080\u0080\u0080\u0081\u0081\u0081\u0081\u0082\u0082\u0082\u0082"; +private yygo34 = decodeArr "¶·¸ĉčĎ" "\u0087\u0087\u0087\u0088\u0089\u0089"; +private yygo35 = decodeArr "¶·¸đĕĖėĘ" "\u008b\u008b\u008b\u008c\u008d\u008d\u008e\u008e"; +private yygo36 = decodeArr "ěģĤĥĦħ" "\u0090\\\\\\\\\\"; +private yygo40 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````a\u0094\u0094\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo41 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````a\u0096\u0096\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo42 = decodeArr "¶·¸đĕĖėĘ" "\u008b\u008b\u008b\u008c\u008d\u008d\u0097\u0097"; +private yygo45 = decodeArr "stuvwxy}~\u007f©³´µ¶·¸ÀÁËÌÍÎÏÐÑÒÓãďĐęĚěĜģĤĥĦħĨĩŒœřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "\u009b\u009b\u009b\u009b\u009b\u009b\u009bPPPTUUUVVVWWQZZZZYYRR[MMNOGL\\\\\\\\\\]]KKSSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo46 = decodeArr "stuvwxy}~\u007f©³´µ¶·¸ÀÁËÌÍÎÏÐÑÒÓãďĐęĚěĜģĤĥĦħĨĩŒœřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "\u009c\u009c\u009c\u009c\u009c\u009c\u009cPPPTUUUVVVWWQZZZZYYRR[MMNOGL\\\\\\\\\\]]KKSSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo47 = decodeArr "stuvwxy}~\u007f©³´µ¶·¸ÀÁËÌÍÎÏÐÑÒÓãďĐęĚěĜģĤĥĦħĨĩŒœřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "\u009d\u009d\u009d\u009d\u009d\u009d\u009dPPPTUUUVVVWWQZZZZYYRR[MMNOGL\\\\\\\\\\]]KKSSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo48 = decodeArr "ã" "\u009e"; +private yygo58 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````a\u009f\u009f\u009f\u009f\u009fccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo59 = decodeArr "³´µ¶·¸¿ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿǀǁ" "UUUVVV£¤¤```````````a¦¦§§§§bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg¥¥"; +private yygo60 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿǍǎǏ" "UUUVVVWW```````````a©©\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeeggggggggggggggggggggggªªª"; +private yygo63 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƖƗƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````¬¬««ffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo83 = decodeArr "ŗŘ" "°°"; +private yygo87 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````²²ffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo88 = decodeArr "¿ÅÆÇÈÉ" "µ¶¶¶··"; +private yygo92 = decodeArr "ŔŕŖ" "»»»"; +private yygo93 = decodeArr "ŔŕŖ" "¼¼¼"; +private yygo94 = decodeArr "ŹźŻ" "À¿¿"; +private yygo99 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````ÃÃffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo106 = decodeArr "\u001a\u001b\u001c\u001d\u001e\u001f !\"#$%&'(rstuvwxy}~\u007f\u008c\u008d\u008e©³´µ¶·¸ÀÁÂÃÄÊËÌÍÎÏÐÑÒÓãďĐęĚěĜģĤĥĦħĨĩŒœřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ÇÇÇBBBEEEEDDDDJCFFFFFFFPPPHHHTUUUVVVWWXXXIQZZZZYYRR[MMNOGL\\\\\\\\\\]]KKSSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo108 = decodeArr "\u0017\u0018\u0019" "lÉÉ"; +private yygo110 = decodeArr "\f\r\u000eª«¬­®¯°" "ÊÊÊ\u0014\u0014\u0014\u0014\u0014\u0014\u0014"; +private yygo114 = decodeArr "¹ºÀÁ" "ÌÌss"; +private yygo117 = decodeArr "\u008f\u0090\u0091\u0092\u0093©" "ÑÑÑÑÑÒ"; +private yygo122 = decodeArr ")*" "ÔÔ"; +private yygo125 = decodeArr "¿ÀÁ" "Ö××"; +private yygo129 = decodeArr "\u0004\u0005\u0006\u0007\b\t\n\u000b¿ÀÁØÙÚġĢ" "Þßßßßßßßàááâââãã"; +private yygo131 = decodeArr "ûüýþÿĪī" "éééééèè"; +private yygo132 = decodeArr "ûüýþÿĪī" "éééééëë"; +private yygo134 = decodeArr "¶·¸ĉĊċČ" "\u0087\u0087\u0087íîîî"; +private yygo135 = decodeArr "ûüýþÿ" "ïïïïï"; +private yygo137 = decodeArr "ŔŕŖ" "ñññ"; +private yygo138 = decodeArr "¶·¸đĒēĔ" "\u008b\u008b\u008bòóóó"; +private yygo139 = decodeArr "¶·¸õö÷øùúûüýþÿĀāĂăĄ" "ööö÷÷÷÷÷÷øøøøøùùùùù"; +private yygo142 = decodeArr "ŔŕŖ" "ûûû"; +private yygo145 = decodeArr "ûüýþÿĪī" "éééééþþ"; +private yygo147 = decodeArr "³´µ¶·¸¿ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿǀǁ" "UUUVVVĀāā```````````a¦¦§§§§bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg¥¥"; +private yygo148 = decodeArr "Ƈƈ" "ĄĄ"; +private yygo152 = decodeArr "\u0087\u0088\u0089\u008a\u008b©³´µ¶·¸ÀÁËÌÍÎÏÐÑřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ĉĉĊĊĊTUUUVVVWWćZZZZYYĈĈĈ^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo153 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧūŬŭűŲųŴŵƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````čččďďďĎĎaČČ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo154 = decodeArr "©¿ÀÁÌÍÎÏÔÕÖ×ÛÜÝÞ" "T~\u007f\u007f\u0080\u0080\u0080\u0080\u0081\u0081\u0081\u0081\u0082\u0082\u0082\u0082"; +private yygo160 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````a\u009f\u009f\u009f\u009f\u009fccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo162 = decodeArr "ǀǁ" "đđ"; +private yygo163 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aēē\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo164 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````²²ffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo167 = decodeArr "¿" "ě"; +private yygo171 = decodeArr "ƂƃƄ" "ġĢĢ"; +private yygo172 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƖƗƘƙƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````¬¬ģģffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo174 = decodeArr "\u001a\u001b\u001c\u001d\u001e\u001f !\"#$%&'(rstuvwxy}~\u007f\u008c\u008d\u008e©³´µ¶·¸ÀÁÂÃÄÊËÌÍÎÏÐÑÒÓãďĐęĚěĜģĤĥĦħĨĩŒœřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ĤĤĤBBBEEEEDDDDJCFFFFFFFPPPHHHTUUUVVVWWXXXIQZZZZYYRR[MMNOGL\\\\\\\\\\]]KKSSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo177 = decodeArr "©ǂǃDŽNjnj" "ħĨĨĨĩĩ"; +private yygo182 = decodeArr "¿ÅÆÇÈÉ" "µ¶¶¶ĪĪ"; +private yygo184 = decodeArr "¶·¸äåæéêëìôõö÷øùúûüýþÿĀāĂ㥣ł" "öööĬĬĭĮĮİİįIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo185 = decodeArr "©ÌÍÎÏÐÑ" "TZZZZijij"; +private yygo189 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧŴŵŶŷŸƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````ĶĶķķķaĵĵ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo190 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aĸĸ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo192 = decodeArr "ŹźŻ" "ÀĹĹ"; +private yygo193 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aĺĺĺĺbbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo194 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aĻĻĻĻbbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo196 = decodeArr "¿ÀÁ" "Ŀŀŀ"; +private yygo197 = decodeArr "DždžLJLjljNJ" "łłłŃŃŃ"; +private yygo198 = decodeArr "\u001a\u001b\u001c\u001d\u001e\u001f !\"#$%&'(rstuvwxy}~\u007f\u008c\u008d\u008e©³´µ¶·¸ÀÁÂÃÄÊËÌÍÎÏÐÑÒÓãďĐęĚěĜģĤĥĦħĨĩŒœřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ńńńBBBEEEEDDDDJCFFFFFFFPPPHHHTUUUVVVWWXXXIQZZZZYYRR[MMNOGL\\\\\\\\\\]]KKSSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo200 = decodeArr "±²¹º»¼½¾¿ÀÁ" "ņņʼnʼnňňňňŇss"; +private yygo206 = decodeArr "\u008f\u0090\u0091\u0092\u0093©" "ŋŋŋŋŋÒ"; +private yygo207 = decodeArr "\u008f\u0090\u0091\u0092\u0093©" "ŌŌŌŌŌÒ"; +private yygo208 = decodeArr "\u0094\u0095\u0096\u0097\u0098\u0099\u009a\u009b\u009c\u009d\u009e\u009f³´µ¶·¸¿ÀÁ" "őőőœœœœœœŒŒŒŔŔŔŕŕŕŖŗŗ"; +private yygo211 = decodeArr "¶·¸æíîïôõö÷øùúûüýþÿĀāĂ㥣ł" "öööŚřřřśIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo212 = decodeArr "+," "ŝŝ"; +private yygo218 = decodeArr "\u0005\u0006\u0007\b\t\n\u000b" "ŢŢŢŢŢŢŢ"; +private yygo221 = decodeArr "¶·¸æíîïðñôõö÷øùúûüýþÿĀāĂ㥣ł" "öööŚťťťŦŦśIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo226 = decodeArr "ġĢ" "ŧŧ"; +private yygo228 = decodeArr "¶·¸ßàáâäåæéêëìôõö÷øùúûüýþÿĀāĂ㥣ł" "öööũũŪŪŨŨĭĮĮİİįIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo231 = decodeArr "ĮįİıIJijĴĵĶķĸĹĺ" "ŵŵŵŶŶŶŶŷŷŷŸŸŸ"; +private yygo233 = decodeArr "ûüýþÿĪī" "éééééźź"; +private yygo234 = decodeArr "ĝĞĬĭĮįİıIJijĴĵĶķĸĹĺ" "ŽŽžžſſſŶŶŶŶŷŷŷŸŸŸ"; +private yygo244 = decodeArr "¶·¸æíîïôõö÷øùúûüýþÿĀāĂ㥣łǀǁ" "öööŚƉƉƉśIJIJIJIJIJIJøøøøøùùùùùııƊƊ"; +private yygo245 = decodeArr "¶·¸æíîïôõö÷øùúûüýþÿĀāĂ㥣ł" "öööŚƌƌƌśIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo250 = decodeArr "¶·¸ĀāĂăĄ" "öööƏƏƏƏƏ"; +private yygo252 = decodeArr "ûüýþÿĪī" "éééééƑƑ"; +private yygo253 = decodeArr "¶·¸äåæéêëìôõö÷øùúûüýþÿĀāĂ㥣ł" "öööƒƒĭĮĮİİįIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo255 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````a\u009f\u009f\u009f\u009f\u009fccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo256 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aēē\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo257 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````²²ffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo260 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aƘƘ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo261 = decodeArr "¶·¸äåæéêëìôõö÷øùúûüýþÿĀāĂ㥣ł" "öööƙƙĭĮĮİİįIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo264 = decodeArr "ŗŘ" "°°"; +private yygo278 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿǐǑǒ" "UUUVVVWW```````````aƣƣ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeeggggggggggggggggggggggƤƤƤ"; +private yygo280 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿǍǎǏ" "UUUVVVWW```````````aƥƥ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeeggggggggggggggggggggggƦƦƦ"; +private yygo281 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aĺĺĺĺbbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo282 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aĻĻĻĻbbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo284 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿǍǎǏ" "UUUVVVWW```````````aƥƥ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeeggggggggggggggggggggggƩƩƩ"; +private yygo285 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧūŬŭŮůŰŴŵƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````ƪƪƪƫƫƫĎĎaČČ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo286 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aƭƭ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo288 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aƮƮ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo293 = decodeArr "\u0087\u0088\u0089\u008a\u008b©³´µ¶·¸ÀÁËÌÍÎÏÐÑřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ĉĉưưưTUUUVVVWWćZZZZYYĈĈĈ^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo299 = decodeArr "ûüýþÿĪī" "éééééƴƴ"; +private yygo306 = decodeArr "¶·¸õö÷øùúûüýþÿĀāĂ㥣ł" "öööIJIJIJIJIJIJøøøøøùùùùùƷƷ"; +private yygo308 = decodeArr "rz{|}~\u007f\u0080\u0081\u0082\u0083\u0084\u0085\u0086©³´µ¶·¸ÀÁËÌÍÎÏÐÑÒÓãřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ƼƾƾƾƽƽƽǀǀǀǀƿƿƿTUUUVVVWWQZZZZYYRR[SSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo311 = decodeArr "ũŪ" "DŽDŽ"; +private yygo317 = decodeArr "DždžLJLjljNJ" "dždždžŃŃŃ"; +private yygo318 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aLJLJ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo325 = decodeArr "¹ºÀÁ" "ǏǏss"; +private yygo330 = decodeArr "\u008f\u0090\u0091\u0092\u0093©" "ǒǒǒǒǒÒ"; +private yygo334 = decodeArr "¹ºÀÁ" "ttss"; +private yygo335 = decodeArr "\u0097\u0098\u0099\u009a\u009b\u009c\u009d\u009e\u009f³´µ¶·¸¿ÀÁ" "œœœœœœǕǕǕŔŔŔŕŕŕŖŗŗ"; +private yygo339 = decodeArr "¦§¨¿" "ǛǛǛǚ"; +private yygo344 = decodeArr "\u0094\u0095\u0096\u0097\u0098\u0099\u009a\u009b\u009c\u009d\u009e\u009f³´µ¶·¸¿ÀÁ" "ǜǜǜœœœœœœŒŒŒŔŔŔŕŕŕŖŗŗ"; +private yygo348 = decodeArr "¶·¸æíîïðñôõö÷øùúûüýþÿĀāĂ㥣ł" "öööŚťťťǞǞśIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo349 = decodeArr "-." "ǠǠ"; +private yygo353 = decodeArr "\u0005\u0006\u0007\b\t\n\u000b" "ǡǡǡǡǡǡǡ"; +private yygo355 = decodeArr "\u0005\u0006\u0007\b\t\n\u000b" "ǢǢǢǢǢǢǢ"; +private yygo364 = decodeArr "¶·¸æíîïðñôõö÷øùúûüýþÿĀāĂ㥣ł" "öööŚťťťǩǩśIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo365 = decodeArr "¶·¸ôõö÷øùúûüýþÿĀāĂ㥣ł" "öööǪIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo366 = decodeArr "¶·¸õö÷øùúûüýþÿĀāĂăĄĻļĽľĿŀ" "öööǮǮǮǮǮǮøøøøøùùùùùǯǯǰǰǰDZ"; +private yygo367 = decodeArr "ıIJijĴĵĶķĸĹĺ" "DzDzDzDzŷŷŷŸŸŸ"; +private yygo368 = decodeArr "ĵĶķĸĹĺ" "dzdzdzŸŸŸ"; +private yygo369 = decodeArr "ĵĶķĸĹĺ" "ǴǴǴŸŸŸ"; +private yygo370 = decodeArr "ĵĶķĸĹĺ" "ǵǵǵŸŸŸ"; +private yygo371 = decodeArr "ĸĹĺ" "ǶǶǶ"; +private yygo372 = decodeArr "ĸĹĺ" "ǷǷǷ"; +private yygo377 = decodeArr "ĮįİıIJijĴĵĶķĸĹĺ" "ǹǹǹŶŶŶŶŷŷŷŸŸŸ"; +private yygo381 = decodeArr "\u0004\u0005\u0006\u0007\b\t\n\u000bğĠ" "ǻßßßßßßßǼǼ"; +private yygo384 = decodeArr "ĝĞĬĭĮįİıIJijĴĵĶķĸĹĺ" "ǾǾǿǿſſſŶŶŶŶŷŷŷŸŸŸ"; +private yygo385 = decodeArr "¶·¸ĉĊċČ" "\u0087\u0087\u0087íȀȀȀ"; +private yygo387 = decodeArr "ûüýþÿ" "ȁȁȁȁȁ"; +private yygo388 = decodeArr "¶·¸đĒēĔ" "\u008b\u008b\u008bòȂȂȂ"; +private yygo397 = decodeArr "ǀǁ" "ƊƊ"; +private yygo399 = decodeArr "¶·¸õö÷øùúûüýþÿĀāĂăĄ" "öööȉȉȉȉȉȉøøøøøùùùùù"; +private yygo400 = decodeArr "ĬĭĮįİıIJijĴĵĶķĸĹĺ" "žžſſſŶŶŶŶŷŷŷŸŸŸ"; +private yygo403 = decodeArr "¶·¸äåæéêëìôõö÷øùúûüýþÿĀāĂ㥣ł" "öööȋȋĭĮĮİİįIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo408 = decodeArr "ƉƊ" "ȎȎ"; +private yygo410 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧŨżŽžſƀƁƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````ȐȑȑȑȒȒȒaȏȏ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo411 = decodeArr "\u0087\u0088\u0089\u008a\u008b©³´µ¶·¸ÀÁËÌÍÎÏÐÑřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ĉĉȓȓȓTUUUVVVWWćZZZZYYĈĈĈ^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo413 = decodeArr "\u0087\u0088\u0089\u008a\u008b©³´µ¶·¸ÀÁËÌÍÎÏÐÑřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ĉĉȕȕȕTUUUVVVWWćZZZZYYĈĈĈ^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo414 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aȖȖ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo415 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aȗȗ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo416 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧūŬŭűŲųŴŵƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````čččȘȘȘĎĎaČČ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo433 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aȠȠ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo435 = decodeArr "©ǂǃDŽNjnj" "ħȡȡȡĩĩ"; +private yygo436 = decodeArr "çè" "ȤȤ"; +private yygo437 = decodeArr "¶·¸ëìôõö÷øùúûüýþÿĀāĂ㥣ł" "öööȦȦȥIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo438 = decodeArr "¶·¸ëìôõö÷øùúûüýþÿĀāĂ㥣ł" "öööȧȧȥIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo440 = decodeArr "}~\u007f©³´µ¶·¸ÀÁËÌÍÎÏÐÑÒÓãřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ȨȨȨTUUUVVVWWQZZZZYYRR[SSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo441 = decodeArr "}~\u007f©³´µ¶·¸ÀÁËÌÍÎÏÐÑÒÓãřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ȩȩȩTUUUVVVWWQZZZZYYRR[SSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo442 = decodeArr "}~\u007f©³´µ¶·¸ÀÁËÌÍÎÏÐÑÒÓãřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ȪȪȪTUUUVVVWWQZZZZYYRR[SSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo444 = decodeArr "r}~\u007f\u0080\u0081\u0082\u0083\u0084\u0085\u0086©³´µ¶·¸ÀÁËÌÍÎÏÐÑÒÓãřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ƼƽƽƽǀǀǀǀȫȫȫTUUUVVVWWQZZZZYYRR[SSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo449 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧŴŵŶŷŸƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````ĶĶȮȮȮaĵĵ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo452 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aȯȯ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo456 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aȶȶ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo458 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aȹȹ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo460 = decodeArr "DždžLJLjljNJ" "ȻȻȻŃŃŃ"; +private yygo462 = decodeArr "¹ºÀÁ" "ȼȼss"; +private yygo465 = decodeArr "±²¹º»¼½¾¿ÀÁ" "ȽȽʼnʼnňňňňŇss"; +private yygo467 = decodeArr " ¡¢£¤¥¦§¨¿" "ɂɂɂɀɀɀɁɁɁǚ"; +private yygo468 = decodeArr "¹ºÀÁ" "ÌÌss"; +private yygo471 = decodeArr "\u0094\u0095\u0096\u0097\u0098\u0099\u009a\u009b\u009c\u009d\u009e\u009f³´µ¶·¸¿ÀÁ" "ɃɃɃœœœœœœŒŒŒŔŔŔŕŕŕŖŗŗ"; +private yygo477 = decodeArr "¶·¸æíîïôõö÷øùúûüýþÿĀāĂ㥣ł" "öööŚɅɅɅśIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo483 = decodeArr "¶·¸æíîïðñôõö÷øùúûüýþÿĀāĂ㥣ł" "öööŚťťťɇɇśIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo485 = decodeArr "¶·¸æíîïðñôõö÷øùúûüýþÿĀāĂ㥣ł" "öööŚťťťɈɈśIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo486 = decodeArr "¶·¸ßàáâäåæéêëìôõö÷øùúûüýþÿĀāĂ㥣ł" "öööũũɉɉŨŨĭĮĮİİįIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo487 = decodeArr "¶·¸æíîïðñôõö÷øùúûüýþÿĀāĂ㥣ł" "öööŚťťťɊɊśIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo488 = decodeArr "ąĆćĈ" "ɍɍɎɎ"; +private yygo491 = decodeArr "\u0010\u0011\u0012\u0013ŃńŅņŇň" "\u0004\u0004ɑɑɒɒɒɒɒɓ"; +private yygo492 = decodeArr "¶·¸õö÷øùúûüýþÿĀāĂăĄŀ" "öööǮǮǮǮǮǮøøøøøùùùùùɔ"; +private yygo493 = decodeArr "¶·¸õö÷øùúûüýþÿĀāĂăĄŀ" "öööǮǮǮǮǮǮøøøøøùùùùùɕ"; +private yygo496 = decodeArr "¶·¸õö÷øùúûüýþÿĀāĂăĄĻļĽľĿŀ" "öööǮǮǮǮǮǮøøøøøùùùùùɖɖǰǰǰDZ"; +private yygo507 = decodeArr "ġĢ" "ɗɗ"; +private yygo509 = decodeArr "ĬĭĮįİıIJijĴĵĶķĸĹĺ" "ɘɘſſſŶŶŶŶŷŷŷŸŸŸ"; +private yygo510 = decodeArr "\u0004\u0005\u0006\u0007\b\t\n\u000bğĠ" "ǻßßßßßßßəə"; +private yygo513 = decodeArr "ŔŕŖ" "ɚɚɚ"; +private yygo517 = decodeArr "¶·¸æíîïðñôõö÷øùúûüýþÿĀāĂ㥣ł" "öööŚťťťɛɛśIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo518 = decodeArr "¶·¸æíîïòóôõö÷øùúûüýþÿĀāĂ㥣ł" "öööŚɜɜɜɝɝśIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo522 = decodeArr "ĬĭĮįİıIJijĴĵĶķĸĹĺ" "ǿǿſſſŶŶŶŶŷŷŷŸŸŸ"; +private yygo526 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aɟɟ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo528 = decodeArr "ũŪŹźŻ" "ɡɡÀɠɠ"; +private yygo529 = decodeArr "ŗŘ" "ɣɣ"; +private yygo532 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aɥɥ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo537 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿǐǑǒ" "UUUVVVWW```````````aƣƣ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeeggggggggggggggggggggggɧɧɧ"; +private yygo540 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧūŬŭŮůŰŴŵƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````ƪƪƪɨɨɨĎĎaČČ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo548 = decodeArr "¶·¸éêëìôõö÷øùúûüýþÿĀāĂ㥣ł" "öööɩɩİİįIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo557 = decodeArr "rz{|}~\u007f\u0080\u0081\u0082\u0083\u0084\u0085\u0086©³´µ¶·¸ÀÁËÌÍÎÏÐÑÒÓãřŚśŜŝŞşŠšŢţŤťŦŧƂƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "ƼɪɪɪƽƽƽǀǀǀǀƿƿƿTUUUVVVWWQZZZZYYRR[SSS^```````````a____bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo560 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aȶȶ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo562 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aȹȹ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo574 = decodeArr " ¡¢¦§¨¿" "ɰɰɰɁɁɁǚ"; +private yygo577 = decodeArr "¦§¨¿" "ɲɲɲǚ"; +private yygo582 = decodeArr "/0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopq" "ʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʳʳʳʳʳʳ"; +private yygo588 = decodeArr "ąĆćĈ" "ʶʶɎɎ"; +private yygo593 = decodeArr "©ʼnŊŋŌōŎŏŐő" "ʽʾʾʿʿʿˀˀˀˁ"; +private yygo609 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aˈˈ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo610 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧŨżŽžſƀƁƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````Ȑȑȑȑˉˉˉaȏȏ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo622 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aȶȶ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo623 = decodeArr "³´µ¶·¸ÀÁŝŞşŠšŢţŤťŦŧƂƅƆƋƌƍƎƏƐƑƒƓƔƕƖƗƚƛƜƝƞƟƠơƢƣƤƥƦƧƨƩƪƫƬƭƮƯưƱƲƳƴƵƶƷƸƹƺƻƼƽƾƿ" "UUUVVVWW```````````aȹȹ\u0095\u0095\u0095\u0095bbbbbccddffeeeeeeeeeeeeeegggggggggggggggggggggg"; +private yygo627 = decodeArr " ¡¢£¤¥¦§¨¿" "ɂɂɂˊˊˊɁɁɁǚ"; +private yygo678 = decodeArr "/0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopq" "ʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴˌˌˌˌˌˌ"; +private yygo692 = decodeArr "/0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopq" "ʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴˎˎˎˎˎˎ"; +private yygo696 = decodeArr "ąĆćĈ" "ːːɎɎ"; +private yygo697 = decodeArr "©ŎŏŐő" "ʽˑˑˑˁ"; +private yygo698 = decodeArr "©ŎŏŐő" "ʽ˒˒˒ˁ"; +private yygo699 = decodeArr "©ő" "ʽ˓"; +private yygo700 = decodeArr "©ő" "ʽ˔"; +private yygo707 = decodeArr "\u0010\u0011\u0012\u0013ŃńŅņŇň" "\u0004\u0004ɑɑ˗˗˗˗˗ɓ"; +private yygo708 = decodeArr "\u0010\u0011\u0012\u0013ŃńŅņŇň" "\u0004\u0004ɑɑ˘˘˘˘˘ɓ"; +private yygo710 = decodeArr "¶·¸æíîïòóôõö÷øùúûüýþÿĀāĂ㥣ł" "öööŚɜɜɜ˙˙śIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo715 = decodeArr "/0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopq" "ʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴ˚˚˚˚˚˚"; +private yygo725 = decodeArr "¶·¸äåæéêëìôõö÷øùúûüýþÿĀāĂ㥣ł" "ööö˜˜ĭĮĮİİįIJIJIJIJIJIJøøøøøùùùùùıı"; +private yygo726 = decodeArr "©ʼnŊŋŌōŎŏŐő" "ʽ˝˝ʿʿʿˀˀˀˁ"; +private yygo731 = decodeArr "/0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopq" "ʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴʴ˞˞˞˞˞˞"; private yygos = let sub1 = [ (0, yygo0), (1, yygo1), @@ -10529,196 +10626,200 @@ private yygos = let (59, yygo59), (60, yygo60), (63, yygo63), - (82, yygo82), - (86, yygo86), + (83, yygo83), (87, yygo87), - (91, yygo91), + (88, yygo88), (92, yygo92), - (97, yygo97), - (104, yygo104), + (93, yygo93), + (94, yygo94), + (99, yygo99), (106, yygo106), (108, yygo108), - (112, yygo112), - (115, yygo115), - (120, yygo120), - (123, yygo123), - (127, yygo127), + (110, yygo110), + (114, yygo114), + (117, yygo117), + (122, yygo122), + (125, yygo125), (129, yygo129), - (130, yygo130), + (131, yygo131), (132, yygo132), - (133, yygo133), + (134, yygo134), (135, yygo135), - (136, yygo136), (137, yygo137), - (140, yygo140), + (138, yygo138), + (139, yygo139), (142, yygo142), - (144, yygo144), (145, yygo145), - (149, yygo149), - (150, yygo150), - (151, yygo151), - (157, yygo157), - (159, yygo159), + (147, yygo147), + (148, yygo148), + (152, yygo152), + (153, yygo153), + (154, yygo154), (160, yygo160), - (161, yygo161), + (162, yygo162), + (163, yygo163), (164, yygo164), - (168, yygo168), - (169, yygo169), + (167, yygo167), (171, yygo171), + (172, yygo172), (174, yygo174), - (179, yygo179), - (181, yygo181)]; - sub2 = [ (182, yygo182), + (177, yygo177), + (182, yygo182)]; + sub2 = [ (184, yygo184), (185, yygo185), - (186, yygo186), - (188, yygo188), (189, yygo189), (190, yygo190), (192, yygo192), (193, yygo193), (194, yygo194), (196, yygo196), - (202, yygo202), - (203, yygo203), - (204, yygo204), + (197, yygo197), + (198, yygo198), + (200, yygo200), + (206, yygo206), (207, yygo207), (208, yygo208), - (214, yygo214), - (217, yygo217), - (222, yygo222), - (224, yygo224), - (227, yygo227), - (229, yygo229), - (230, yygo230), - (240, yygo240), - (241, yygo241), - (246, yygo246), - (248, yygo248), + (211, yygo211), + (212, yygo212), + (218, yygo218), + (221, yygo221), + (226, yygo226), + (228, yygo228), + (231, yygo231), + (233, yygo233), + (234, yygo234), + (244, yygo244), + (245, yygo245), (250, yygo250), - (251, yygo251), (252, yygo252), + (253, yygo253), (255, yygo255), (256, yygo256), - (259, yygo259), - (273, yygo273), - (275, yygo275), - (276, yygo276), - (277, yygo277), - (279, yygo279), + (257, yygo257), + (260, yygo260), + (261, yygo261), + (264, yygo264), + (278, yygo278), (280, yygo280), (281, yygo281), - (283, yygo283), + (282, yygo282), + (284, yygo284), + (285, yygo285), + (286, yygo286), (288, yygo288), - (294, yygo294), - (301, yygo301), - (303, yygo303), + (293, yygo293), + (299, yygo299), (306, yygo306), - (312, yygo312), - (313, yygo313), - (320, yygo320), + (308, yygo308), + (311, yygo311), + (317, yygo317), + (318, yygo318), (325, yygo325), - (329, yygo329), (330, yygo330), (334, yygo334), + (335, yygo335), (339, yygo339), - (343, yygo343), (344, yygo344), (348, yygo348), - (350, yygo350), - (359, yygo359), - (360, yygo360), - (361, yygo361), - (362, yygo362), - (363, yygo363), + (349, yygo349), + (353, yygo353), + (355, yygo355), (364, yygo364), - (365, yygo365)]; - sub3 = [ (366, yygo366), + (365, yygo365), + (366, yygo366), (367, yygo367), + (368, yygo368)]; + sub3 = [ (369, yygo369), + (370, yygo370), + (371, yygo371), (372, yygo372), - (376, yygo376), - (379, yygo379), - (380, yygo380), - (382, yygo382), - (383, yygo383), - (392, yygo392), - (394, yygo394), - (396, yygo396), - (401, yygo401), + (377, yygo377), + (381, yygo381), + (384, yygo384), + (385, yygo385), + (387, yygo387), + (388, yygo388), + (397, yygo397), + (399, yygo399), + (400, yygo400), (403, yygo403), - (404, yygo404), - (406, yygo406), - (407, yygo407), (408, yygo408), - (409, yygo409), - (426, yygo426), - (428, yygo428), - (429, yygo429), - (430, yygo430), - (431, yygo431), + (410, yygo410), + (411, yygo411), + (413, yygo413), + (414, yygo414), + (415, yygo415), + (416, yygo416), (433, yygo433), - (434, yygo434), (435, yygo435), + (436, yygo436), (437, yygo437), + (438, yygo438), + (440, yygo440), + (441, yygo441), (442, yygo442), - (445, yygo445), + (444, yygo444), (449, yygo449), - (451, yygo451), - (453, yygo453), - (455, yygo455), + (452, yygo452), + (456, yygo456), (458, yygo458), (460, yygo460), - (461, yygo461), - (464, yygo464), - (470, yygo470), - (476, yygo476), - (478, yygo478), - (479, yygo479), - (480, yygo480), - (481, yygo481), - (484, yygo484), + (462, yygo462), + (465, yygo465), + (467, yygo467), + (468, yygo468), + (471, yygo471), + (477, yygo477), + (483, yygo483), (485, yygo485), (486, yygo486), - (489, yygo489), - (500, yygo500), - (502, yygo502), - (503, yygo503), - (506, yygo506), + (487, yygo487), + (488, yygo488), + (491, yygo491), + (492, yygo492), + (493, yygo493), + (496, yygo496), + (507, yygo507), + (509, yygo509), (510, yygo510), - (511, yygo511), + (513, yygo513), + (517, yygo517), (518, yygo518), - (520, yygo520), - (521, yygo521), - (524, yygo524), + (522, yygo522), + (526, yygo526), + (528, yygo528), (529, yygo529), (532, yygo532), + (537, yygo537), (540, yygo540), - (549, yygo549), - (552, yygo552), - (554, yygo554), - (566, yygo566)]; - sub4 = [ (569, yygo569), + (548, yygo548)]; + sub4 = [ (557, yygo557), + (560, yygo560), + (562, yygo562), (574, yygo574), - (580, yygo580), - (585, yygo585), - (601, yygo601), - (602, yygo602), - (614, yygo614), - (615, yygo615), - (619, yygo619), - (670, yygo670), - (684, yygo684), - (688, yygo688), - (689, yygo689), - (690, yygo690), - (691, yygo691), + (577, yygo577), + (582, yygo582), + (588, yygo588), + (593, yygo593), + (609, yygo609), + (610, yygo610), + (622, yygo622), + (623, yygo623), + (627, yygo627), + (678, yygo678), (692, yygo692), + (696, yygo696), + (697, yygo697), + (698, yygo698), (699, yygo699), (700, yygo700), - (702, yygo702), (707, yygo707), - (717, yygo717), - (718, yygo718), - (723, yygo723)]; + (708, yygo708), + (710, yygo710), + (715, yygo715), + (725, yygo725), + (726, yygo726), + (731, yygo731)]; in sub1 `seq` sub2 `seq` sub3 `seq` sub4 `seq` genericArrayFromIndexList (sub1 ++ sub2 ++ sub3 ++ sub4); {- diff --git a/frege/compiler/grammar/Frege.y b/frege/compiler/grammar/Frege.y index 14e7eb6f..eafcd9e4 100644 --- a/frege/compiler/grammar/Frege.y +++ b/frege/compiler/grammar/Frege.y @@ -145,38 +145,40 @@ private yyprod1 :: [(Int, YYsi ParseResult Token)] //%type importliste ImportList //%type definitions [Def] //%type definition [Def] -//%type import Def -//%type infix Def -//%type fixity Def -//%type typedef Def +//%type import ImpDcl +//%type infix FixDcl +//%type fixity FixDcl +//%type typedef TypDcl //%type scontext ContextS //%type scontexts [ContextS] //%type ccontext [ContextS] //%type sicontext ContextS //%type sicontexts [ContextS] //%type icontext [ContextS] -//%type insthead Def -//%type classdef Def -//%type instdef Def -//%type derivedef Def -//%type nativedef Def -//%type impurenativedef Def -//%type datadef Def -//%type datainit Def -//%type annotation [Def] -//%type fundef [Def] -//%type documentation Def +//%type insthead InsDcl +//%type classdef ClaDcl +//%type instdef InsDcl +//%type derivedef DrvDcl +//%type nativedef NatDcl +//%type impurenativedef NatDcl +//%type datadef DatDcl +//%type datainit DatDcl +//%type datajavadef JavDcl +//%type datajavainit JavDcl +//%type annotation [AnnDcl] +//%type fundef FunDcl +//%type documentation DocDcl //%type topdefinition [Def] //%type publicdefinition [Def] //%type plocaldef [Def] //%type dplocaldef [Def] //%type localdef [Def] //%type localdefs [Def] -//%type letdef [Def] -//%type letdefs [Def] -//%type wherelet [Def] +//%type letdef [LetMemberS] +//%type letdefs [LetMemberS] +//%type wherelet [LetMemberS] //%type visibledefinition [Def] -//%type moduledefinition Def +//%type moduledefinition ModDcl //%type wheredef [Def] //%type tyvar TauS //%type tvapp TauS @@ -351,6 +353,8 @@ private yyprod1 :: [(Int, YYsi ParseResult Token)] //%explain letdefs declarations in a let expression or where clause //%explain datadef a data definition //%explain datainit a data definition +//%explain datajavadef a data definition for a native type +//%explain datajavainit a data definition for a native type //%explain dalt a variant of an algebraic datatype //%explain simpledalt a variant of an algebraic datatype //%explain strictdalt a variant of an algebraic datatype @@ -500,7 +504,7 @@ definitions: ; definition: - documentation { single } + documentation { single . DefinitionS.Doc } | topdefinition | visibledefinition ; @@ -509,14 +513,14 @@ visibledefinition: PRIVATE publicdefinition { \_\ds -> map (updVis Private) ds } | PROTECTED publicdefinition { \_\ds -> map (updVis Protected) ds } | PUBLIC publicdefinition { \_\ds -> map (updVis Public) ds } - | ABSTRACT datadef { \_\(d::Def) -> [d.{ctrs <- map updCtr}] } + | ABSTRACT datadef { \_\(d::DatDcl) -> [DefinitionS.Dat $ d.{ctrs <- map updCtr}] } ; topdefinition: - import { single } - | infix { single } - | moduledefinition { single } + import { single . DefinitionS.Imp } + | infix { single . DefinitionS.Fix } + | moduledefinition { single . DefinitionS.Mod } | publicdefinition ; @@ -566,11 +570,12 @@ documentation: ; publicdefinition: - typedef { single } - | datadef { single } - | classdef { single } - | instdef { single } - | derivedef { single } + typedef { single . DefinitionS.Typ } + | datadef { single . DefinitionS.Dat } + | datajavadef { single . DefinitionS.Jav } + | classdef { single . DefinitionS.Cla } + | instdef { single . DefinitionS.Ins } + | derivedef { single . DefinitionS.Drv } | localdef ; @@ -582,9 +587,9 @@ localdefs: ; localdef: - annotation - | nativedef { single } - | fundef + annotation { map DefinitionS.Ann } + | nativedef { single . DefinitionS.Nat } + | fundef { single . DefinitionS.Fun } ; plocaldef: @@ -595,14 +600,14 @@ plocaldef: ; dplocaldef: - documentation { single } - | documentation dplocaldef { (:) } + documentation { single . DefinitionS.Doc } + | documentation dplocaldef { \doc\ds -> DefinitionS.Doc doc : ds } | plocaldef ; letdef: - annotation - | fundef + annotation { map LetMemberS.Ann } + | fundef { single . LetMemberS.Fun } ; @@ -751,7 +756,7 @@ operators: ; infix: - fixity operators { \(def::Def)\o -> def.{ops = o}} + fixity operators { \(def::FixDcl)\o -> def.{ops = o}} ; annotation: @@ -772,7 +777,7 @@ annoitems: nativedef: - PURE impurenativedef { \_\(d::Def) -> d.{isPure = true} } + PURE impurenativedef { \_\(d::NatDcl) -> d.{isPure = true} } | impurenativedef ; @@ -1019,21 +1024,24 @@ insthead: instdef: INSTANCE insthead wheredef { - \ins\head\defs -> (head::Def).{defs, pos = yyline ins} + \ins\head\defs -> (head::InsDcl).{defs, pos = yyline ins} } ; derivedef: - DERIVE insthead { - \d\(i::Def) -> DrvDcl {pos = yyline d, vis = Public, clas=i.clas, typ=i.typ, doc=Nothing} + DERIVE insthead { + \d\(i::InsDcl) -> DrvDcl {pos = yyline d, vis = Public, clas=i.clas, typ=i.typ, doc=Nothing} } ; datadef: - datainit wheredef { \def\defs -> (def::Def).{defs = defs} } + datainit wheredef { \def\defs -> (def::DatDcl).{defs = defs} } ; +datajavadef: + datajavainit wheredef { \def\defs -> (def::JavDcl).{defs = defs} } + nativepur: PURE NATIVE { \_\_ -> true } | NATIVE { \_ -> false } @@ -1049,23 +1057,8 @@ gargs: | '{' '}' { \_\_ -> [] } ; - datainit: - DATA CONID '=' nativepur nativespec { - \dat\d\docu\pur\(jt,gargs) -> JavDcl {pos=yyline d, vis=Public, name=Token.value d, - jclas=jt, vars=[], defs=[], - gargs, - isPure = pur, - doc=Nothing} - } - | DATA CONID dvars '=' nativepur nativespec { - \dat\d\ds\docu\pur\(jt,gargs) -> JavDcl {pos=yyline d, vis=Public, name=Token.value d, - jclas=jt, vars=ds, defs=[], - gargs, - isPure = pur, - doc=Nothing} - } - | DATA CONID dvars '=' dalts { + DATA CONID dvars '=' dalts { \dat\d\ds\docu\alts -> DatDcl {pos=yyline d, vis=Public, name=Token.value d, newt = false, vars=ds, ctrs=alts, defs=[], doc=Nothing} @@ -1092,6 +1085,23 @@ datainit: } ; +datajavainit: + DATA CONID '=' nativepur nativespec { + \dat\d\docu\pur\(jt,gargs) -> JavDcl {pos=yyline d, vis=Public, name=Token.value d, + jclas=jt, vars=[], defs=[], + gargs, + isPure = pur, + doc=Nothing} + } + | DATA CONID dvars '=' nativepur nativespec { + \dat\d\ds\docu\pur\(jt,gargs) -> JavDcl {pos=yyline d, vis=Public, name=Token.value d, + jclas=jt, vars=ds, defs=[], + gargs, + isPure = pur, + doc=Nothing} + } + ; + dvars: tyvar { single } | tyvar dvars { (:) } @@ -1221,13 +1231,7 @@ wherelet: fundef: funhead '=' expr { \(ex,pats)\eq\expr -> fundef ex pats expr } | funhead guards { \(ex,pats)\gds -> fungds ex pats gds } - | fundef wherelet { \fdefs\defs -> - case fdefs of - [fd] | FunDcl {expr=x} <- fd = YYM.pure [fd.{expr = Let defs x}] - _ = do - yyerror (head fdefs).pos ("illegal function definition, where { ... } after annotation?") - YYM.pure fdefs - } + | fundef wherelet { \(fd::FunDcl)\defs -> YYM.pure $ fd.{expr = Let defs fd.expr} } ; @@ -1262,7 +1266,9 @@ aeq: ARROW | '='; lcqual: gqual - | expr '=' expr { \e\t\x -> do { (ex,pat) <- funhead e; YYM.pure (Right (fundef ex pat x)) }} + | expr '=' expr { \e\t\x -> do + (ex,pat) <- funhead e + YYM.pure $ Right $ single $ LetMemberS.Fun $ fundef ex pat x } | LET '{' letdefs '}' { \_\_\ds\_ -> Right ds } ; diff --git a/frege/compiler/passes/Enter.fr b/frege/compiler/passes/Enter.fr index ae03a6ab..7cfc2666 100644 --- a/frege/compiler/passes/Enter.fr +++ b/frege/compiler/passes/Enter.fr @@ -55,9 +55,10 @@ oneSym sym | otherwise = 1 -isInstOrDerive (InsDcl {pos}) = true -isInstOrDerive (DrvDcl {pos}) = true -isInstOrDerive _ = false +isInstOrDerive :: DefinitionS -> Bool +isInstOrDerive (DefinitionS.Ins _) = true +isInstOrDerive (DefinitionS.Drv _) = true +isInstOrDerive _ = false private transTVar :: TauS -> Tau @@ -81,10 +82,11 @@ link sym = do --- reorder definitions so that annotations come last +annosLast :: [DefinitionS] -> [DefinitionS] annosLast defs = nannos ++ annos where (annos, nannos) = DL.partition isAnno defs - isAnno (AnnDcl {pos}) = true - isAnno _ = false + isAnno (DefinitionS.Ann _) = true + isAnno _ = false {-- @@ -92,12 +94,30 @@ annosLast defs = nannos ++ annos where Takes care that annotations are processed after their implementations so that 'changeSym' will work. -} +enter :: (String -> QName) -> [DefinitionS] -> StG () enter fname defs = foreach (annosLast defs) (enter1 fname) {-- create provisional symbol for 1 definition in the symbol table -} enter1 :: (String -> QName) -> DefinitionS -> StG () -enter1 fname (d@FunDcl {positions}) = case funbinding d of +enter1 fname d = + case d of + DefinitionS.Fun x -> enter1FunDcl fname x + DefinitionS.Nat x -> enter1NatDcl fname x + DefinitionS.Ann x -> enter1AnnDcl fname x + DefinitionS.Cla x -> enter1ClaDcl fname x + DefinitionS.Ins x -> enter1InsDcl fname x + DefinitionS.Drv x -> E.fatal x.pos (text "FATAL: cannot enter a derive definition") + DefinitionS.Dat x -> enter1DatDcl fname x + DefinitionS.Jav x -> enter1JavDcl fname x + DefinitionS.Typ x -> enter1TypDcl fname x + DefinitionS.Imp _ -> stio () + DefinitionS.Fix _ -> stio () + DefinitionS.Doc _ -> stio () + DefinitionS.Mod _ -> stio () + +enter1FunDcl :: (String -> QName) -> FunDcl -> StG () +enter1FunDcl fname (d@FunDcl {positions}) = case funbinding d of Just name -> do let qname = fname name.value foreach positions (register qname) @@ -123,15 +143,18 @@ enter1 fname (d@FunDcl {positions}) = case funbinding d of changeST Global.{ sub <- SubSt.{ idKind <- insert (KeyTk tok) (Right qname)}} - -enter1 fname (d@NatDcl {pos}) = do + +enter1NatDcl :: (String -> QName) -> NatDcl -> StG () +enter1NatDcl fname (d@NatDcl {pos}) = do let !qname = fname d.name changeST Global.{ sub <- SubSt.{ idKind <- insert (KeyTk pos.first) (Right qname)}} ST.enter (vSym pos qname).{vis=d.vis, doc=d.doc, nativ=Just d.meth, pur=d.isPure} -enter1 fname (d@AnnDcl {pos}) = do + +enter1AnnDcl :: (String -> QName) -> AnnDcl -> StG () +enter1AnnDcl fname (d@AnnDcl {pos}) = do g <- getST let qname = fname d.name merge Nothing _ b _ = b @@ -162,8 +185,8 @@ enter1 fname (d@AnnDcl {pos}) = do sub <- SubSt.{ idKind <- insert (KeyTk pos.first) (Right qname)}} - -enter1 fname (d@ClaDcl {pos}) = do +enter1ClaDcl :: (String -> QName) -> ClaDcl -> StG () +enter1ClaDcl fname (d@ClaDcl {pos}) = do g <- getST let tname = TName g.thisPack d.name changeST Global.{sub <- @@ -171,16 +194,25 @@ enter1 fname (d@ClaDcl {pos}) = do ST.enter (SymC {sid=0, pos=d.pos, vis=d.vis, doc=d.doc, name=tname, tau=transTVar d.clvar, supers=[], insts=[], env=empty}) - let vdefs = map DefinitionS.{vis <- max d.vis} d.defs - xdefs = filter ((>d.vis) • DefinitionS.vis) d.defs + let vdefs = map (\def -> def.chgVis $ max d.vis) d.members + xdefs = filter ((>d.vis) . _.vis) d.members -- complain about class members that are more visible than the class - foreach xdefs (\(def::DefinitionS) -> E.error def.pos (msgdoc ( - d.name ++ "." ++ def.name ++ " is " ++ show def.vis - ++ " while the enclosing class is only " - ++ show d.vis))) - - enter (MName tname) vdefs + foreach xdefs $ \def -> + let emitError name pos = + E.error pos $ msgdoc $ + d.name ++ "." ++ name ++ " is " ++ show def.vis + ++ " while the enclosing class is only " + ++ show d.vis + in + case def of + -- a bare FunDcl (a function definition without annotation) is + -- assumed absent + ClassMemberS.Ann x -> emitError x.name x.pos + ClassMemberS.Nat x -> emitError x.name x.pos + ClassMemberS.Fun _ -> pure () + + enter (MName tname) $ map (_.toDefinitionS) vdefs {- all entries from the env of the symbol that is named by 'tname' except those whose name is found in the global package and the @@ -198,7 +230,8 @@ enter1 fname (d@ClaDcl {pos}) = do E.logmsg TRACE3 pos (text ("enter1: ClaDcl: vs=" ++ show (map (flip nice g) vs))) foreach (vs) link -enter1 !fname (!d@InsDcl {pos = !pos}) = do +enter1InsDcl :: (String -> QName) -> InsDcl -> StG () +enter1InsDcl !fname (!d@InsDcl {pos = !pos}) = do g <- getST let tname = TName g.thisPack (insName d) @@ -224,8 +257,15 @@ enter1 !fname (!d@InsDcl {pos = !pos}) = do ++ ", there is no type constructor.")) where mklinkd !tname !mname !d - | Just t <- funbinding d = mklink tname mname t.value - | d.{name?} = mklink tname mname d.name + | DefinitionS.Fun f <- d + , Just t <- funbinding f = mklink tname mname t.value + -- enumerated all possibilities; some cases may be redundant + | DefinitionS.Typ t <- d = mklink tname mname t.name + | DefinitionS.Cla t <- d = mklink tname mname t.name + | DefinitionS.Ann t <- d = mklink tname mname t.name + | DefinitionS.Nat t <- d = mklink tname mname t.name + | DefinitionS.Dat t <- d = mklink tname mname t.name + | DefinitionS.Jav t <- d = mklink tname mname t.name | otherwise = error ("function binding expected: " ++ tname.base) mklink !tname !mname !nm = do g <- getST @@ -237,9 +277,8 @@ enter1 !fname (!d@InsDcl {pos = !pos}) = do Nothing -> linkq rem sym Nothing -> E.fatal d.pos (text ("FATAL, can't find " ++ mem.nice g ++ " again")) -enter1 fname (d@DrvDcl {pos}) = E.fatal pos (text "FATAL: cannot enter a derive definition") - -enter1 fname (d@DatDcl {pos}) = do +enter1DatDcl :: (String -> QName) -> DatDcl -> StG () +enter1DatDcl fname (d@DatDcl {pos}) = do g <- getST -- dkinds ← mapM U.transKind dsig.kinds let dname = TName g.thisPack d.name @@ -302,8 +341,8 @@ enter1 fname (d@DatDcl {pos}) = do " must occur only once.")) stio () - -enter1 fname (d@JavDcl {pos}) = do +enter1JavDcl :: (String -> QName) -> JavDcl -> StG () +enter1JavDcl fname (d@JavDcl {pos}) = do g <- getST let !dname = TName g.thisPack d.name dtcon = TCon {pos=d.pos, name=dname} @@ -322,7 +361,8 @@ enter1 fname (d@JavDcl {pos}) = do idKind <- insert (KeyTk pos.first) (Right dname)}} enter (MName dname) d.defs -enter1 fname (d@TypDcl {pos}) = do +enter1TypDcl :: (String -> QName) -> TypDcl -> StG () +enter1TypDcl fname (d@TypDcl {pos}) = do g <- getST let !dname = TName g.thisPack d.name kind = KVar @@ -334,14 +374,15 @@ enter1 fname (d@TypDcl {pos}) = do vars = map transTVar d.vars}) -enter1 fname (ImpDcl {pos}) = stio () -enter1 fname (FixDcl {pos}) = stio () -enter1 fname (DocDcl {pos}) = stio () -enter1 fname (ModDcl {pos}) = stio () +class IsInstanceDcl a where + typ :: a -> SigmaS + clas :: a -> SName +instance IsInstanceDcl InsDcl +instance IsInstanceDcl DrvDcl -insName :: DefinitionS -> String -insName idcl | idcl.{clas?}, idcl.{typ?} = clas ++ "_" ++ tcon idcl.typ where +insName :: IsInstanceDcl a => a -> String +insName idcl = clas ++ "_" ++ tcon idcl.typ where clas = idcl.clas.id.value tcon (ForAll _ rho) = rhoTcon rho rhoTcon (RhoFun _ _ _) = "->" @@ -357,4 +398,3 @@ insName idcl | idcl.{clas?}, idcl.{typ?} = clas ++ "_" ++ tcon idcl.typ where tauTcon (TVar {var}) = var -- undefined tauTcon (Meta _) = "meta" -- undefined tauTcon TSig{} = "forall" -insName _ = error "not an instance" \ No newline at end of file diff --git a/frege/compiler/passes/Fields.fr b/frege/compiler/passes/Fields.fr index 960a1ff0..c15dda93 100644 --- a/frege/compiler/passes/Fields.fr +++ b/frege/compiler/passes/Fields.fr @@ -34,22 +34,27 @@ import frege.compiler.Utilities as U(vSym) -} pass = do g <- getST - definitions <- mapSt chgddef g.sub.sourcedefs - changeST Global.{sub <- SubSt.{sourcedefs = definitions}} - return ("fields", (count definitions - count g.sub.sourcedefs ) `quot` 4) - -count :: [DefinitionS] -> Int -count = sum . map subdefs - where - subdefs d | d.{defs?} = length d.defs - | otherwise = 0 + (count, newDefsRev) <- foldSt + (\(count, newDefs) oldDef -> + case oldDef of + DefinitionS.Dat d -> do + newDef <- chgddef d + pure (count + 1, DefinitionS.Dat newDef:newDefs) + other -> pure (count, other:newDefs) + ) + (0, []) + g.sub.sourcedefs + changeST Global.{sub <- SubSt.{sourcedefs = reverse newDefsRev}} + return ("fields", count) +chgddef :: DatDcl -> StG DatDcl chgddef (d@DatDcl {pos}) = do g <- getST let dname = TName g.thisPack d.name dsym <- U.findT dname - let (newdefs,_) = work g dsym + let (newdefs',_) = work g dsym + newdefs = map DefinitionS.Fun newdefs' enter (MName dname) newdefs -- inlining chg$field and upd$field tends to break binary compatibility, -- because the caller's java code will use the constructor directly. @@ -58,7 +63,7 @@ chgddef (d@DatDcl {pos}) = do -- changeST _.{sub <- _.{toExport <- (exports++)}} stio d.{defs <- (++ newdefs)} where - work :: Global -> Symbol -> ([DefinitionS], [SName]) + work :: Global -> Symbol -> ([FunDcl], [SName]) work g (dsym@SymT {env}) = let cons = [ sym | sym@SymD {sid} <- values env ] fields = (uniqBy (using fst) • sort) [ (f,p) | con <- cons, Field {pos = p, name = Just f} <- Symbol.flds con ] @@ -69,7 +74,7 @@ chgddef (d@DatDcl {pos}) = do s <- ["chg$", "upd$"]] else []) work _ _ = error "work: need a SymT" - gen :: Global -> Position -> QName -> [Symbol] -> String -> [DefinitionS] + gen :: Global -> Position -> QName -> [Symbol] -> String -> [FunDcl] gen g fpos tname cons f = let pos = fpos.{first <- Token.{offset <- succ}} model = FunDcl {vis = Public, positions = [fpos.first], @@ -150,5 +155,3 @@ chgddef (d@DatDcl {pos}) = do | con <- cons, v <- occurs con f] last = CAlt {pat=var "_", ex = vFalse} in [symf, symu, symc, symh] -chgddef d = stio d -- leave others unchanged - diff --git a/frege/compiler/passes/Fix.fr b/frege/compiler/passes/Fix.fr index 5c9f43bc..1d3bd765 100644 --- a/frege/compiler/passes/Fix.fr +++ b/frege/compiler/passes/Fix.fr @@ -51,10 +51,14 @@ pass = do -} fixdefs :: [DefinitionS] -> StG [DefinitionS] fixdefs defs = do - ds <- unDoc defs >>= mapM unlet >>= pure . concat + ds <- unDoc defs >>= mapM (forFunDcl unlet) >>= pure . concat fs <- funJoin ds - checkUniq [ name | dcl@FunDcl {lhs} <- fs, name <- funbinding dcl ] + checkUniq [ name | DefinitionS.Fun dcl <- fs, name <- funbinding dcl ] return fs + where + forFunDcl :: (FunDcl -> StG [FunDcl]) -> DefinitionS -> StG [DefinitionS] + forFunDcl f (DefinitionS.Fun x) = map DefinitionS.Fun <$> f x + forFunDcl _ d = pure [d] checkUniq [] = return () @@ -76,7 +80,7 @@ checkUniq (name:as) = do > a = case let of (a,b) -> a > b = case let of (a,b) -> b -} -unlet :: DefinitionS -> StG [DefinitionS] +unlet :: FunDcl -> StG [FunDcl] unlet f | FunDcl{vis, lhs, pats, expr, doc} <- f, patbinding f = do @@ -127,30 +131,56 @@ unlet f unDoc :: [DefinitionS] -> StG [DefinitionS] unDoc [] = stio [] unDoc (defs@(d:ds)) - | DocDcl {} <- d = do r <- apply doc rest; unDoc r - | d.{defs?} = do ndefs <- fixdefs d.defs - liftM2 (:) (stio d.{defs=ndefs}) (unDoc ds) - | otherwise = liftM2 (:) (stio d) (unDoc ds) + | DefinitionS.Doc d' <- d + = do r <- apply doc d'.pos rest + unDoc r + | DefinitionS.Cla d' <- d + = do defs <- fixdefs d'.defs + (DefinitionS.Cla (d'.{defs}) :) <$> unDoc ds + | DefinitionS.Ins d' <- d + = do defs <- fixdefs d'.defs + (DefinitionS.Ins (d'.{defs}) :) <$> unDoc ds + | DefinitionS.Dat d' <- d + = do defs <- fixdefs d'.defs + (DefinitionS.Dat (d'.{defs}) :) <$> unDoc ds + | DefinitionS.Jav d' <- d + = do defs <- fixdefs d'.defs + (DefinitionS.Jav (d'.{defs}) :) <$> unDoc ds + | otherwise = (d:) <$> unDoc ds where - pos = d.pos - docs = takeWhile isDoc defs + docs = [ x | DefinitionS.Doc x <- takeWhile isDoc defs ] rest = dropWhile isDoc defs - isDoc (DocDcl {}) = true - isDoc _ = false - doc = joined "\n\n" (map DefinitionS.text docs) - apply :: String -> [DefinitionS] -> StG [DefinitionS] - apply str [] = do E.warn pos (msgdoc ("documentation at end of file")); stio [] - apply str (d:ds) = case d of - ImpDcl {pos=p} -> do - E.warn p (msgdoc ("there is no point in documenting an import, documentation from line " + isDoc (DefinitionS.Doc _) = true + isDoc _ = false + doc = joined "\n\n" (map _.text docs) + apply :: String -> Position -> [DefinitionS] -> StG [DefinitionS] + apply str pos [] = do E.warn pos (msgdoc ("documentation at end of file")); stio [] + apply str pos (d:ds) = case d of + DefinitionS.Imp def -> do + E.warn def.pos (msgdoc ("there is no point in documenting an import, documentation from line " ++ show pos ++ " ignored.")) stio (d:ds) - FixDcl {pos=p} -> do - E.warn p (msgdoc ("there is no point in documenting a fixity declaration, documentation from line " + DefinitionS.Fix def -> do + E.warn def.pos (msgdoc ("there is no point in documenting a fixity declaration, documentation from line " ++ show pos ++ " ignored.")) stio (d:ds) - def | Just s <- def.doc = stio (def.{doc = Just (str ++ "\n\n" ++ s)} : ds) - | otherwise = stio (def.{doc = Just str} : ds) + DefinitionS.Mod def -> do + E.warn def.pos (msgdoc ("documenting a native module declaration is not supported. documentation from line " + ++ show pos ++ " ignored.")) + stio (d:ds) + DefinitionS.Doc def -> do + E.warn def.pos (msgdoc ("should not happen, this is a bug of the compiler. documentation from line " + ++ show pos ++ " ignored.")) + stio (d:ds) + DefinitionS.Typ def -> pure $ (DefinitionS.Typ $ def.{doc = Just $ str ++ maybe "" ("\n\n" ++) def.doc}) : ds + DefinitionS.Cla def -> pure $ (DefinitionS.Cla $ def.{doc = Just $ str ++ maybe "" ("\n\n" ++) def.doc}) : ds + DefinitionS.Ins def -> pure $ (DefinitionS.Ins $ def.{doc = Just $ str ++ maybe "" ("\n\n" ++) def.doc}) : ds + DefinitionS.Drv def -> pure $ (DefinitionS.Drv $ def.{doc = Just $ str ++ maybe "" ("\n\n" ++) def.doc}) : ds + DefinitionS.Ann def -> pure $ (DefinitionS.Ann $ def.{doc = Just $ str ++ maybe "" ("\n\n" ++) def.doc}) : ds + DefinitionS.Nat def -> pure $ (DefinitionS.Nat $ def.{doc = Just $ str ++ maybe "" ("\n\n" ++) def.doc}) : ds + DefinitionS.Fun def -> pure $ (DefinitionS.Fun $ def.{doc = Just $ str ++ maybe "" ("\n\n" ++) def.doc}) : ds + DefinitionS.Dat def -> pure $ (DefinitionS.Dat $ def.{doc = Just $ str ++ maybe "" ("\n\n" ++) def.doc}) : ds + DefinitionS.Jav def -> pure $ (DefinitionS.Jav $ def.{doc = Just $ str ++ maybe "" ("\n\n" ++) def.doc}) : ds {-- * look for adjacent function definitions with same name and join them @@ -158,30 +188,30 @@ unDoc (defs@(d:ds)) funJoin :: [DefinitionS] -> StG [DefinitionS] funJoin [] = return [] funJoin (defs@(d:ds)) - | FunDcl {lhs} <- d, Just name <- funbinding d - = do + | (DefinitionS.Fun f) <- d, Just name <- funbinding f + = do joined <- joinFuns (Pos name name) (funs name) rest <- funJoin (next name) - return (joined:rest) + return (DefinitionS.Fun joined:rest) | otherwise = do rest <- funJoin ds return (d:rest) where - funs name = takeWhile (sameFun name) defs + funs name = [f | DefinitionS.Fun f <- takeWhile (sameFun name) defs] next name = dropWhile (sameFun name) defs - sameFun name fundcl | Just n <- funbinding fundcl = n.value == name.value + sameFun name (DefinitionS.Fun fundcl) | Just n <- funbinding fundcl = n.value == name.value sameFun name _ = false - joinFuns :: Position -> [DefinitionS] -> StG DefinitionS + joinFuns :: Position -> [FunDcl] -> StG FunDcl joinFuns pos [f] = return f.{positions=[pos.first]} joinFuns pos (fs@(f:_)) | null f.pats = do E.error pos (msgdoc "function binding without patterns must have only a single equation") return f - | (g:_) <- filter (\x -> DefinitionS.vis x != f.vis) fs = do - E.error (getpos g.lhs) (msgdoc ("the visibility of " ++ g.name ++ + | (g:_) <- filter (\x -> FunDcl.vis x != f.vis) fs = do + E.error (getpos g.lhs) (msgdoc ("the visibility of the functions" ++ " must match that of the equation in line " ++ show pos)) stio f - | (g:_) <- filter (\x -> length (DefinitionS.pats x) != length f.pats) fs = do + | (g:_) <- filter (\x -> length (FunDcl.pats x) != length f.pats) fs = do E.error (getpos g.lhs) (msgdoc ("number of patterns (" ++ show (length g.pats) ++ ") must be the same as in previous equations (" ++ show (length f.pats))) @@ -196,8 +226,8 @@ funJoin (defs@(d:ds)) -- newpats = [ PVar (pos.change VARID ("_"++i)) 0 ("_" ++ i) | i <- take arity allAsciiBinders] newexpr = Case CNormal (mkTuple Con pos newvars) alts alts = [ CAlt {pat=mkpTuple (getpos g.lhs) g.pats, ex = g.expr} | - (g::DefinitionS) <- fs ] - olddoc = [ s | Just s <- map DefinitionS.doc fs ] + (g::FunDcl) <- fs ] + olddoc = [ s | Just s <- map FunDcl.doc fs ] newdoc = if null olddoc then Nothing else Just (joined "\n\n" olddoc) joinFuns _ [] = error "fatal compiler error: joinFuns []" diff --git a/frege/compiler/passes/Imp.fr b/frege/compiler/passes/Imp.fr index 52200bb8..dc584926 100644 --- a/frege/compiler/passes/Imp.fr +++ b/frege/compiler/passes/Imp.fr @@ -124,7 +124,7 @@ importAlways = [ ImpDcl {pos=Position.null, pack=Pack.raw p, as=Just n, imports --- Add an --- > import frege.Prelude --- unless there is an explicit import already or this is a prelude package. -importsFor :: Global -> [DefinitionS] +importsFor :: Global -> [ImpDcl] importsFor g = if noPreludeNeeded then imports else fakePreludeImport : imports @@ -138,7 +138,7 @@ importsFor g = if noPreludeNeeded imports = if isOff g.options.flags INPRELUDE then importAlways ++ importDefs else importDefs - importDefs = [ imp | imp@ImpDcl{} <- g.sub.sourcedefs ] + importDefs = [ imp | DefinitionS.Imp imp <- g.sub.sourcedefs ] -- import frege.Prelude fakePreludeImport = ImpDcl {pos=Position.null, pack=Pack.raw pPrelude, @@ -150,7 +150,7 @@ dependsOn g = [ Pack.new pack | ImpDcl{pack} <- importsFor g ] --- Find the java classes mentioned in the definitions dependsOnNative ∷ Global → [Pack] -dependsOnNative g = [ Pack.new jclas | JavDcl{name, isPure, jclas} ← g.definitions, +dependsOnNative g = [ Pack.new jclas | DefinitionS.Jav JavDcl{jclas} <- g.definitions, jclas `notElem` G.primitiveTypes, jclas `notElem` keys G.shortClassName, not (jclas.startsWith "java."), -- avoid JDK classes @@ -177,16 +177,15 @@ doImports = do mark the namespace as used, so as to avoid "unused import" messages. -} -useIfPublic :: DefinitionS -> StIO () +useIfPublic :: ImpDcl -> StIO () useIfPublic (imp@ImpDcl {pos,imports}) = do g <- getSTT let pack = Pack.new imp.pack as = maybe pack.nsName NSX imp.as when (imports.publik || any _.publik imports.items) do changeSTT _.{sub <- _.{nsUsed <- insert as ()}} -useIfPublic _ = return () -importHere :: DefinitionS -> StIO () +importHere :: ImpDcl -> StIO () importHere (imp@ImpDcl {pos,imports}) = do g <- getSTT let pack = Pack.new imp.pack @@ -225,7 +224,6 @@ importHere (imp@ImpDcl {pos,imports}) = do Just env -> importEnvSilent pos env as pack imports Nothing -> E.fatal pos (text ("module " ++ g.unpack pack ++ " should be here?")) stio () -importHere d = liftStG $ E.fatal d.pos (text ("must be an import definition, not " ++ show (constructor d))) --- Avoid warnings when we resolve items in the imported package diff --git a/frege/compiler/passes/Instances.fr b/frege/compiler/passes/Instances.fr index 82c3c0cb..df6b0fcc 100644 --- a/frege/compiler/passes/Instances.fr +++ b/frege/compiler/passes/Instances.fr @@ -39,18 +39,23 @@ import frege.compiler.gen.java.Common(sigmaJT) -} pass () = do g <- getST - let insdrv = filter isInstOrDerive g.sub.sourcedefs + -- not sure if including InsDcl here is needed; if ordering doesn't matter, + -- it shouldn't be needed + let insdrv = flip mapMaybe g.sub.sourcedefs $ \d -> + case d of + DefinitionS.Ins ins -> Just $ Left ins + DefinitionS.Drv drv -> Just $ Right drv + otherwise -> Nothing normal = filter (not • isInstOrDerive) g.sub.sourcedefs - derived <- mapSt deriveInst insdrv + derived <- mapSt (fmap DefinitionS.Ins . either pure deriveInst) insdrv enter (VName g.thisPack) derived -- change state so that derived instances will be transdef'ed later changeST Global.{sub <- SubSt.{sourcedefs = normal ++ derived}} stio ("instances", length derived) ---- make an instance definition from a derive definition, identity for instance definitions -deriveInst :: DefinitionS -> StG DefinitionS -deriveInst (d@InsDcl {pos}) = return d -deriveInst (d@DrvDcl {pos}) = do +--- make an instance definition from a derive definition +deriveInst :: DrvDcl -> StG InsDcl +deriveInst (d@DrvDcl{pos}) = do g <- getST clas <- defaultXName pos (TName pPreludeBase "Eq") d.clas typ <- U.transSigma d.typ @@ -82,10 +87,6 @@ deriveInst (d@DrvDcl {pos}) = do context = [ Ctx pos klasse (TVar pos KVar v) | v <- U.freeTVnames [] rho ] withDerivedContext pos sigma _ _ = sigma -deriveInst d = do - E.fatal d.pos (text ("deriveInst got definition with constructor " - ++ show (constructor d))) - --- List of derivable classes --- Note that special classes like 'Exceptional' and 'JavaType' are not listed here. --- This controls also whether type variables in the instance type must have the same class membership. @@ -204,11 +205,12 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive hfun a b = mkop (mkop (int 31) opMul a) opAdd b hashex = fold hfun (int 1) (c:hs) + deriveClass :: String -> [DefinitionS] -- derive Hashable - deriveClass "Hashable" = [publicfun "hashCode" [parg1] hash] + deriveClass "Hashable" = [DefinitionS.Fun $ publicfun "hashCode" [parg1] hash] -- derive Eq - deriveClass "Eq" = [publicfun "==" [parg1,parg2] ifx, publicfun "hashCode" [parg1] hash] where + deriveClass "Eq" = map DefinitionS.Fun [publicfun "==" [parg1,parg2] ifx, publicfun "hashCode" [parg1] hash] where ifx = if length ctrs == 1 then eex else Ifte cond eex vFalse eex = if isEnum then vTrue else Case CNormal (vtup varg1 varg2) alts alts = map mkequalalt ctrs ++ deflt @@ -232,10 +234,10 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive andit (x:xs) = nApp (nApp (gvar "PreludeBase" "&&") x) (andit xs) -- derive Ord deriveClass "Ord" - | [prod] <- ctrs = [publicfun "<=>" + | [prod] <- ctrs = [DefinitionS.Fun $ publicfun "<=>" [conpat prod "a", conpat prod "b"] (ordex (arity prod) 0)] - | otherwise = [publicfun "<=>" [parg1, parg2] outercase] + | otherwise = [DefinitionS.Fun $ publicfun "<=>" [parg1, parg2] outercase] where --* case a1 <=> b1 of { Eq -> case a2 <=> b2 of { ... ordex a n @@ -270,13 +272,13 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive sex = Case CNormal (var "r") [(mktupshowalt con)] show = publicfun "show" [var "r"] sex -- showsub = publicfun "showsub" [] (var "show") - in [show] + in [DefinitionS.Fun show] | otherwise = let sex = Case CNormal (var "r") (mkshowalts ctrs) subex = Case CNormal (var "r") (mkshowsubalts ctrs) show = publicfun "show" [var "r"] sex showsub = publicfun "showsub" [var "r"] subex - in [show, showsub] + in map DefinitionS.Fun [show, showsub] where mkshowalts constr = map mkshowalt constr mkshowsubalts constr = map mkshowsubalt constr @@ -306,7 +308,7 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive joinit s [v] = showsv s v ")" joinit s (a:b:c) = joinit (showsv s a ", ") (b:c) - deriveClass "Enum" = [ord, from, succ, pred, + deriveClass "Enum" = map DefinitionS.Fun [ord, from, succ, pred, eFromThenTo, eFromThen] -- , eq] where -- eq = publicfun "==" [pvar "a", pvar "b"] eqex @@ -345,7 +347,7 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive | otherwise = singleton min eFTex = fold nApp (var "enumFromThenTo") [varg1, varg2, minmax] - deriveClass "Bounded" = [minval, maxval] + deriveClass "Bounded" = map DefinitionS.Fun [minval, maxval] where ctup = sortBy (comparing Symbol.cid) ctrs ctdn = reverse ctup @@ -355,6 +357,7 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive minval = publicfun "minBound" [] min deriveClass "Exceptional" = [ + DefinitionS.Nat $ NatDcl{pos, vis=Public, name="javaClass", txs = [(ForAll [] (RhoTau [] tapp), [])], meth = fromMaybe (rawName jt) forty.nativ ++ ".class", diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index 47455855..c48203fc 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -91,7 +91,7 @@ pass = do g <- getSTT -- before we start, we must have operator information - forM_ g.sub.sourcedefs (liftStG . fixity) + mapM_ (liftStG . fixity) [x | DefinitionS.Fix x <- g.sub.sourcedefs] -- do the main part forsome g.sub.sourcedefs (liftStG . transdef [] (VName g.thisPack)) @@ -108,6 +108,7 @@ pass = do --- change 'Symbol.op' field according to @infix@ definitions. +fixity :: FixDcl -> StG () fixity (d@FixDcl{pos, opid, ops}) = foreach ops changeop where changeop op = do @@ -133,9 +134,7 @@ fixity (d@FixDcl{pos, opid, ops}) = foreach ops changeop changeSym sym.{op=opid} else do E.error pos (text (nicer sym g ++ " cannot have a precedence")) - -fixity _ = return () --- translate inline candidates from exporting package clause to QNames and set exported flag in corresponding symbols inlineCandidates = do @@ -193,23 +192,29 @@ varcon _ = Nothing transdef ∷ [QName] → (String→QName) → DefinitionS → StG () -transdef env fname def = case def of - ImpDcl{} → pure () -- nothing to do here - FixDcl{} → pure () -- nothing to do here - DocDcl{} → pure () -- nothing to do here - TypDcl{} → pure () -- already done in TypeAlias pass - ClaDcl{} → transClaDcl env fname def - InsDcl{} → transInsDcl env fname def - DrvDcl{} → pure () -- already done in Instances pass - AnnDcl{} → transAnnDcl env fname def - NatDcl{} → transNatDcl env fname def - FunDcl{} → transFunDcl env fname def - DatDcl{} → transDatDcl env fname def - JavDcl{} → transJavDcl env fname def - ModDcl{} → transModDcl env fname def - -transFunDcl env fname (d@FunDcl {positions}) = do - let dname = defname d +transdef env fname def' = case def' of + DefinitionS.Imp _ -> pure () -- nothing to do here + DefinitionS.Fix _ -> pure () -- nothing to do here + DefinitionS.Doc _ -> pure () -- nothing to do here + DefinitionS.Typ _ -> pure () -- already done in TypeAlias pass + DefinitionS.Cla def -> transClaDcl env fname def + DefinitionS.Ins def -> transInsDcl env fname def + DefinitionS.Drv _ -> pure () -- already done in Instances pass + DefinitionS.Ann def -> transAnnDcl env fname def + DefinitionS.Nat def -> transNatDcl env fname def + DefinitionS.Fun def -> transFunDcl env fname def + DefinitionS.Dat def -> transDatDcl env fname def + DefinitionS.Jav def -> transJavDcl env fname def + DefinitionS.Mod def -> transModDcl env fname def + +transLetMemberS :: [QName] -> (String -> QName) -> LetMemberS -> StG () +transLetMemberS env fname def' = case def' of + LetMemberS.Ann def -> transAnnDcl env fname def + LetMemberS.Fun def -> transFunDcl env fname def + +transFunDcl :: [QName] -> (String -> QName) -> FunDcl -> StG () +transFunDcl env fname (d@FunDcl {positions}) = do + let dname = defname $ LetMemberS.Fun d aname = if null env then fname dname else findLocal env dname case funbinding d of Just _ -> common aname d @@ -268,7 +273,6 @@ transFunDcl env fname (d@FunDcl {positions}) = do othr -> changeSym sym.{expr = Just (return x)} | otherwise = E.fatal pos (text ("expected function, found " ++ sym.nice g)) nothing -> do E.fatal pos (text ("Cannot happen, function " ++ aname.nice g ++ " missing")) -transFunDcl _ _ d = E.fatal d.pos (text "not a fun dcl") {- AnnDcl {pos::Line, vis::Visibility, name::String, typ::SigmaT t, doc::Maybe String} @@ -276,6 +280,7 @@ transFunDcl _ _ d = E.fatal d.pos (text "not a fun dcl") typ::Sigma, expr::Maybe Expr, nativ::Maybe String, pur::Bool, anno::Bool} /// variable -} +transAnnDcl :: [QName] -> (String -> QName) -> AnnDcl -> StG () transAnnDcl env fname (d@AnnDcl {pos}) = do g <- getST let aname = if null env then fname d.name else findLocal env d.name @@ -292,8 +297,8 @@ transAnnDcl env fname (d@AnnDcl {pos}) = do ++ ". Place this annotation before line " ++ show dpos.line ++ " to prevent this error.")) | otherwise = E.fatal pos (text ("expected function, found " ++ sym.nice g)) -transAnnDcl _ _ d = E.fatal d.pos (text "not a ann dcl") +transNatDcl :: [QName] -> (String -> QName) -> NatDcl -> StG () transNatDcl env fname (d@NatDcl {pos}) = do g <- getST let aname = fname d.name @@ -311,7 +316,7 @@ transNatDcl env fname (d@NatDcl {pos}) = do changeSym sym.{typ = ovlsigma, over} | otherwise = E.fatal pos (text ("expected function, found " ++ sym.nice g)) where - overload ∷ DefinitionS → Symbol → SigmaS → [TauS] → StG QName + overload :: NatDcl -> Symbol -> SigmaS -> [TauS] -> StG QName overload def sym sig exs = do g <- getST let name = U.unusedASCIIName sym.name g @@ -321,7 +326,7 @@ transNatDcl env fname (d@NatDcl {pos}) = do enter sym.{sid=0, name, typ = t, throwing = thrs, vis = Protected, gargs} return name -- extract and translate generic type arguments - mkGargs ∷ Bool → Symbol → DefinitionS → Sigma → StG [Tau] + mkGargs ∷ Bool → Symbol → NatDcl → Sigma → StG [Tau] mkGargs ovld sym d sig = do g ← getST dgargs ← case d.gargs of @@ -421,8 +426,7 @@ transNatDcl env fname (d@NatDcl {pos}) = do <> text "} for" <+> text (nicer sym.name g)) return gargs -transNatDcl _ _ d = E.fatal d.pos (text "not a nat dcl") - +transInsDcl :: [QName] -> (String -> QName) -> InsDcl -> StG () transInsDcl env fname (d@InsDcl {pos}) = do g <- getST let iname = TName g.thisPack (Enter.insName d) @@ -435,15 +439,19 @@ transInsDcl env fname (d@InsDcl {pos}) = do changeSym sym.{clas,typ} foreach d.defs (transdef [] (MName iname)) nothing -> do E.fatal pos (text ("Cannot happen, instance " ++ iname.nice g ++ " missing")) -transInsDcl _ _ d = E.fatal d.pos (text "not a ins dcl") -private refreshType ∷ DefinitionS → Symbol → StG Symbol -private refreshType d sym = do +private refreshTypeDatDcl :: DatDcl -> Symbol -> StG Symbol +private refreshTypeDatDcl DatDcl{name, pos, vars} = refreshType name pos vars +private refreshTypeJavDcl :: JavDcl -> Symbol -> StG Symbol +private refreshTypeJavDcl JavDcl{name, pos, vars} = refreshType name pos vars + +private refreshType :: String -> Position -> [TauS] -> Symbol -> StG Symbol +private refreshType name pos vars sym = do g ← getST - vars ← mapM (\t → transTau t >>= forceTau) d.vars - let !dname = TName g.thisPack d.name - dtcon = TCon {pos=d.pos, name=dname} + vars <- mapM (\t -> transTau t >>= forceTau) vars + let !dname = TName g.thisPack name + dtcon = TCon {pos, name=dname} dtau = dtcon.mkapp vars :: Tau !dsig = ForAll vars (RhoTau [] dtau) !kind = foldr KApp KType dsig.kinds :: Kind @@ -451,12 +459,13 @@ private refreshType d sym = do changeSym newsym pure newsym +transDatDcl :: [QName] -> (String -> QName) -> DatDcl -> StG () transDatDcl env fname (d@DatDcl {pos}) = do g <- getST let tname = TName g.thisPack d.name case g.findit tname of Just sym | SymT {pos} <- sym = do - sym ← refreshType d sym + sym ← refreshTypeDatDcl d sym foreach d.ctrs (transCon sym.typ (MName tname)) foreach d.defs (transdef [] (MName tname)) polymorphicFields tname @@ -606,8 +615,8 @@ transDatDcl env fname (d@DatDcl {pos}) = do -- when (con.strsig.isStrict) (foreach nfs (strictFieldsCheck cname)) changeSym con.{typ=sig}.{flds=nfs . snd . U.returnType $ sig.rho} _ -> E.fatal pos (text ("constructor `" ++ cname.nice g ++ "` vanished.")) -transDatDcl _ _ d = E.fatal d.pos (text "not a data dcl") +transJavDcl :: [QName] -> (String -> QName) -> JavDcl -> StG () transJavDcl env fname (d@JavDcl {pos}) = do g <- getST let tname = TName g.thisPack d.name @@ -615,7 +624,7 @@ transJavDcl env fname (d@JavDcl {pos}) = do Just sym | SymT {nativ = Just nativ} <- sym = do -- Redo types - sym ← refreshType d sym + sym ← refreshTypeJavDcl d sym -- extract and translate generic type arguments let doit (Just gs) = mapM transTau gs >>= mapM forceTau doit Nothing = pure sym.typ.tvars @@ -650,8 +659,8 @@ transJavDcl env fname (d@JavDcl {pos}) = do E.warn pos (text (nativ ++ ": this way of declaring array types is strongly discouraged.")) | otherwise = E.fatal pos (text ("Cannot happen, native type " ++ tname.nice g ++ " is not native?")) nothing -> do E.fatal pos (text ("Cannot happen, data " ++ tname.nice g ++ " missing")) -transJavDcl _ _ d = E.fatal d.pos (text "not a java dcl") +transClaDcl :: [QName] -> (String -> QName) -> ClaDcl -> StG () transClaDcl env fname (d@ClaDcl {pos}) = do g <- getST let tname = TName g.thisPack d.name @@ -663,13 +672,14 @@ transClaDcl env fname (d@ClaDcl {pos}) = do | SymC {pos} <- sym = do transclass d sym -- ; stio (Just d) | otherwise = do E.fatal pos (text ("expected class, found " ++ sym.nice g)) -transClaDcl _ _ d = E.fatal d.pos (text "not a class dcl") -- record the super type and super interfaces of the module in Options. +transModDcl :: [QName] -> (String -> QName) -> ModDcl -> StG () transModDcl env fname ModDcl{pos, extending, implementing, code} = do g ← getST - case length (filter _.{code?} g.sub.sourcedefs) of - 1 = do + case [m | DefinitionS.Mod m <- g.sub.sourcedefs] of + -- exactly one element + [_] = do ext ← case extending of Just t → Just <$> (transTau t >>= starSigma) _ → return Nothing @@ -679,8 +689,6 @@ transModDcl env fname ModDcl{pos, extending, implementing, code} = do starSigma sig = fst <$> kiSigmaX sig KType _ = E.error pos (msgdoc ("There may be at most one native module definition.")) -transModDcl _ _ d = E.fatal d.pos (text "not a mod dcl") - --- Type for overloaded functions ovlsigma :: Sigma ovlsigma = ForAll{ bound=[tvar], @@ -856,15 +864,23 @@ fName env fname nm = case findLocal env nm of Local 0 _ -> fname nm local -> local -defname (d@FunDcl{}) +defname :: LetMemberS -> String +defname (LetMemberS.Fun d) | Just t <- funbinding d = t.value | not (patbinding d), Vbl{name=Simple excl} <- d.lhs, excl.value == "!" || excl.value=="?", [pat] <- d.pats, Just t <- funbinding d.{lhs=pat, pats=[]} = t.value -defname AnnDcl{name} = name -defname x = error ("defname: no FunDcl: " ++ show (constructor x)) + | otherwise = error "defname: neither funbinding nor patbinding" +defname (LetMemberS.Ann AnnDcl{name}) = name + +annosLast :: [LetMemberS] -> [LetMemberS] +annosLast defs = funs ++ annos + where + (annos, funs) = DL.partition isAnno defs + isAnno (LetMemberS.Ann _) = true + isAnno _ = false transExpr :: [QName] -> (String -> QName) -> ExprS -> StG D.Expr @@ -922,9 +938,9 @@ transExpr env fname ex = do b <- transExpr env fname b return (D.Ifte c a b Nothing) Let {defs,ex} -> do - defs <- Fix.fixdefs defs - nenv <- foldM enterlocal [] (Enter.annosLast defs) - foreach defs (transdef (nenv++env) fname) + defs <- fmap (mapMaybe LetMemberS.fromDefinitionS) $ Fix.fixdefs $ map LetMemberS.toDefinitionS defs + nenv <- foldM enterlocal [] (annosLast defs) + foreach defs (transLetMemberS (nenv++env) fname) ex <- transExpr (nenv++env) fname ex syms <- mapSt U.findV nenv foreach (syms) checkDefined @@ -932,14 +948,14 @@ transExpr env fname ex = do where checkDefined (SymV {expr = Just _}) = stio () checkDefined sym = E.error sym.pos (msgdoc (nice sym g ++ " is annotated but not defined.")) - enterlocal :: [QName] -> DefinitionS -> StG [QName] + enterlocal :: [QName] -> LetMemberS -> StG [QName] enterlocal env def = case findLocal env (defname def) of Local 0 _ = do -- not yet entered uid <- uniqid - Enter.enter1 (Local uid) def + Enter.enter1 (Local uid) def.toDefinitionS return (Local uid (defname def):env) Local u _ = do - Enter.enter1 (Local u) def + Enter.enter1 (Local u) def.toDefinitionS return env _ = error "onlyLocal possible" Lam {pat=spat,ex,fromDO} -> do @@ -1150,11 +1166,11 @@ assoc t | otherwise = error ("no precedence for operator: " ++ show t) -transclass :: DefinitionS -> Symbol -> StG () +transclass :: ClaDcl -> Symbol -> StG () transclass def sym = do supers <- liftM (map unJust • filter isJust) (mapSt (resolveXName def.pos sym) def.supers) changeSym sym.{supers = unique supers} g <- getST - foreach def.defs (transdef [] (MName sym.name)) + foreach def.members (transdef [] (MName sym.name) . _.toDefinitionS) diff --git a/frege/compiler/passes/TypeAlias.fr b/frege/compiler/passes/TypeAlias.fr index dd1f1257..9b9ef217 100644 --- a/frege/compiler/passes/TypeAlias.fr +++ b/frege/compiler/passes/TypeAlias.fr @@ -30,17 +30,14 @@ import Compiler.common.SymbolTable pass = do g <- getST - let (adefs,other) = partitioned isTypDcl g.sub.sourcedefs + let (adefs,other) = extractTypDcl g.sub.sourcedefs adeps = map aliasdep adefs agrps = tsort adeps aflat = [ a | grp <- agrps, a <- grp ] - sdefs = [ d | a <- aflat, d <- adefs, QName.base a == DefinitionS.name d ] - isTypDcl (TypDcl {pos}) = true - isTypDcl _ = false + sdefs = [ d | a <- aflat, d <- adefs, QName.base a == TypDcl.name d ] aliasdep (TypDcl {pos, name, typ}) = (tn, filter (g.our) deps) where tn = TName g.thisPack name deps = collectRho typ.rho [] - aliasdep x = error "no TypDcl" collectRho (RhoFun _ sig rho) acc = collectRho rho (collectSigma sig acc) collectRho (RhoTau _ tau) acc = collectTau tau acc collectSigma (ForAll _ rho) acc = collectRho rho acc @@ -65,14 +62,26 @@ pass = do | tn `elem` deps = E.error (getpos tn) (msgdoc ("Self referential type alias `" ++ QName.nice tn g ++ "`")) | otherwise = stio () - changeST Global.{sub <- SubSt.{sourcedefs=reverse other}} -- no more type aliases henceforth + changeST Global.{sub <- SubSt.{sourcedefs=other}} -- no more type aliases henceforth foreach agrps checkmutual foreach adeps checkselfref g <- getST unless (g.errors > 0) do foreach sdefs transalias return ("type aliases", length adefs) - -transalias :: DefinitionS -> StG () + +extractTypDcl :: [DefinitionS] -> ([TypDcl], [DefinitionS]) +extractTypDcl = \xs -> (typDcls xs, others xs) + where + typDcls [] = [] + typDcls (x:xs) + | DefinitionS.Typ t <- x = t : typDcls xs + | otherwise = typDcls xs + others [] = [] + others (x:xs) + | DefinitionS.Typ _ <- x = others xs + | otherwise = x : others xs + +transalias :: TypDcl -> StG () transalias (d@TypDcl {pos}) = do g <- getST let tname = TName g.thisPack d.name @@ -106,4 +115,3 @@ transalias (d@TypDcl {pos}) = do <+> text (joined ", " bad) <+> text " must either be type args or bound in forall, but not both.") nothing -> E.fatal pos (text ("Cannot happen, type alias " ++ tname.nice g ++ " missing")) -transalias _ = return () diff --git a/frege/compiler/types/SourceDefinitions.fr b/frege/compiler/types/SourceDefinitions.fr index 0dd1b367..d872f9ff 100644 --- a/frege/compiler/types/SourceDefinitions.fr +++ b/frege/compiler/types/SourceDefinitions.fr @@ -24,39 +24,98 @@ infixl 16 `App` `nApp` `TApp` * definitions -} data DefinitionS = - ImpDcl {pos::Position, pack::String, as::Maybe String, - imports::ImportList} - | FixDcl {pos::Position, opid::TokenID, ops::[String]} - | DocDcl {pos::Position, text::String} - | TypDcl {pos::Position, vis::Visibility, name::String, - vars::[TauS], typ::SigmaS, doc::Maybe String} - | ClaDcl {pos::Position, vis::Visibility, name::String, - clvar::TauS, supers::[SName], - defs::[DefinitionS], doc::Maybe String} - | InsDcl {pos::Position, vis::Visibility, - clas::SName, typ::SigmaS, - defs::[DefinitionS], doc::Maybe String} - | DrvDcl {pos::Position, vis::Visibility, - clas::SName, typ::SigmaS, - doc::Maybe String} - | AnnDcl {pos::Position, vis::Visibility, name::String, typ::SigmaS, doc::Maybe String} - | NatDcl {pos::Position, vis::Visibility, name::String, txs::[SigExs], - meth::String, isPure::Bool, gargs::Maybe [TauS], doc::Maybe String} - | FunDcl {vis::Visibility, lhs::ExprS, - pats::[ExprS], expr::ExprS, - doc::Maybe String, - positions::[Token] --- the tokens that introduce the equally named definitions - } - | DatDcl {pos::Position, vis::Visibility, name::String, newt :: Bool, - vars::[TauS], ctrs::[DCon], defs::[DefinitionS], - doc::Maybe String} - | JavDcl {pos::Position, vis::Visibility, name::String, isPure::Bool, - jclas::String, vars::[TauS], gargs::Maybe [TauS], defs::[DefinitionS], - doc::Maybe String} - | ModDcl {pos::Position, extending::Maybe TauS, implementing::[TauS], code::[Token]} + protected Imp ImpDcl + | protected Fix FixDcl + | protected Doc DocDcl + | protected Typ TypDcl + | protected Cla ClaDcl + | protected Ins InsDcl + | protected Drv DrvDcl + | protected Ann AnnDcl + | protected Nat NatDcl + | protected Fun FunDcl + | protected Dat DatDcl + | protected Jav JavDcl + | protected Mod ModDcl + +--- A sum type of definitions which are valid members of a @class@ excluding documentation +data ClassMemberS = + protected Ann AnnDcl + | protected Nat NatDcl + | protected Fun FunDcl + where + toDefinitionS :: ClassMemberS -> DefinitionS + toDefinitionS (Ann x) = DefinitionS.Ann x + toDefinitionS (Nat x) = DefinitionS.Nat x + toDefinitionS (Fun x) = DefinitionS.Fun x + fromDefinitionS :: DefinitionS -> Maybe ClassMemberS + fromDefinitionS (DefinitionS.Ann x) = Just $ Ann x + fromDefinitionS (DefinitionS.Nat x) = Just $ Nat x + fromDefinitionS (DefinitionS.Fun x) = Just $ Fun x + fromDefinitionS _ = Nothing + vis :: ClassMemberS -> Visibility + vis (Ann AnnDcl{vis=v}) = v + vis (Nat NatDcl{vis=v}) = v + vis (Fun FunDcl{vis=v}) = v + chgVis :: ClassMemberS -> (Visibility -> Visibility) -> ClassMemberS + chgVis (Ann x) f = Ann $ x.{vis <- f} + chgVis (Nat x) f = Nat $ x.{vis <- f} + chgVis (Fun x) f = Fun $ x.{vis <- f} + +{-- + - A sum type of definitions which are valid members of @let@ expressions or + - @where@ clauses on ordinary functions. + -} +data LetMemberS = + protected Ann AnnDcl + | protected Fun FunDcl + where + toDefinitionS :: LetMemberS -> DefinitionS + toDefinitionS (Ann x) = DefinitionS.Ann x + toDefinitionS (Fun x) = DefinitionS.Fun x + fromDefinitionS :: DefinitionS -> Maybe LetMemberS + fromDefinitionS (DefinitionS.Ann x) = Just $ Ann x + fromDefinitionS (DefinitionS.Fun x) = Just $ Fun x + fromDefinitionS _ = Nothing + +data ImpDcl = ImpDcl {pos::Position, pack::String, as::Maybe String, + imports::ImportList} +data FixDcl = FixDcl {pos::Position, opid::TokenID, ops::[String]} +data DocDcl = DocDcl {pos::Position, text::String} +data TypDcl = TypDcl {pos::Position, vis::Visibility, name::String, + vars::[TauS], typ::SigmaS, doc::Maybe String} +data ClaDcl = ClaDcl {pos::Position, vis::Visibility, name::String, + clvar::TauS, supers::[SName], + defs::[DefinitionS], doc::Maybe String} + where + -- after the @fix@ pass, all of 'ClaDcl.defs' should return 'Just' if applied to + -- 'ClassMemberS.fromDefinitionS' + members :: ClaDcl -> [ClassMemberS] + members this = mapMaybe ClassMemberS.fromDefinitionS this.defs +data InsDcl = InsDcl {pos::Position, vis::Visibility, + clas::SName, typ::SigmaS, + defs::[DefinitionS], doc::Maybe String} +data DrvDcl = DrvDcl {pos::Position, vis::Visibility, + clas::SName, typ::SigmaS, + doc::Maybe String} +data AnnDcl = AnnDcl {pos::Position, vis::Visibility, name::String, typ::SigmaS, doc::Maybe String} +data NatDcl = NatDcl {pos::Position, vis::Visibility, name::String, txs::[SigExs], + meth::String, isPure::Bool, gargs::Maybe [TauS], doc::Maybe String} +data FunDcl = FunDcl {vis::Visibility, lhs::ExprS, + pats::[ExprS], expr::ExprS, + doc::Maybe String, + positions::[Token]} --- the tokens that introduce the equally named definitions +data DatDcl = DatDcl {pos::Position, vis::Visibility, name::String, newt :: Bool, + vars::[TauS], ctrs::[DCon], defs::[DefinitionS], + doc::Maybe String} +data JavDcl = JavDcl {pos::Position, vis::Visibility, name::String, isPure::Bool, + jclas::String, vars::[TauS], gargs::Maybe [TauS], defs::[DefinitionS], + doc::Maybe String} +data ModDcl = ModDcl {pos::Position, extending::Maybe TauS, implementing::[TauS], code::[Token]} --- Is this a function binding? --- If so, return the identifier. +funbinding :: FunDcl -> Maybe Token funbinding FunDcl{lhs = Vbl{name=Simple{id}},pats} | null pats = Just id | id.value != "!", @@ -157,7 +216,7 @@ data ExprS = | !ConFS { name::SName, fields::[(String, ExprS)] } --- > Con{field1 = ex1, field2 = ex2} | !App { fun, arg::ExprS } --- > fun arg - | !Let { defs::[DefinitionS], ex :: ExprS } --- > let {defs} in ex + | !Let { defs::[LetMemberS], ex :: ExprS } --- > let {defs} in ex | !Lam { pat, ex::ExprS, fromDO :: Bool } --- > \pat -> ex | !Ifte { cnd, thn, els::ExprS } --- > if cnd then thn else els | !Mem { ex::ExprS, member::Token } --- > ex.member diff --git a/frege/tools/Splitter.fr b/frege/tools/Splitter.fr index 232babe6..df9227e2 100644 --- a/frege/tools/Splitter.fr +++ b/frege/tools/Splitter.fr @@ -19,7 +19,7 @@ import Compiler.types.QNames import Compiler.types.Types import Compiler.types.Patterns import Compiler.types.Expression -import Compiler.types.SourceDefinitions(DefinitionS) +import Compiler.types.SourceDefinitions(DefinitionS, ImpDcl) import Compiler.types.Symbols import Compiler.types.Global as G @@ -278,7 +278,7 @@ printMods g modul mbHelper mItems hItems syms = do mod.println return hpw Nothing -> do - unless (modul `elem` [ pack | ImpDcl{pack} <- g.definitions]) do + unless (modul `elem` [ pack | DefinitionS.Imp ImpDcl{pack} <- g.definitions ]) do orig.println orig.println "-- import outsourced modules" orig.println ("import " ++ modul) @@ -374,9 +374,11 @@ printHeader pw pack = do pw.println (" -- generated by Splitter") +printImports :: Global -> MutableIO PrintWriter -> IO () printImports g pw = mapM_ (printImpDcl g pw) - [ idef | idef @ImpDcl{pos, pack, as, imports} <- g.definitions ] + [ idef | DefinitionS.Imp idef <- g.definitions ] +printImpDcl :: Global -> MutableIO PrintWriter -> ImpDcl -> IO () printImpDcl g pw ImpDcl{pos, pack, as, imports} = do PrintWriter.println pw ("import " ++ pack ++ maybe "" (" as " ++) as @@ -396,7 +398,6 @@ printImpDcl g pw ImpDcl{pos, pack, as, imports} = do ++ (if null alias then "" else if alias == name.id.value then "" else " " ++ alias) -printImpDcl g pw _ = error "can only print ImpDcl" dotDep :: MutableIO PrintWriter -> Global -> (TreeMap QName [QName]) -> [QName] -> IO () dotDep writer g tree qns = do From f5771087d8b016efa4eb3a1b5b589976a22fe8f0 Mon Sep 17 00:00:00 2001 From: matil019 Date: Mon, 21 Oct 2019 12:48:01 +0900 Subject: [PATCH 02/95] Add instance Alt Maybe This is needed by the lenses to be added later. --- frege/prelude/Maybe.fr | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/frege/prelude/Maybe.fr b/frege/prelude/Maybe.fr index 173f5330..e474c49a 100644 --- a/frege/prelude/Maybe.fr +++ b/frege/prelude/Maybe.fr @@ -71,13 +71,16 @@ instance Monad Maybe where a >> b = a >>= const b -- pure = Just +instance Alt Maybe where + Nothing <|> x = x + x <|> _ = x + instance MonadFail Maybe where fail = const Nothing instance MonadPlus Maybe where mzero = Nothing - mplus Nothing x = x - mplus x _ = x + mplus = (<|>) instance ListEmpty Maybe where empty = Nothing From c4dfb235c02666f00033a9151239005f46e1c289 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 17 Oct 2019 18:06:51 +0900 Subject: [PATCH 03/95] [norun] Change SymbolT.SymT to an independent data type See frege/compiler/types/Symbols.fr As a first step to decomposing the sum-record SymbolT, SymT was isolated to an independent data type. Some parts of code were deliberately rewritten into refutable case analyses so that compiler warnings are triggered. --- frege/compiler/Classes.fr | 2 +- frege/compiler/GenMeta.fr | 21 +++++++++++---------- frege/compiler/Kinds.fr | 6 +++--- frege/compiler/Typecheck.fr | 6 +++--- frege/compiler/Utilities.fr | 6 +++--- frege/compiler/classes/Nice.fr | 2 +- frege/compiler/common/JavaName.fr | 6 +++--- frege/compiler/common/Trans.fr | 8 ++++---- frege/compiler/gen/java/Common.fr | 6 +++--- frege/compiler/gen/java/DataCode.fr | 12 ++++++------ frege/compiler/gen/java/InstanceCode.fr | 4 ++-- frege/compiler/gen/java/Match.fr | 18 ++++++++++-------- frege/compiler/gen/java/VarCode.fr | 10 ++++++---- frege/compiler/passes/Enter.fr | 7 ++++--- frege/compiler/passes/Fields.fr | 2 +- frege/compiler/passes/GenCode.fr | 2 +- frege/compiler/passes/Imp.fr | 16 ++++++++++------ frege/compiler/passes/Instances.fr | 2 +- frege/compiler/passes/Transdef.fr | 10 +++++----- frege/compiler/tc/Methods.fr | 4 ++-- frege/compiler/types/Symbols.fr | 19 +++++++++++-------- frege/ide/Utilities.fr | 10 +++++----- frege/tools/doc/Utilities.fr | 2 +- 23 files changed, 97 insertions(+), 84 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index 4c7a14bf..a88ecae3 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -395,7 +395,7 @@ instForClass alien c iname = do isym <- U.findI iname case instTSym (Symbol.typ isym) g of - Just (tsym@SymT {pos}) -> do + Just (tsym@(SymbolT.T SymT{pos})) -> do E.logmsg TRACE6 (Symbol.pos isym) (text (isym.nice g ++ " " ++ tsym.nice g)) when (not alien || g.our isym.name) do diff --git a/frege/compiler/GenMeta.fr b/frege/compiler/GenMeta.fr index aa13105b..2dd42006 100644 --- a/frege/compiler/GenMeta.fr +++ b/frege/compiler/GenMeta.fr @@ -151,7 +151,7 @@ genmeta = do let isyms = [sym | sym@SymI {pos} <- values g.thisTab, sym.vis!=Private] symis <- liftStG $ mapSt annoSymI isyms - let tsyms = [sym | sym@SymT {pos} <- values g.thisTab, sym.vis!=Private] + let tsyms = [sym | sym@(SymbolT.T SymT{vis}) <- values g.thisTab, vis!=Private] symts <- liftStG $ mapSt annoSymT tsyms symvs <- liftStG $ envValues g.thisTab @@ -659,17 +659,18 @@ annoSymI sym = do ("doc", maybe PP.nil anno (Symbol.doc sym))] stio a -annoSymT sym = do +annoSymT :: Symbol -> StG DOCUMENT +annoSymT (SymbolT.T sym) = do g ← getST - typ <- sigIndex (Symbol.typ sym) - memc <- envCons (Symbol.env sym) - meml <- envLinks (Symbol.env sym) - memv <- envValues (Symbol.env sym) + typ <- sigIndex sym.typ + memc <- envCons sym.env + meml <- envLinks sym.env + memv <- envValues sym.env kind <- kindIndex sym.kind gargs ← mapM tauIndex sym.gargs let a = meta g "SymT" [ - ("offset", anno (Symbol.pos sym).first.offset), - ("name", annoG g (Symbol.name sym)), + ("offset", anno sym.pos.first.offset), + ("name", annoG g sym.name), ("typ", anno typ), ("kind", anno kind), ("cons", some memc), @@ -679,8 +680,8 @@ annoSymT sym = do ("isEnum", if sym.enum then anno true else PP.nil), ("pur", if sym.pur then anno true else PP.nil), ("newt", if sym.newt then anno true else PP.nil), - ("nativ", maybe PP.nil anno (Symbol.nativ sym)), + ("nativ", maybe PP.nil anno sym.nativ), ("gargs", if null gargs then PP.nil else anno gargs), ("publik", if sym.vis == Public then PP.nil else anno false), - ("doc", maybe PP.nil anno (Symbol.doc sym))] + ("doc", maybe PP.nil anno sym.doc)] pure a diff --git a/frege/compiler/Kinds.fr b/frege/compiler/Kinds.fr index 9c73e4cc..1fb61057 100644 --- a/frege/compiler/Kinds.fr +++ b/frege/compiler/Kinds.fr @@ -409,7 +409,7 @@ varKind (KApp a b) = varKind a || varKind b varKind _ = false --- find the 'Sigmas' of all constructors of the given type 'Symbol' -conSigmas SymT{env} = [ typ | SymD{typ} <- values env ] +conSigmas (SymbolT.T SymT{env}) = [ typ | SymD{typ} <- values env ] conSigmas _ = [] --- give the direct dependencies of a type symbol @@ -418,8 +418,8 @@ typeDep g = ourNames g . sigmasTCons . conSigmas --- find our type symbols typeSyms :: Global -> [Symbol] typeSyms g = filter isOurT (values g.thisTab) where - isOurT SymT{name} = g.our name - isOurT _ = false + isOurT (SymbolT.T SymT{name}) = g.our name + isOurT _ = false --- find all our 'QNames' from a 'OrdSet' ourNames :: Global -> TreeMap QName β -> [QName] diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index 2ff0ac2b..b170f898 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -1073,7 +1073,7 @@ tcRho' (x@Mem {ex,member}) ety = do else member case instTauSym tau g of - Just (SymT {name, env, nativ, newt}) + Just (SymbolT.T SymT{name, env, nativ, newt}) | Just (SymV {name}) <- env.lookup member.value = do changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk original) (Right name)}} @@ -1103,7 +1103,7 @@ tcRho' (x@Mem {ex,member}) ety = do name == TName pPreludeIO "Mutable", -- it is some Mutable type TApp _ ntau <- tau, -- Mutable x ntau TCon{name=tcon}:_ <- ntau.flat, - Just SymT{nativ=Just s} <- g.findit tcon, + Just (SymbolT.T SymT{nativ=Just s}) <- g.findit tcon, SymV{name=m}:_ <- [ h | sup <- s:U.supersOfNativ s g, q <- U.typesOfNativ sup g, h <- g.findit (MName q member.value) ] @@ -1461,7 +1461,7 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do overloads g sym = case sym of SymV{over=[]} -> [sym] SymV{pos, name = MName{tynm, base}, over=(_:_)} - | Just SymT{nativ = Just this} <- g.findit tynm, + | Just (SymbolT.T SymT{nativ = Just this}) <- g.findit tynm, ov <- [ sy | m <- sym.over, sy <- g.findit m ], syms <- [ sy | s <- U.supersOfNativ this g, q <- U.typesOfNativ s g, diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index 23761d97..687f56dc 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -139,7 +139,7 @@ findI qname = do findT qname = do g <- getST case g.findit qname of - Just (symc@SymT {pos}) -> stio symc + Just (symc@SymbolT.T _) -> stio symc Just sym -> E.fatal sym.pos (fill (break("looked for type " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for type " ++ qname.nice g ++ ", found Nothing"))) @@ -519,7 +519,7 @@ transTApp (con:as) = do Nothing -> unit -- check if this is really a type constructor Just tn -> case g.findit tn of - Just (SymT {name,typ=ForAll bs _}) -> do + Just (SymbolT.T SymT{name,typ=ForAll bs _}) -> do let ncon = TCon {pos, name} as <- mapSt transTau as appTauSigmas ncon as @@ -1066,7 +1066,7 @@ isException g _ = Nothing type _ty_ denotes a sub type of @java.lang.Throwable@ -} isThrowable g ty = case instTauSym ty g of - Just SymT{nativ=Just x} -> x == "java.lang.Throwable" + Just (SymbolT.T SymT{nativ=Just x}) -> x == "java.lang.Throwable" || "java.lang.Throwable" `elem` supersOfNativ x g other -> false diff --git a/frege/compiler/classes/Nice.fr b/frege/compiler/classes/Nice.fr index 82adecad..a87a378c 100644 --- a/frege/compiler/classes/Nice.fr +++ b/frege/compiler/classes/Nice.fr @@ -97,7 +97,7 @@ instance Nice Symbol where nicer sym g = category sym g ++ " `" ++ sym.name.nicer g ++ "`" -protected category (SymT {name}) g = "data type" +protected category (SymbolT.T _) g = "data type" protected category (SymD {name}) g = "constructor" protected category (SymC {name}) g = "class" protected category (SymI {name}) g = "instance" diff --git a/frege/compiler/common/JavaName.fr b/frege/compiler/common/JavaName.fr index 40a4497b..e84ac2d0 100644 --- a/frege/compiler/common/JavaName.fr +++ b/frege/compiler/common/JavaName.fr @@ -32,9 +32,9 @@ javaName g qname = case g.findit qname of -} symJavaName g SymV{name=Local uid s} = JName "" (mangled s ++ "$" ++ show uid) symJavaName g sym = case sym of - SymT {name} -> t "T" name + SymbolT.T (SymT{name}) -> t "T" name SymD {name = MName tname base} -> case g.findit tname of - Just (SymT {product,enum}) -> if enum + Just (SymbolT.T SymT{product,enum}) -> if enum then memberOf (t "T" tname) (mangled base) else if product then t "T" tname @@ -43,7 +43,7 @@ symJavaName g sym = case sym of SymC {name} -> t "C" name SymI {name} -> t "I" name SymV {name = MName tname base} = case g.findit tname of - Just (SymT {product=false,enum=false,newt=false,nativ=Nothing}) + Just (SymbolT.T SymT{product=false,enum=false,newt=false,nativ=Nothing}) = memberOf tjname mbase Just (SymC {sid}) = memberOf (memberOf tjname "I") mbase other = memberOf tjname mbase diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index 36cef4cc..37d19918 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -210,7 +210,7 @@ patternStrictness p = case p of * [requires] @name@ must name a member of a data type in @g@ -} productCon (MName tname _) g = case g.findit tname of - Just (SymT {product}) -> product + Just (SymbolT.T (SymT {product})) -> product other -> error ("productCon " ++ tname.nice g ++ " is not a type") productCon _ _ = false @@ -221,7 +221,7 @@ productCon _ _ = false * [requires] @name@ must name a member of a data type in @g@ -} newtypeCon (MName tname _) g = case g.findit tname of - Just (SymT {newt}) -> newt + Just (SymbolT.T (SymT {newt})) -> newt other -> error ("productCon " ++ tname.nice g ++ " is not a type") newtypeCon _ _ = false @@ -285,7 +285,7 @@ patsComplete g ps where pnames = map Pattern.qname ps cons (MName tname _) = case Global.findit g tname of - Just (SymT {env}) -> U.envConstructors env + Just (SymbolT.T (SymT {env})) -> U.envConstructors env _ -> [] cons _ = [] mkCon (SymD {name,flds}) = PCon {pos=Position.null, qname=name, @@ -326,7 +326,7 @@ patsComplete g ps -- constructors :: Pattern -> ([Pattern] -> constructors (lit@PLit {kind=LBool}) = [ lit.{value=s} | s <- ["true", "false"] ] constructors (con@PCon {qname=MName tname _}) = case g.findit tname of - Just (SymT {env}) -> + Just (SymbolT.T (SymT {env})) -> [ PCon con.pos sym.name (take (length sym.flds) dummies) | (sym::Symbol) <- U.envConstructors env ] where dummies = repeat (PVar con.pos 0 "_") diff --git a/frege/compiler/gen/java/Common.fr b/frege/compiler/gen/java/Common.fr index e9fb8af8..eb4496d6 100644 --- a/frege/compiler/gen/java/Common.fr +++ b/frege/compiler/gen/java/Common.fr @@ -25,7 +25,7 @@ import Compiler.types.Global(StIO, StG, Symbol, SymInfo8, Global(), GenSt(), isReserved) import Compiler.enums.TokenID(QUALIFIER) -import Compiler.types.Symbols(SymD, SymT, SymV, SymC, SymI) +import Compiler.types.Symbols(SymD, SymT, SymV, SymC, SymI, SymbolT) import Compiler.types.JNames(JName, memberOf) import Compiler.types.QNames(TName) import Compiler.types.Packs(pPreludeIO, pPreludeArrays, pPreludeList) @@ -247,8 +247,8 @@ tauJT g (TSig sig) = sigmaJT g sig taujtApp g qname rest app - | Just (sym@SymT{}) <- g.findit qname = case sym of - SymT {product=true, kind, newt=true} -> + | Just (sym@(SymbolT.T symt)) <- g.findit qname = case symt of + SymT{product=true, kind, newt=true} -> let sigmas = [ ConField.typ f | sym@SymD {flds} <- values sym.env, f <- flds ] in case sigmas of [] -> Prelude.error (nice sym g ++ " has no fields") diff --git a/frege/compiler/gen/java/DataCode.fr b/frege/compiler/gen/java/DataCode.fr index 62ed023d..373ebc4b 100644 --- a/frege/compiler/gen/java/DataCode.fr +++ b/frege/compiler/gen/java/DataCode.fr @@ -30,7 +30,7 @@ dataCode :: Symbol → StG [JDecl] names of the constructors and the function definitions found in the where clause of the @data@. -} -dataCode (sym@SymT{enum = true}) = do +dataCode (sym@(SymbolT.T SymT{enum = true})) = do g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for enum " ++ nicer sym g)) @@ -55,7 +55,7 @@ dataCode (sym@SymT{enum = true}) = do We generate an @abstract static class@ as a namespace for the definitions in the where clause, if any. Otherwise, nothing is generated. -} -dataCode (sym@SymT{product = true, newt = true}) = do +dataCode (sym@(SymbolT.T SymT{product = true, newt = true})) = do g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for newtype " ++ nicer sym g)) @@ -76,7 +76,7 @@ dataCode (sym@SymT{product = true, newt = true}) = do In this case, also the appropriate Kinded instances will be generated. -} -dataCode (sym@SymT{ product = true }) = do +dataCode (sym@(SymbolT.T SymT{ product = true })) = do g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for product " ++ nicer sym g)) @@ -129,7 +129,7 @@ dataCode (sym@SymT{ product = true }) = do > // sub definitions > } -} -dataCode (sym@SymT{ nativ = Nothing, product = false, newt = false }) = do +dataCode (sym@(SymbolT.T SymT{ nativ = Nothing, product = false, newt = false })) = do g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer sym g)) @@ -178,7 +178,7 @@ dataCode (sym@SymT{ nativ = Nothing, product = false, newt = false }) = do Native data types are mapped to a class that acts as namespace for the subdefinitions, if any. -} -dataCode (sym@SymT{ nativ = Just _ }) = do -- nativ +dataCode (sym@(SymbolT.T SymT{ nativ = Just _ })) = do -- nativ g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer sym g)) @@ -334,7 +334,7 @@ asThunkMethod t = atomMethod "asThunk" (inThunk t) "null" that is not a constructor. --} subDecls ∷ Symbol → StG [JDecl] -subDecls (sym@SymT{}) = do +subDecls (sym@(SymbolT.T _)) = do g ← getST E.logmsg TRACEG sym.pos (text ("subDecls for " ++ nicer sym g)) let subdefs = filter (not . _.{flds?}) (values sym.env) -- no constructors diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index e5d3e4a4..f7969882 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -222,7 +222,7 @@ instanceCode (sym@SymI {sid}) = do -- instance definition -- links in types that point to instance members of this class and its superclasses -- The goal is to have (links to) implementations of all super class methods. methods2 = case instTSym (Symbol.typ sym) g of - Just (tsym@SymT {pos}) -> [ alias | + Just (SymbolT.T tsym) -> [ alias | SymL {name, alias} <- values tsym.env, alias.{tynm?}, -- links alias `notElem` methods1, -- avoid duplicates alias.base `elem` superMethods, -- mentioning one of our methods @@ -234,7 +234,7 @@ instanceCode (sym@SymI {sid}) = do -- instance definition methods1 = map Symbol.name (values sym.env) -- methods of super classes that are implemented in the type itself methods3 = case instTSym (Symbol.typ sym) g of - Just (tsym@SymT {pos}) -> [ sym.name | + Just (SymbolT.T tsym) -> [ sym.name | sym <- values tsym.env, sym.name.base `elem` superMethods, sym.name.base `notElem` methods] where diff --git a/frege/compiler/gen/java/Match.fr b/frege/compiler/gen/java/Match.fr index 72782e43..3b8e5436 100644 --- a/frege/compiler/gen/java/Match.fr +++ b/frege/compiler/gen/java/Match.fr @@ -164,13 +164,15 @@ match assert (pat@PLit {kind=LBool, value}) bind cont binds = do match assert (pat@PCon {pos,qname,pats}) bind cont binds = do -- g <- getST symd <- U.findD qname -- forall a.a -> List a -> List a - symt <- U.findT symd.name.tynm -- forall a.List a - if symt.enum then matchEnum symd symt - else if symt.product - then if symt.newt - then matchNew symd symt - else matchProd symd symt -- pat bind cont binds - else matchVariant symd symt -- pat bind cont binds + symt' <- U.findT symd.name.tynm -- forall a.List a + case symt' of + SymbolT.T symt -> + if symt.enum then matchEnum symd (SymbolT.T symt) + else if symt.product + then if symt.newt + then matchNew symd (SymbolT.T symt) + else matchProd symd (SymbolT.T symt) -- pat bind cont binds + else matchVariant symd (SymbolT.T symt) -- pat bind cont binds where unKindedStrict g lbnd = case strictBind g lbnd of kbnd -> case kbnd.jtype of @@ -209,7 +211,7 @@ match assert (pat@PCon {pos,qname,pats}) bind cont binds = do match assert (head pats) box1 cont binds matchVariant :: Symbol -> Symbol -> StG (Binding, [JStmt]) - matchVariant symd symt = do + matchVariant symd (SymbolT.T symt) = do g <- getST E.logmsg TRACEG (getpos pat) (text "match pattern " <+> text (nicer pat g) diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index a4c4f7ef..5bd44617 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -21,7 +21,7 @@ import Compiler.instances.Nicer(nicerctx, nicectx) import Compiler.types.Global(Symbol, StG, Global(), getST, changeST, uniqid) -import Compiler.types.Symbols(SymV, SymL, SymD, SymT, SymC, SymI) +import Compiler.types.Symbols(SymV, SymL, SymD, SymT, SymC, SymI, SymbolT) import Compiler.types.Expression(Expr, ExprT, CAlt, CAltT, flatx) import Compiler.types.Patterns(Pattern, PatternT) import Compiler.types.Positions(Positioned) @@ -1271,7 +1271,9 @@ genExpr rflg rm ex binds = do | Just (sym@SymD{cid, flds}) ← g.findit name = if (length flds > 0) then etaWrap (snd (U.returnType ft.rho)) - else if maybe false _.enum (g.findit name.tynm) + else if case g.findit name.tynm of + Just (SymbolT.T symt) -> symt.enum + Nothing -> false then do let item = symJavaName g sym stref = JX.staticMember item @@ -1481,9 +1483,9 @@ genExpr rflg rm ex binds = do any | nargs > ari = etaShrink (nargs - ari) | nargs < ari = etaWrap sigs where nargs = length args - SymT{newt = true, product = true} + SymbolT.T SymT{newt = true, product = true} = genExpr rflg rm (head args) binds - SymT{} + SymbolT.T _ = do -- resolve the contexts, if any ctxs ← mapM (resolveConstraint pos) contexts diff --git a/frege/compiler/passes/Enter.fr b/frege/compiler/passes/Enter.fr index 7cfc2666..789ae987 100644 --- a/frege/compiler/passes/Enter.fr +++ b/frege/compiler/passes/Enter.fr @@ -243,7 +243,7 @@ enter1InsDcl !fname (!d@InsDcl {pos = !pos}) = do !clas <- defaultXName (Pos d.clas.id d.clas.id) (TName pPreludeBase "Eq") d.clas case instTSym typ g of - Just (SymT {name=typnm}) -> do + Just (SymbolT.T SymT{name=typnm}) -> do foreach d.defs (mklinkd typnm (MName tname)) case g.findit clas of Just (SymC {name,env}) -> do @@ -301,7 +301,7 @@ enter1DatDcl fname (d@DatDcl {pos}) = do --when (not d.newt && length d.ctrs == 1 && 1 == (length • DCon.flds • head) d.ctrs) do -- E.hint d.pos (text d.name PP.<+> text "could be a newtype") - ST.enter dsym + ST.enter $ SymbolT.T dsym changeST Global.{ sub <- SubSt.{ idKind <- insert (KeyTk pos.first) (Right dname)}} @@ -352,7 +352,8 @@ enter1JavDcl fname (d@JavDcl {pos}) = do kind = foldr KApp ktype dsig.kinds dsig = ForAll vars (RhoTau [] dtau) jname = d.jclas - ST.enter (SymT {sid=0, pos=d.pos, vis=d.vis, doc=d.doc, name=dname, + ST.enter $ SymbolT.T + (SymT {sid=0, pos=d.pos, vis=d.vis, doc=d.doc, name=dname, product = false, enum = false, newt = false, pur = d.isPure, typ=dsig, gargs=[], kind, nativ = Just jname, env=empty}) diff --git a/frege/compiler/passes/Fields.fr b/frege/compiler/passes/Fields.fr index c15dda93..151397dd 100644 --- a/frege/compiler/passes/Fields.fr +++ b/frege/compiler/passes/Fields.fr @@ -64,7 +64,7 @@ chgddef (d@DatDcl {pos}) = do stio d.{defs <- (++ newdefs)} where work :: Global -> Symbol -> ([FunDcl], [SName]) - work g (dsym@SymT {env}) = + work g (SymbolT.T (dsym@SymT {env})) = let cons = [ sym | sym@SymD {sid} <- values env ] fields = (uniqBy (using fst) • sort) [ (f,p) | con <- cons, Field {pos = p, name = Just f} <- Symbol.flds con ] in ([ d | (f,p) <- fields, d <- gen g p dsym.name cons f], diff --git a/frege/compiler/passes/GenCode.fr b/frege/compiler/passes/GenCode.fr index fd768a34..42e04ef4 100644 --- a/frege/compiler/passes/GenCode.fr +++ b/frege/compiler/passes/GenCode.fr @@ -163,7 +163,7 @@ pass = do >>= liftIO . ppDecls g -- data definitions - let datas = [ s | s@SymT {} <- values g.thisTab ] + let datas = [ s | s@(SymbolT.T _) <- values g.thisTab ] liftStG (concat <$> mapM dataCode datas) >>= liftIO . ppDecls g diff --git a/frege/compiler/passes/Imp.fr b/frege/compiler/passes/Imp.fr index dc584926..cc965cb6 100644 --- a/frege/compiler/passes/Imp.fr +++ b/frege/compiler/passes/Imp.fr @@ -322,7 +322,7 @@ linkHere ns pack (item@Item {publik,name,members,alias=newn}) sym = do errors case sym of - SymT {env} + SymbolT.T SymT{env} | Nothing <- members = do -- link constructors also let cons = [ item.{name <- (pos.first.{tokid=CONID, value=mem.name.base} `qBy`), members = Nothing, @@ -578,7 +578,7 @@ importClassData pos why pack = do foreach (enumFromTo 0 (sym.funs.length-1)) (enter • rbSymV sym.funs) foreach (enumFromTo 0 (sym.lnks.length-1)) (enter • rbSymL sym.lnks) rbSymT :: CT.SymT -> Symbol - rbSymT sym = SymT {sid=0, pos=mkpos sym.offset sym.name.base, + rbSymT sym = SymbolT.T $ SymT {sid=0, pos=mkpos sym.offset sym.name.base, vis = if sym.publik then Public else Protected, doc=strMB sym.doc, name = rebuildQN sym.name, typ = nSigma sym.typ, product = sym.prod, enum = sym.isEnum, @@ -631,7 +631,8 @@ preludeBasics = do unitCA = VName pPreludeBase "()" unitTy = ForAll [] (RhoTau [] (TCon Position.null unitT)) -- sigmaRhoTau xs t = ForAll xs (RhoTau [] t) - enter (SymT {name = unitT, typ=unitTy, env = empty, nativ = Nothing, + enter $ SymbolT.T + (SymT {name = unitT, typ=unitTy, env = empty, nativ = Nothing, product = true, enum = true, pur = false, newt = false, kind = KType, gargs = [], sid=0, pos=Position.null, vis=Public, doc=Just "Unit type"}) @@ -654,7 +655,8 @@ preludeBasics = do (ForAll [] listRho) listRho)) -- tuples - enter (SymT {name = listT, typ = listTy, env = empty, nativ = Nothing, + enter $ SymbolT.T + (SymT {name = listT, typ = listTy, env = empty, nativ = Nothing, product = false, enum = false, pur = false, newt = false, kind = Kind.unary, gargs = [], sid=0, pos=Position.null, vis=Public, doc=Just "list type"}) @@ -675,7 +677,8 @@ preludeBasics = do -- -> let funTy = ForAll [va, vb] (RhoTau [] (Tau.tfun va vb)) funT = TName pPreludeBase "->" - enter (SymT {name = funT, typ = funTy, env = empty, nativ = Nothing, + enter $ SymbolT.T + (SymT {name = funT, typ = funTy, env = empty, nativ = Nothing, product = false, enum = false, kind = Kind.fun, gargs = [], pur = false, newt = false, sid=0, pos=Position.null, @@ -700,7 +703,8 @@ preludeBasics = do tupleRho = RhoTau [] (Tau.mkapp (TCon Position.null tupleT) tvs) -- (a,b,...) tupleSig = ForAll vks tupleRho -- forall a b....(a,b, ...) conRho = foldr (RhoFun []) tupleRho sigmas -- a -> b -> ... -> (a,b, ...) - enter (SymT {name = tupleT, typ = tupleSig, env = empty, nativ = Nothing, + enter $ SymbolT.T + (SymT {name = tupleT, typ = tupleSig, env = empty, nativ = Nothing, product = true, enum = false, kind = Kind.kind n, sid=0, pos=Position.null, vis=Public, doc=Just (show n ++ "-tuple"), pur = false, newt = false, gargs = []}) diff --git a/frege/compiler/passes/Instances.fr b/frege/compiler/passes/Instances.fr index df6b0fcc..2cf488a0 100644 --- a/frege/compiler/passes/Instances.fr +++ b/frege/compiler/passes/Instances.fr @@ -60,7 +60,7 @@ deriveInst (d@DrvDcl{pos}) = do clas <- defaultXName pos (TName pPreludeBase "Eq") d.clas typ <- U.transSigma d.typ case instTSym typ g of - Just (sym@SymT {env}) | ctrs <- U.envConstructors env, + Just (sym@(SymbolT.T SymT{env})) | ctrs <- U.envConstructors env, not (null ctrs) || inPrelude clas.pack g && clas.base == "ArrayElement" || inPrelude clas.pack g && clas.base == "JavaType" diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index c48203fc..39d71afe 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -115,7 +115,7 @@ fixity (d@FixDcl{pos, opid, ops}) = foreach ops changeop g ← getST let qo = VName g.thisPack op vals = values g.thisTab - typemembers = [ MName name op | t@SymT{name} <- vals, g.our name ] + typemembers = [ MName name op | t@(SymbolT.T SymT{name}) <- vals, g.our name ] classmembers = [ MName name op | t@SymC{name} <- vals, g.our name ] instmembers = [ MName name op | t@SymI{name} <- vals, g.our name ] members = typemembers ++ classmembers ++ instmembers @@ -464,7 +464,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do g <- getST let tname = TName g.thisPack d.name case g.findit tname of - Just sym | SymT {pos} <- sym = do + Just sym | SymbolT.T _ <- sym = do sym ← refreshTypeDatDcl d sym foreach d.ctrs (transCon sym.typ (MName tname)) foreach d.defs (transdef [] (MName tname)) @@ -472,7 +472,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do U.findT tname >>= newtCheck other -> do E.fatal pos (text ("Cannot happen, data " ++ tname.nice g ++ " missing")) where - newtCheck (symt@SymT{newt=true}) -- this is declared as newtype + newtCheck (SymbolT.T (symt@SymT{newt=true})) -- this is declared as newtype | [con] ← [ c | c@SymD{} <- values symt.env ], -- so it has 1 constructor [fld] ← [ f | f@Field {typ} <- con.flds ], -- with 1 field ForAll _ RhoTau{tau} ← fld.typ, -- which has some type tau @@ -484,7 +484,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do <+/> text (nicer symt.name g) <+/> text " cannot be a newtype and will be treated as data." ) - changeSym symt.{newt=false} -- make it data + changeSym $ SymbolT.T symt.{newt=false} -- make it data changeSym con.{flds <- map _.{strict=true}} -- with strict field pure () newtCheck other = pure () @@ -622,7 +622,7 @@ transJavDcl env fname (d@JavDcl {pos}) = do let tname = TName g.thisPack d.name case g.findit tname of Just sym - | SymT {nativ = Just nativ} <- sym = do + | SymbolT.T SymT{nativ = Just nativ} <- sym = do -- Redo types sym ← refreshTypeJavDcl d sym -- extract and translate generic type arguments diff --git a/frege/compiler/tc/Methods.fr b/frege/compiler/tc/Methods.fr index ea4119c5..67114e7a 100644 --- a/frege/compiler/tc/Methods.fr +++ b/frege/compiler/tc/Methods.fr @@ -264,7 +264,7 @@ sanity (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, over}) ++ " could modify it.")) other = return () Nothing -> case instTauSym tau g of - Just SymT{nativ = Just nt, pur = pureType} + Just (SymbolT.T SymT{nativ = Just nt, pur = pureType}) | !pureType = case phantom of Just ph -> E.error (getpos tau) ( text "Non pure native type " @@ -337,7 +337,7 @@ sanity (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, over}) E.error (getpos tau) (msgdoc ("`Int` expected.")) return () -- already in error, or ok | otherwise = case instTauSym tau g of - Just SymT{nativ = Just nt, pur = pureType} + Just (SymbolT.T SymT{nativ = Just nt, pur = pureType}) | !pureType = case phantom of Just ph -> E.error (getpos tau) (msgdoc ( "Non pure native type " ++ nicer tau g diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 91a40d18..f1ee9875 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -20,19 +20,22 @@ import frege.compiler.enums.TokenID --- A delayed expressions that will be build on demand. type ExprD a = State a Expr +--- data type +data SymT global = !SymT + { sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name::QName, + kind::Kind, typ::Sigma, env::TreeMap String (SymbolT global), nativ::Maybe String, + gargs::[Tau] --- generic arguments of a native type + product::Bool --- indicate product type + enum::Bool --- indicates enumeration type + pur::Bool --- indicates *pure native* types + newt::Bool --- indicates *newtype* + } {-- The information stored in the 'Symtab' nodes. -} data SymbolT global = - !SymT {sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name::QName, - kind::Kind, typ::Sigma, env::TreeMap String (SymbolT global), nativ::Maybe String, - gargs::[Tau] --- generic arguments of a native type - product::Bool --- indicate product type - enum::Bool --- indicates enumeration type - pur::Bool --- indicates *pure native* types - newt::Bool --- indicates *newtype* - } --- data type + protected !T (SymT global) --- data type | !SymL {sid::Int, pos::Position, vis::Visibility, name::QName, alias::QName} --- alias name | !SymD {sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name::QName, diff --git a/frege/ide/Utilities.fr b/frege/ide/Utilities.fr index 7cc9c967..4417be45 100644 --- a/frege/ide/Utilities.fr +++ b/frege/ide/Utilities.fr @@ -345,7 +345,7 @@ proposeContent !global root !offset !tokens !index = propose | !inside, Token{tokid=CONID, value} <- token, traceLn ("rule case " ++ value ++ "¦") || true, - Just (symbol@SymT{}) <- global.findit TName{pack=global.thisPack, base=value}, + Just (symbol@SymbolT.T _) <- global.findit TName{pack=global.thisPack, base=value}, traceLn (value ++ " is a type") || true -- cons <- [ con | con@SymD{} <- values symtab ], -- traceLn (value ++ " has " ++ show (length cons) ++ " constructors.") || true @@ -360,7 +360,7 @@ proposeContent !global root !offset !tokens !index = propose RhoTau{tau} <- sym.typ.rho, tau <- TC.reduced tau global, traceLn ("type is " ++ nicer tau global) || true, - Just (symbol@SymT{}) <- instTauSym tau global + Just (symbol@SymbolT.T _) <- instTauSym tau global = caseProposal false (Just symbol) | !inside, Token{tokid=VARID, value} <- token, @@ -372,7 +372,7 @@ proposeContent !global root !offset !tokens !index = propose (tau,_) <- U.returnType sym.typ.rho, tau <- TC.reduced tau global, traceLn ("return type is " ++ nicer tau global) || true, - Just (symbol@SymT{}) <- instTauSym tau global + Just (symbol@SymbolT.T _) <- instTauSym tau global = caseProposal false (Just symbol) | direct, token.tokid == VARID = localProposal directProposal @@ -507,7 +507,7 @@ proposeContent !global root !offset !tokens !index = propose tauProposal tau prop | traceLn ("tauProposal: " ++ nicer tau global) = undefined | tau <- TC.reduced tau global, - Just SymT{env, nativ=mbs} <- instTauSym tau global + Just (SymbolT.T SymT{env, nativ=mbs}) <- instTauSym tau global = case mbs of Just s | ss <- s:U.supersOfNativ s global, -- the supertypes of s (including s) @@ -708,7 +708,7 @@ label g SymI{clas,typ} = nicer (instanceHead clas typ.rho) g label g SymV{name,typ} = name.base ++ dcolon g ++ verbose g typ label g SymD{name,typ} = name.base ++ dcolon g ++ verbose g typ label g SymC{name,tau} = name.base ++ dcolon g ++ show tau.kind -label g SymT{name, nativ = Just n, pur} +label g (SymbolT.T SymT{name, nativ = Just n, pur}) | pur = name.base ++ dcolon g ++ "immutable native " ++ n | otherwise = name.base ++ dcolon g ++ "mutable native " ++ n label g SymA{name,typ} = name.base ++ " = " ++ typ.rho.nicer gspecial diff --git a/frege/tools/doc/Utilities.fr b/frege/tools/doc/Utilities.fr index d5b275d9..25e56d94 100644 --- a/frege/tools/doc/Utilities.fr +++ b/frege/tools/doc/Utilities.fr @@ -233,7 +233,7 @@ docSym g (SymI {pos, name, doc, clas, typ=ForAll _ rho, env}) = (code title, con DL (Just "func") (map (docSym g) members)]], p <- d ] -docSym g (SymT {name, doc, typ=ForAll _ rho, env, nativ, pur}) = (code title, content) where +docSym g (SymbolT.T SymT{name, doc, typ=ForAll _ rho, env, nativ, pur}) = (code title, content) where title = (bold • text $ "data ") :- Label name (text " ") :- text " " From 73d651a1dfee433e1b5a9f72c1d10f1250ccf97a Mon Sep 17 00:00:00 2001 From: matil019 Date: Fri, 18 Oct 2019 00:46:12 +0900 Subject: [PATCH 04/95] [nocompile] Change all of SymbolT constructors to independent types --- frege/compiler/types/Symbols.fr | 91 ++++++++++++++++++++++----------- 1 file changed, 62 insertions(+), 29 deletions(-) diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index f1ee9875..688ed560 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -31,39 +31,72 @@ data SymT global = !SymT newt::Bool --- indicates *newtype* } +--- alias name +data SymL global = !SymL + { sid::Int, pos::Position, vis::Visibility, name::QName, alias::QName } + +--- data constructor +data SymD global = !SymD + { sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name::QName, + cid::Int --- constructor number + typ::Sigma, flds::[ConField QName], + strsig :: Strictness, + op :: TokenID --- how to use as operator + } + +--- class +data SymC global = !SymC + { sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name::QName, + tau::Tau, supers::[QName], insts::[(QName, QName)], + env::TreeMap String (SymbolT global) + } + +--- instance +data SymI global = !SymI + { sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name ::QName, + clas::QName, typ::Sigma, + env::TreeMap String (SymbolT global) + } + +--- variable or function +data SymV global = !SymV + { sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name ::QName, + typ::Sigma, + --- For imported expressions, we will make them on demand + expr::Maybe (ExprD global), + nativ::Maybe String, + pur::Bool, anno::Bool, exported::Bool, state::SymState, + strsig :: Strictness, depth :: Int, rkind :: RState, + throwing :: [Tau] --- list of exceptions thrown + over :: [QName ] --- list of overloaded members, if any + gargs::[Tau] --- generic arguments that must be used on the method + op :: TokenID --- how to use as operator + } + where + -- functions for querying the field 'Symbol.rkind' + --- Check certain bit in 'Symbol.rkind' + has :: SymV a -> RFlag -> Bool + has sym bit = bit RState.`member` sym.rkind + --- Check if this is 'RMethod' + isMethod sym = has sym RMethod + +--- type alias +data SymA global = !SymA + { sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name ::QName, + kind::Kind, typ::Sigma, vars::[Tau] + } + {-- The information stored in the 'Symtab' nodes. -} data SymbolT global = - protected !T (SymT global) --- data type - | !SymL {sid::Int, pos::Position, vis::Visibility, name::QName, - alias::QName} --- alias name - | !SymD {sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name::QName, - cid::Int --- constructor number - typ::Sigma, flds::[ConField QName], - strsig :: Strictness, - op :: TokenID --- how to use as operator - } --- data constructor - | !SymC {sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name::QName, - tau::Tau, supers::[QName], insts::[(QName, QName)], - env::TreeMap String (SymbolT global)} --- class - | !SymI {sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name ::QName, - clas::QName, typ::Sigma, - env::TreeMap String (SymbolT global)} --- instance - | !SymV {sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name ::QName, - typ::Sigma, - --- For imported expressions, we will make them on demand - expr::Maybe (ExprD global), - nativ::Maybe String, - pur::Bool, anno::Bool, exported::Bool, state::SymState, - strsig :: Strictness, depth :: Int, rkind :: RState, - throwing :: [Tau] --- list of exceptions thrown - over :: [QName ] --- list of overloaded members, if any - gargs::[Tau] --- generic arguments that must be used on the method - op :: TokenID --- how to use as operator - } --- variable or function - | !SymA {sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name ::QName, - kind::Kind, typ::Sigma, vars::[Tau]} --- type alias + protected T (SymT global) --- data type + | protected L (SymL global) --- alias name + | protected D (SymD global) --- data constructor + | protected C (SymC global) --- class + | protected I (SymI global) --- instance + | protected V (SymV global) --- variable or function + | protected A (SymA global) --- type alias where hashCode = SymbolT.sid gExpr SymV{expr=Just x} g = Just (evalState x g) From 504e178f83ccb1aa807fb2a617bfbbaf155b5ab2 Mon Sep 17 00:00:00 2001 From: matil019 Date: Mon, 21 Oct 2019 12:48:13 +0900 Subject: [PATCH 05/95] Isolate all of SymbolT data constructors The field accessors of SymbolT were replaced with lenses. Partial functions were deliberately introduced to trigger compilation warnings where certain constructor is implicitly assumed (for example, an unsafe conversion `SymbolT g -> SymD g` is inserted to a piece of code which accesses `flds`, which exists only on `SymD`.) --- frege/compiler/Classes.fr | 425 ++++++++++++----------- frege/compiler/GenMeta.fr | 104 +++--- frege/compiler/Javatypes.fr | 5 +- frege/compiler/Kinds.fr | 85 ++--- frege/compiler/Main.fr | 14 +- frege/compiler/Typecheck.fr | 326 +++++++++-------- frege/compiler/Utilities.fr | 120 ++++--- frege/compiler/classes/Nice.fr | 25 +- frege/compiler/common/ImpExp.fr | 30 +- frege/compiler/common/JavaName.fr | 21 +- frege/compiler/common/Lens.fr | 46 +++ frege/compiler/common/PatternCompiler.fr | 8 +- frege/compiler/common/Resolve.fr | 64 ++-- frege/compiler/common/SymbolTable.fr | 152 ++++---- frege/compiler/common/Trans.fr | 54 +-- frege/compiler/common/UnAlias.fr | 4 +- frege/compiler/gen/java/Common.fr | 59 ++-- frege/compiler/gen/java/DataCode.fr | 77 ++-- frege/compiler/gen/java/InstanceCode.fr | 118 ++++--- frege/compiler/gen/java/Instantiation.fr | 13 +- frege/compiler/gen/java/Match.fr | 34 +- frege/compiler/gen/java/MethodCall.fr | 79 +++-- frege/compiler/gen/java/VarCode.fr | 234 +++++++------ frege/compiler/instances/Nicer.fr | 2 +- frege/compiler/passes/Easy.fr | 87 +++-- frege/compiler/passes/Enter.fr | 84 +++-- frege/compiler/passes/Fields.fr | 26 +- frege/compiler/passes/Final.fr | 13 +- frege/compiler/passes/GenCode.fr | 15 +- frege/compiler/passes/GlobalLam.fr | 12 +- frege/compiler/passes/Imp.fr | 102 +++--- frege/compiler/passes/Instances.fr | 54 +-- frege/compiler/passes/LetUnroll.fr | 90 ++--- frege/compiler/passes/Strict.fr | 139 ++++---- frege/compiler/passes/Transdef.fr | 198 ++++++----- frege/compiler/passes/TypeAlias.fr | 12 +- frege/compiler/tc/Methods.fr | 14 +- frege/compiler/tc/Util.fr | 27 +- frege/compiler/types/Global.fr | 13 +- frege/compiler/types/Symbols.fr | 147 ++++++-- frege/ide/Utilities.fr | 137 ++++---- frege/tools/Doc.fr | 53 +-- frege/tools/Quick.fr | 2 +- frege/tools/Splitter.fr | 94 +++-- frege/tools/doc/Utilities.fr | 55 +-- 45 files changed, 1903 insertions(+), 1570 deletions(-) create mode 100644 frege/compiler/common/Lens.fr diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index a88ecae3..319064b0 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -45,6 +45,8 @@ import Data.TreeMap as TM(keys, values, TreeMap, insert, delete, lookup) import Data.List as DL(uniq, sort, sortBy, maximumBy) import Data.Graph (stronglyConnectedComponents tsort) +import frege.compiler.common.Lens (preview, set, unsafePartialView, view) + import Compiler.enums.Flags as Compilerflags(TRACE6) import Compiler.enums.Visibility import Compiler.enums.SymState @@ -80,21 +82,23 @@ post = stio true {-- * look through list of 'Symbol's and note name and direct superclasses for each class -} -classDeps syms g = [ (c.name, c.supers) | c@SymC {pos} <- syms ] +classDeps :: [Symbol] -> Global -> [(QName, [QName])] +classDeps syms g = [ (c.name, c.supers) | SymbolT.C c <- syms ] --- will loop on mutually recursive classes -superclasses (c@SymC {supers}) g = (uniq • sort) (supers ++ +superclasses (SymbolT.C SymC{supers}) g = (uniq . sort) (supers ++ [ supsup | sup <- supers, csym <- (Global.findit g sup).toList, -- Symbol.name csym `notElem` supers, -- ??? supsup <- superclasses csym g ]) -superclasses _ g = [] -- error will be diagnosed later +superclasses _ _ = [] -- error will be diagnosed later {-- * collect all known classes -} +allClasses :: StG [Symbol] allClasses = do g <- getST - stio [ c | env <- values g.packages, c@SymC {pos} <- values env ] + stio [ c | env <- values g.packages, c@(SymbolT.C _) <- values env ] {-- * handle classes @@ -114,11 +118,12 @@ passC = do -- bring all super classes in dependency order deporder :: QName -> StG () deporder clas = do - symc <- U.findC clas - let allsups = superclasses symc g + let unsafeToSymC s = case s of { SymbolT.C x -> x; } + symc <- unsafeToSymC <$> U.findC clas + let allsups = superclasses (SymbolT.C symc) g newsups = [ s | s <- ordered, s `elem` allsups ] - changeSym symc.{supers=newsups} - E.logmsg TRACE6 symc.pos (text (nice symc g ++ " superclasses " + changeSym $ SymbolT.C symc.{supers=newsups} + E.logmsg TRACE6 symc.pos (text (nice (SymbolT.C symc) g ++ " superclasses " ++ show (map (flip nice g) newsups))) -- foreach classdeps trace1 foreach mutual err1 @@ -138,31 +143,32 @@ passC = do complete qcls = do g <- getST case g.find qcls of - Just (symc@SymC {pos}) -> do + Just (SymbolT.C symc) -> do superkind <- foldM (superKind symc) symc.tau.kind [sym | qn <- symc.supers, sym <- g.findit qn ] kind <- foldM (sigmaKind symc.tau.var) superkind [ sym | - (sym@SymV {typ,anno,nativ}) <- values symc.env, + (sym@(SymbolT.V SymV{typ,anno,nativ})) <- values symc.env, anno || isJust nativ, not (isPSigma typ), ] let newkind = if kind `keq` KVar then KType else kind - symc <- U.findC symc.name - changeSym symc.{tau <- Tau.{kind = newkind}} -- update class var - symc <- U.findC symc.name - foreach symc.supers (supercheck symc) + let unsafeToSymC s = case s of { SymbolT.C x -> x; } + symc <- unsafeToSymC <$> U.findC symc.name + changeSym $ SymbolT.C symc.{tau <- Tau.{kind = newkind}} -- update class var + symc <- unsafeToSymC <$> U.findC symc.name + foreach symc.supers (supercheck $ SymbolT.C symc) foreach (values symc.env) (methodcheck symc) nothing -> E.fatal Position.null (text ("lost class " ++ QName.nice qcls g)) - superKind symc ka (supb@SymC{}) = do + superKind symc ka (SymbolT.C supb) = do case K.unifyKind ka supb.tau.kind of Just k -> return k Nothing -> do g <- getST E.error (symc.pos.merge symc.tau.getpos) ( text "kind error: it looks like" - <+> text (nicer symc g) + <+> text (nicer (SymbolT.C symc) g) <+> text "should have kind" <+> text (show ka) <+> nest 4 ( @@ -173,9 +179,9 @@ passC = do )) return ka superKind _ k _ = return k - sigmaKind var kind (sym@SymV {}) = do + sigmaKind var kind (SymbolT.V sym) = do (sig, _) <- K.kiSigmaC var kind sym.typ - changeSym sym.{typ = sig} + changeSym $ SymbolT.V sym.{typ = sig} let -- t = TreeMap.fromList sig.bound ok = _.kind <$> DL.find ((var==) . _.var) sig.bound case ok of @@ -187,24 +193,25 @@ passC = do text ("kind error: kind of type variable `" ++ var ++ "` :: " ++ show k) nest 4 ( - text ("in type signature of " ++ sym.nicer g) + text ("in type signature of " ++ (SymbolT.V sym).nicer g) text ("does not match kind of class variable `" ++ var ++ "` :: " ++ show kind) text "as inferred from other class methods or superclasses.")) return kind Nothing -> return kind -- no class var? will be flagged later sigmaKind _ _ _ = error "sigmaKind: no SymV" - - - methodcheck symc (msym@SymV {pos}) = do + + methodcheck :: SymC Global -> Symbol -> StG () + methodcheck symc (SymbolT.V (msym@SymV {pos})) = do g <- getST - let jprevs = [ g.findit (MName sup msym.name.base) | sup <- Symbol.supers symc ] - xprevs = [ p | Just p <- jprevs, p.{anno?}, p.anno || isJust p.nativ] + let unsafeToSymC s = case s of { SymbolT.C x -> x; } + let jprevs = [ g.findit (MName sup msym.name.base) | sup <- symc.supers ] + xprevs = [ symv | Just (SymbolT.V symv) <- jprevs, symv.anno || isJust symv.nativ ] prevs = if null xprevs then [] else [maximumBy first xprevs] first SymV{name=MName c1 _} SymV{name=MName c2 _} - | Just sym1 <- g.findit c1 - , Just sym2 <- g.findit c2 + | Just sym1 <- unsafeToSymC <$> g.findit c1 + , Just sym2 <- unsafeToSymC <$> g.findit c2 = if sym1.name `elem` sym2.supers then Lt else if sym2.name `elem` sym1.supers then Gt else Eq @@ -213,7 +220,7 @@ passC = do case prevs of [] -> if msym.anno || isJust msym.nativ -- new method then do - checkanno symc msym + checkanno (SymbolT.C symc) (SymbolT.V msym) checklink msym -- global link must point to us else E.error msym.pos (msgdoc ("class member " ++ msym.name.base ++ " must be annotated")) @@ -221,36 +228,35 @@ passC = do when (msym.anno && isNothing msym.nativ) do E.error msym.pos (msgdoc ("class member " ++ msym.name.base ++ " must not be annotated.")) when (isJust msym.nativ) do - T.subsCheck msym msym.typ osym.typ + T.subsCheck (SymbolT.V msym) msym.typ osym.typ case g.findit osym.name.tynm of - Just (ssym@SymC {pos}) -> do - mkanno symc msym osym ssym + Just (ssym@(SymbolT.C _)) -> do + mkanno (SymbolT.C symc) (SymbolT.V msym) (SymbolT.V osym) ssym return () nothing -> E.fatal pos (text ("methodcheck: class " ++ osym.name.tynm.nice g ++ " vanished.")) _ -> E.fatal pos (text (msym.name.nice g ++ " occurs in more than one super class of " ++ symc.name.nice g)) - methodcheck symc (msym@SymL{pos}) = do + methodcheck symc (SymbolT.L (msym@SymL{pos})) = do g <- getST - let jprevs = [ g.findit (MName sup msym.name.base) | sup <- Symbol.supers symc ] - prevs = [ p | Just p <- jprevs, Symbol.{anno?} p, Symbol.anno p ] + let jprevs = [ g.findit (MName sup msym.name.base) | sup <- symc.supers ] + prevs = [ p | Just (SymbolT.V p) <- jprevs, p.anno ] case prevs of [] -> E.error pos (msgdoc ("new class operation `" ++ msym.name.base ++ "` must not be an alias.")) - [osym] | Just ali <- g.findit msym.alias, - SymV{anno=true} <- ali, + [osym] | Just (SymbolT.V ali) <- g.findit msym.alias, + ali.anno, -- symc.name == same, - Just ssym <- g.findit osym.name.tynm, - SymC{} <- ssym = do - sig <- mkanno symc msym osym ssym - T.subsCheck ali ali.typ sig - | otherwise = E.error pos (msgdoc (nicer msym g + Just (ssym@(SymbolT.C _)) <- g.findit osym.name.tynm = do + sig <- mkanno (SymbolT.C symc) (SymbolT.L msym) (SymbolT.V osym) ssym + T.subsCheck (SymbolT.V ali) ali.typ sig + | otherwise = E.error pos (msgdoc (nicer (SymbolT.L msym) g ++ " may only point to a value whose type is known through annotation or import.")) _ -> E.fatal pos (text (msym.name.nice g ++ " occurs in more than one super class of " ++ symc.name.nice g)) methodcheck symc other = do g <- getST - E.error other.pos (text (other.nice g ++ " not allowed in " ++ symc.nice g)) + E.error (view SymbolT.pos other) (text (other.nice g ++ " not allowed in " ++ (SymbolT.C symc).nice g)) {- mkanno class method supermethod superclass * replace forall c . Super c => c -> t * with forall t.This t => t -> n @@ -259,58 +265,61 @@ passC = do * that replaces accidental occurrences of t in the annotation of the super method -} mkanno :: Symbol -> Symbol -> Symbol -> Symbol -> StG Sigma - mkanno csym msym osym ssym = do + mkanno csym' msym osym ssym' = do g <- getST i <- uniqid - let newvar = TVar {pos=msym.pos, var=noClashIdent ("t" ++ show i), kind = KVar} + let csym = case csym' of { SymbolT.C x -> x; } + ssym = case ssym' of { SymbolT.C x -> x; } + let newvar = TVar {pos=view SymbolT.pos msym, var=noClashIdent ("t" ++ show i), kind = KVar} oldvar = ssym.tau.var thsvar = csym.tau.var tree1 = TreeMap.insert empty oldvar csym.tau tree | oldvar != thsvar = tree1.insert thsvar newvar | otherwise = tree1 - case isPSigma osym.typ of + case isPSigma (unsafePartialView SymbolT.typ osym) of false -> do let - rho1 = substRho tree osym.typ.rho + rho1 = substRho tree (unsafePartialView SymbolT.typ osym).rho rep (ctx@Ctx {cname, tau = TVar {var=x}}) - | cname == ssym.name, x == thsvar = ctx.{pos=msym.pos, cname=csym.name} + | cname == ssym.name, x == thsvar = ctx.{pos=view SymbolT.pos msym, cname=csym.name} rep ctx = ctx rho = rho1.{context <- map rep} repv tv = TM.lookupDefault tv tv.var tree - memtyp = ForAll (map repv osym.typ.bound) rho - when msym.{typ?} do - changeSym msym.{typ = memtyp, anno=true} + memtyp = ForAll (map repv (unsafePartialView SymbolT.typ osym).bound) rho + when (isJust $ preview SymbolT.typ msym) $ do + case msym of + SymbolT.V msymv -> + changeSym $ SymbolT.V msymv.{typ = memtyp, anno = true} return memtyp true -> - E.fatal osym.pos (text ("mkanno:: untyped " ++ osym.nice g)) - -- return U.pSigma + E.fatal (view SymbolT.pos osym) (text ("mkanno:: untyped " ++ osym.nice g)) checklink (symm@SymV {name=MName cls base}) = do g <- getST let glob = VName g.thisPack base case g.findit glob of - Just (v@(SymV {name=MName c b})) + Just (v@(SymbolT.V (SymV{name=MName c b}))) | c == cls, b == base = stio () | b != base = E.fatal symm.pos (text ("checklink: " ++ glob.nice g ++ " finds " ++ v.nice g)) | U.isSuper cls g c = case g.find glob of -- this can happen if subclass is defined before the base class -- we correct it here silently - Just (s@(SymL {pos})) -> changeSym s.{alias=symm.name} - Just s -> E.fatal s.pos (text ("checklink: " ++ s.nice g ++ " should be a link")) - Nothing -> E.fatal v.pos (text ("checklink: " ++ glob.nice g ++ "findit is " + Just (SymbolT.L s) -> changeSym $ SymbolT.L s.{alias=symm.name} + Just s -> E.fatal (view SymbolT.pos s) (text ("checklink: " ++ s.nice g ++ " should be a link")) + Nothing -> E.fatal (view SymbolT.pos v) (text ("checklink: " ++ glob.nice g ++ "findit is " ++ v.nice g ++ " but find is Nothing")) - Just v -> E.error symm.pos (msgdoc ("definition of " ++ symm.nice g + Just v -> E.error symm.pos (msgdoc ("definition of " ++ (SymbolT.V symm).nice g ++ " clashes with " ++ v.nice g ++ ", please use another name")) Nothing -> -- should this be possible? - E.fatal symm.pos (text ("checklink: " ++ symm.nice g ++ " not yet known globally")) + E.fatal symm.pos (text ("checklink: " ++ (SymbolT.V symm).nice g ++ " not yet known globally")) -- We could, of course, add it now, but this would be too defensive, -- as we should be justified in assuming that 'enter' did it's job. checklink sym = do g <- getST - E.fatal sym.pos (text ("checklink: " ++ sym.nice g)) - checkanno (symc@SymC {tau=TVar {var}}) (msym@SymV {typ=ForAll bound rho}) = do + E.fatal sym.pos (text ("checklink: " ++ (SymbolT.V sym).nice g)) + checkanno (SymbolT.C (symc@SymC {tau=TVar {var}})) (SymbolT.V (msym@SymV {typ=ForAll bound rho})) = do let check1 = var `elem` map _.var bound check2 = var `notElem` [ var | Ctx {tau=TVar {var}} <- rho.context ] thisctx = Ctx msym.pos symc.name symc.tau @@ -324,19 +333,19 @@ passC = do ++ msym.name.base)) -- construct new type for class member -- == :: e -> e -> Bool => forall e.Eq e => e -> e -> Bool - changeSym msym.{typ =ForAll bound rho.{context <- (thisctx:)}} + changeSym $ SymbolT.V msym.{typ =ForAll bound rho.{context <- (thisctx:)}} checkanno sym1 sym2 = do g <- getST - E.fatal (Symbol.pos sym2) (text ("checkanno (" ++ sym1.nice g + E.fatal (view SymbolT.pos sym2) (text ("checkanno (" ++ sym1.nice g ++ ") (" ++ sym2.nice g ++ ")")) supercheck :: Symbol -> QName -> StG () supercheck symc qn = do g <- getST case g.find qn of - Just (sup@SymC {pos}) -> return () - _ -> E.error symc.pos (msgdoc (QName.nice qn g + Just (SymbolT.C _) -> return () + _ -> E.error (view SymbolT.pos symc) (msgdoc (QName.nice qn g ++ " cannot be a superclass of " - ++ symc.name.nice g ++ " as it is not a class.")) + ++ (view SymbolT.name symc).nice g ++ " as it is not a class.")) {- trace1 (qn1, qns) = do g <- getST @@ -346,7 +355,7 @@ passC = do err1 tns = do g <- getST case g.findit (head tns) of - Just (SymC {pos}) -> E.error pos (msgdoc ("cyclic superclass relation for classes " + Just (SymbolT.C SymC{pos}) -> E.error pos (msgdoc ("cyclic superclass relation for classes " ++ joined ", " (map (flip QName.nice g) tns))) nothing -> E.fatal Position.null (text ("lost class " ++ QName.nice (head tns) g)) @@ -365,11 +374,11 @@ passI alien = do alienInstsForClass c = do g <- getST csym <- U.findC c - E.logmsg TRACE6 csym.pos (text ("alien instances for " ++ QName.nice c g)) + E.logmsg TRACE6 (view SymbolT.pos csym) (text ("alien instances for " ++ QName.nice c g)) let insts = -- (map Symbol.name • sortBy (descending (Position.start • Symbol.pos))) [ ins.name | env <- values g.packages, - ins@SymI {pos} <- values env, - ins.clas == c || ins.clas == csym.name] + SymbolT.I ins <- values env, + ins.clas == c || ins.clas == view SymbolT.name csym] foreach insts (instForClass true c) -- foreach insts (checkTypeAgainst true c) stio (length insts) @@ -377,26 +386,28 @@ alienInstsForClass c = do instsForClass c = do g <- getST csym <- U.findC c - E.logmsg TRACE6 csym.pos (text ("instances for " ++ QName.nice c g)) - let insts = [ ins.name | ins@SymI {pos} <- values g.thisTab, - ins.clas == c || ins.clas == csym.name] + E.logmsg TRACE6 (view SymbolT.pos csym) (text ("instances for " ++ QName.nice c g)) + let insts = [ ins.name | SymbolT.I ins <- values g.thisTab, + ins.clas == c || ins.clas == (view SymbolT.name csym)] foreach insts (instForClass false c) -- foreach insts (checkTypeAgainst c) stio (length insts) instForClass alien c iname = do g <- getST - csym <- U.findC c - + let unsafeToSymC s = case s of { SymbolT.C x -> x; } + unsafeToSymI s = case s of { SymbolT.I x -> x; } + csym <- unsafeToSymC <$> U.findC c + when (not alien) do -- check if class kind matches - isym <- U.findI iname + isym <- unsafeToSymI <$> U.findI iname (sig, ki) <- K.kiSigmaX isym.typ csym.tau.kind - changeSym isym.{typ=sig} - - isym <- U.findI iname - case instTSym (Symbol.typ isym) g of - Just (tsym@(SymbolT.T SymT{pos})) -> do - E.logmsg TRACE6 (Symbol.pos isym) (text (isym.nice g ++ " " ++ tsym.nice g)) + changeSym $ SymbolT.I isym.{typ=sig} + + isym <- unsafeToSymI <$> U.findI iname + case instTSym isym.typ g of + Just (SymbolT.T (tsym@SymT{pos})) -> do + E.logmsg TRACE6 isym.pos (text ((SymbolT.I isym).nice g ++ " " ++ (SymbolT.T tsym).nice g)) when (not alien || g.our isym.name) do foreach (reverse csym.supers) (checkSuperInstance isym.name tsym.name csym.name) @@ -404,8 +415,8 @@ instForClass alien c iname = do foreach (reverse csym.supers) (instForThisClass isym.name tsym.name) csyms <- mapSt U.findC (csym.name:csym.supers) - isym <- U.findI isym.name - when (not alien || g.our isym.name) do tcInstMethods csyms isym + isym <- unsafeToSymI <$> U.findI isym.name + when (not alien || g.our isym.name) do tcInstMethods csyms $ SymbolT.I isym mu -> E.fatal isym.pos (text ("instForClass: bad instance type " ++ isym.typ.nice g)) {-- @@ -423,29 +434,31 @@ instForClass alien c iname = do -} checkSuperInstance iname tname cname bname = do g <- getST - isym <- U.findI iname - bsym <- U.findC bname + let unsafeToSymI s = case s of { SymbolT.I x -> x; } + unsafeToSymC s = case s of { SymbolT.C x -> x; } + isym <- unsafeToSymI <$> U.findI iname + bsym <- unsafeToSymC <$> U.findC bname -- look for super instance case filter ((tname ==) • fst) bsym.insts of (_,sinst):_ -> do - ssym <- U.findI sinst -- this is the super instance + ssym <- unsafeToSymI <$> U.findI sinst -- this is the super instance let msg = "instance " ++ cname.nicer g ++ " " ++ isym.typ.rho.nicer g ++ " has a super instance " ++ bname.nicer g ++ " " ++ ssym.typ.rho.nicer g - E.logmsg TRACE6 (Symbol.pos isym) (text msg) + E.logmsg TRACE6 isym.pos (text msg) baserho <- T.instantiate ssym.typ let msg = "base rho is " ++ baserho.nicer g - E.logmsg TRACE6 (Symbol.pos isym) (text msg) + E.logmsg TRACE6 isym.pos (text msg) thisrho <- T.instantiate isym.typ let msg = "this rho is " ++ thisrho.nicer g - E.logmsg TRACE6 (Symbol.pos isym) (text msg) + E.logmsg TRACE6 isym.pos (text msg) - T.subsCheckRR isym baserho thisrho + T.subsCheckRR (SymbolT.I isym) baserho thisrho let msg1 = "base rho is " ++ baserho.nicer g let msg2 = "this rho is " ++ thisrho.nicer g - E.logmsg TRACE6 (Symbol.pos isym) (text (msg1 ++ " " ++ msg2)) + E.logmsg TRACE6 isym.pos (text (msg1 ++ " " ++ msg2)) g <- getST let ctx1 = T.reducedCtxs g baserho.context @@ -475,34 +488,37 @@ checkSuperInstance iname tname cname bname = do instForThisClass :: QName -> QName -> QName -> StG () instForThisClass iname tname cname = do g <- getST + let unsafeToSymI s = case s of { SymbolT.I x -> x; } + unsafeToSymC s = case s of { SymbolT.C x -> x; } tsym <- U.findT tname - isym <- U.findI iname - csym <- U.findC cname + isym <- unsafeToSymI <$> U.findI iname + csym <- unsafeToSymC <$> U.findC cname let previ = case filter ((tname ==) • fst) csym.insts of ((_,inst):_) -> Just inst _ -> Nothing - E.logmsg TRACE6 (Symbol.pos isym) (text ("this inst: " ++ show iname ++ ", prev inst: " ++ show previ)) + E.logmsg TRACE6 isym.pos (text ("this inst: " ++ show iname ++ ", prev inst: " ++ show previ)) case previ of Just oldinst | oldinst != iname = do - iold <- U.findI oldinst + iold <- unsafeToSymI <$> U.findI oldinst when (iold.clas == isym.clas) do - U.symWarning E.warn isym (msgdoc (tsym.nice g ++ " is already an instance of " - ++ csym.nice g ++ " (" ++ oldinst.nice g + U.symWarning E.warn (SymbolT.I isym) (msgdoc (tsym.nice g ++ " is already an instance of " + ++ (SymbolT.C csym).nice g ++ " (" ++ oldinst.nice g ++ " introduced on line " ++ show iold.pos ++ ")")) stio () | otherwise = do - E.logmsg TRACE6 (Symbol.pos isym) (text ("refresh " ++ tname.nice g - ++ " instance of " ++ csym.nice g)) - foreach (map Symbol.name (values (Symbol.env csym))) + E.logmsg TRACE6 isym.pos (text ("refresh " ++ tname.nice g + ++ " instance of " ++ (SymbolT.C csym).nice g)) + foreach (map (view SymbolT.name) (values csym.env)) (funForCIT cname iname tname) stio () Nothing -> do - E.logmsg TRACE6 (Symbol.pos isym) (text ("make " ++ tname.nice g - ++ " an instance of " ++ csym.nice g)) - foreach (map Symbol.name (values (Symbol.env csym))) (funForCIT cname iname tname) - csym <- U.findC cname - changeSym csym.{insts <- ((tsym.name, iname):)} + E.logmsg TRACE6 isym.pos (text ("make " ++ tname.nice g + ++ " an instance of " ++ (SymbolT.C csym).nice g)) + foreach (map (view SymbolT.name) (values csym.env)) (funForCIT cname iname tname) + let unsafeToSymC c = case c of { SymbolT.C x -> x; } + csym <- unsafeToSymC <$> U.findC cname + changeSym $ SymbolT.C csym.{insts <- ((view SymbolT.name tsym, iname):)} --- check instance member function definition {-- @@ -523,10 +539,14 @@ instForThisClass iname tname cname = do funForCIT :: QName -> QName -> QName -> QName -> StG () funForCIT cname iname tname (mname@MName _ base) = do g <- getST - tsym <- U.findT tname - isym <- U.findI iname - csym <- U.findC cname - msym <- U.findV mname + let unsafeToSymT s = case s of { SymbolT.T x -> x; } + unsafeToSymI s = case s of { SymbolT.I x -> x; } + unsafeToSymC s = case s of { SymbolT.C x -> x; } + unsafeToSymV s = case s of { SymbolT.V x -> x; } + tsym <- unsafeToSymT <$> U.findT tname + isym <- unsafeToSymI <$> U.findI iname + csym <- unsafeToSymC <$> U.findC cname + msym <- unsafeToSymV <$> U.findV mname E.logmsg TRACE6 isym.pos (text ("funForCit class: " ++ nicer cname g ++ ", inst: " ++ nicer iname g ++ ", type: " ++ nicer tname g @@ -535,9 +555,9 @@ funForCIT cname iname tname (mname@MName _ base) = do tvmb = tsym.env.lookup mname.key -- implemented vsym = isJust (Symbol.expr vsym) || isJust (Symbol.nativ vsym) inherit xname = do - mem <- U.findV xname - E.logmsg TRACE6 isym.pos (text ("inheriting " ++ mem.nice g)) - if implemented mem + mem <- unsafeToSymV <$> U.findV xname + E.logmsg TRACE6 isym.pos (text ("inheriting " ++ (SymbolT.V mem).nice g)) + if implemented $ SymbolT.V mem then do -- use default implementation mex <- U.maybeST mem.expr id mbx <- U.maybeST mex (U.copyExpr (Just isym.pos) empty) @@ -546,8 +566,8 @@ funForCIT cname iname tname (mname@MName _ base) = do typ = pSigma, anno = false, exported = false, state = Unchecked, sid = 0, doc = Just ("inherited from '" ++ xname.nicer g ++ "'")} - enter imem - linkq (MName tname base) imem + enter $ SymbolT.V imem + linkq (MName tname base) $ SymbolT.V imem else if g.our cname || mem.vis == Abstract then E.error isym.pos (msgdoc ("implementation of `" ++ (MName tname base).nice g ++ "` must be supplied.")) @@ -558,122 +578,122 @@ funForCIT cname iname tname (mname@MName _ base) = do sid = 0, doc = Just ("uses '" ++ xname.nicer g ++ "'"), expr = Just (return (Vbl isym.pos xname Nothing))} - enter imem - linkq (MName tname base) imem + enter $ SymbolT.V imem + linkq (MName tname base) $ SymbolT.V imem case ivmb of - Just (ivsym@SymV {name}) - | implemented ivsym || not (g.our iname) = case tvmb of - Just (tvsym@SymL {alias}) - | alias == name = changeSym ivsym.{op=msym.op} -- copy op + Just (SymbolT.V (ivsym@SymV{name})) + | implemented (SymbolT.V ivsym) || not (g.our iname) = case tvmb of + Just (SymbolT.L (tvsym@SymL{alias})) + | alias == name = changeSym $ SymbolT.V ivsym.{op=msym.op} -- copy op | MName yname _ <- alias, - Just ysym <- g.findit yname = when (g.ourSym isym) do - U.symWarning E.hint ivsym (msgdoc ("There exists another implementation of `" + Just ysym <- g.findit yname = when (g.ourSym $ SymbolT.I isym) do + U.symWarning E.hint (SymbolT.V ivsym) (msgdoc ("There exists another implementation of `" ++ mname.base ++ "` for unrelated " ++ ysym.nicer g ++ ", this will make it impossible to access " - ++ ivsym.nicer g + ++ (SymbolT.V ivsym).nicer g ++ " directly.")) - | otherwise = E.error tvsym.pos (msgdoc (tvsym.nice g - ++ " should be alias of " ++ ivsym.nice g)) - Just tvsym -> E.error tvsym.pos (msgdoc ("definition of " ++ ivsym.nice g + | otherwise = E.error tvsym.pos (msgdoc ((SymbolT.L tvsym).nice g + ++ " should be alias of " ++ (SymbolT.V ivsym).nice g)) + Just tvsym -> E.error (view SymbolT.pos tvsym) (msgdoc ("definition of " ++ (SymbolT.V ivsym).nice g ++ " not allowed because " ++ tvsym.nice g ++ " already exists.")) Nothing -> do - E.logmsg TRACE6 ivsym.pos (text (mname.nice g ++ " not yet implemented in " ++ tsym.nice g)) - linkq (MName tname base) ivsym - changeSym ivsym.{op=msym.op} -- copy op - | otherwise = E.error isym.pos (msgdoc ("implementation missing for " ++ ivsym.nice g)) - Just SymL{pos=ipos, name=member, alias} -- imported instance with links to type methods? + E.logmsg TRACE6 ivsym.pos (text (mname.nice g ++ " not yet implemented in " ++ (SymbolT.T tsym).nice g)) + linkq (MName tname base) $ SymbolT.V ivsym + changeSym $ SymbolT.V ivsym.{op=msym.op} -- copy op + | otherwise = E.error isym.pos (msgdoc ("implementation missing for " ++ (SymbolT.V ivsym).nice g)) + Just (Symbol.L SymL{pos=ipos, name=member, alias}) -- imported instance with links to type methods? | not (g.our iname), alias.{tynm?}, alias.tynm == tname = stio () | otherwise = case g.findit alias of - Just symv | SymV{} <- symv, !symv.anno && !(maybe false (const true) symv.nativ) = do + Just symv' | SymbolT.V symv <- symv', not symv.anno && not (maybe false (const true) symv.nativ) = do E.error ipos (msgdoc ("function `" ++ nicer alias g ++ "` given as implementation of instance member `" ++ nicer member g ++ "` must be annotated.")) - changeSym isym.{ env <- delete member.key } + changeSym $ SymbolT.I isym.{ env <- delete member.key } Just osym | not (g.ourSym osym) || implemented osym = case tvmb of - Just (tsym @ SymL{alias=same}) - | same == alias = changeSym osym.{op=msym.op} -- copy op + Just (SymbolT.L (tsym@SymL{alias=same})) + | same == alias = changeSym $ set SymbolT.op msym.op osym -- copy op | same == member = do -- this is the normal case after enter -- remove one indirection - changeSym tsym.{alias} - changeSym osym.{op=msym.op} + changeSym $ SymbolT.L tsym.{alias} + changeSym $ set SymbolT.op msym.op osym Just err -> E.error ipos (msgdoc ("definition of " ++ member.nicer g ++ " not allowed because " ++ err.nicer g ++ " already exists.")) Nothing -> do - E.logmsg TRACE6 ipos (text (mname.nice g ++ " not yet implemented in " ++ tsym.nice g)) + E.logmsg TRACE6 ipos (text (mname.nice g ++ " not yet implemented in " ++ (SymbolT.T tsym).nice g)) linkq (MName tname base) osym - changeSym osym.{op=msym.op} + changeSym $ set SymbolT.op msym.op osym Just osym -> E.error ipos (text (nicer osym g ++ " is not implemented.")) Nothing -> do E.fatal ipos (msgdoc (nicer member g ++ " links to " ++ alias.nicer g ++ ", but the latter doesn't exist.")) Just osym -> E.fatal isym.pos (text ("expected instance member, found " ++ osym.nice g)) Nothing -> case tvmb of Nothing -> inherit mname - Just (tvsym@SymV {pos}) + Just (SymbolT.V tvsym) | tvsym.name.getpack != isym.name.getpack = do -- imported type that aready has the member. -- We just link to it. E.logmsg TRACE6 isym.pos (text (mname.nice g ++ " implemented in imported type.")) - linkq (MName iname base) tvsym - changeSym tvsym.{op=msym.op} - | implemented tvsym = do - E.logmsg TRACE6 tvsym.pos (text (mname.nice g ++ " not yet implemented in " ++ isym.nice g)) + linkq (MName iname base) $ SymbolT.V tvsym + changeSym $ SymbolT.V tvsym.{op=msym.op} + | implemented (SymbolT.V tvsym) = do + E.logmsg TRACE6 tvsym.pos (text (mname.nice g ++ " not yet implemented in " ++ (SymbolT.I isym).nice g)) let ivsym = tvsym.{name=MName iname base, sid = 0, op = msym.op} - enter ivsym - changeSym tsym.{ env <- delete mname.key } - linkq (MName tname base) ivsym - | otherwise = E.error tvsym.pos (msgdoc ("implementation missing for " ++ tvsym.nice g)) - Just (ali@SymL {alias}) + enter $ SymbolT.V ivsym + changeSym $ SymbolT.T tsym.{ env <- delete mname.key } + linkq (MName tname base) $ SymbolT.V ivsym + | otherwise = E.error tvsym.pos (msgdoc ("implementation missing for " ++ (SymbolT.V tvsym).nice g)) + Just (SymbolT.L (ali@SymL{alias})) | alias == mname || alias == MName isym.clas base = do -- link to class fun has been introduced earlier in 'enter' - changeSym tsym.{ env <- delete mname.key } + changeSym $ SymbolT.T tsym.{ env <- delete mname.key } inherit alias | MName yname _ <- alias, -- link to member of instance for super class? - Just (ysym@SymI {pos}) <- g.findit yname, + Just (SymbolT.I ysym) <- g.findit yname, ysym.clas `elem` csym.supers = stio () -- Issue 126: can be alias to type member | MName yname other ← alias, yname == tname, - Just impl <- g.follow ali = do + Just impl <- g.follow (SymbolT.L ali) = do if implemented impl then do - E.logmsg TRACE6 impl.pos (text (mname.nice g ++ " not yet implemented in " ++ isym.nice g)) + E.logmsg TRACE6 (view SymbolT.pos impl) (text (mname.nice g ++ " not yet implemented in " ++ (SymbolT.I isym).nice g)) E.logmsg TRACE6 isym.pos (text ("copy implementation from " ++ impl.nice g)) - let ivsym = impl.{name=MName iname base, sid = 0, op = msym.op} + let ivsym = set SymbolT.name (MName iname base) $ set SymbolT.sid 0 $ set SymbolT.op msym.op $ impl enter ivsym - changeSym tsym.{ env <- delete other } + changeSym $ SymbolT.T tsym.{ env <- delete other } linkq (MName tname other) ivsym else do - E.error impl.pos (msgdoc ("implementation missing for " ++ impl.nicer g)) + E.error (view SymbolT.pos impl) (msgdoc ("implementation missing for " ++ impl.nicer g)) | MName yname _ <- alias, - Just (ysym@SymI {pos}) <- g.findit yname, + Just (SymbolT.I ysym) <- g.findit yname, ysym.clas `notElem` csym.supers, - Just (vsym@SymV {nativ = Just _}) <- g.findit alias = do + Just (SymbolT.V (vsym@SymV{nativ = Just _})) <- g.findit alias = do -- allow recycling of native functions - U.symWarning E.hint isym (msgdoc ("implementation for " ++ mname.nice g - ++ " taken from unrelated " ++ ysym.nice g)) - enter vsym.{name=MName isym.name base, sid = 0, op = msym.op} + U.symWarning E.hint (SymbolT.I isym) (msgdoc ("implementation for " ++ mname.nice g + ++ " taken from unrelated " ++ (SymbolT.I ysym).nice g)) + enter $ SymbolT.V vsym.{name=MName isym.name base, sid = 0, op = msym.op} | MName yname _ <- alias, - Just (ysym@SymI {}) <- g.findit yname, + Just (SymbolT.I ysym) <- g.findit yname, ysym.sid == isym.sid = do -- this happens in IDE, when we have an instance for an imported type -- the link still points here, but the instance data got lost -- during rebuild of symbol table - changeSym tsym.{ env <- delete mname.key } + changeSym $ SymbolT.T tsym.{ env <- delete mname.key } inherit mname | MName yname _ <- alias, - Just (ysym@SymI {pos}) <- g.findit yname, + Just (SymbolT.I (ysym@SymI {pos})) <- g.findit yname, ysym.clas `notElem` csym.supers = do - let ysupers = [ s | SymC{supers} <- g.findit ysym.clas, s <- supers ] + let ysupers = [ s | SymbolT.C SymC{supers} <- g.findit ysym.clas, s <- supers ] sibling = cname `elem` ysupers unless sibling do E.error isym.pos (msgdoc (mname.nice g ++ " already implemented via unrelated " - ++ ysym.nice g)) + ++ (SymbolT.I ysym).nice g)) | MName ocname _ <- alias, - Just (ocsym@SymC {name}) <- g.findit ocname, + Just (ocsym@(SymbolT.C SymC{name})) <- g.findit ocname, name `notElem` csym.supers = do E.error isym.pos (msgdoc (mname.nice g ++ " already implemented via unrelated " @@ -686,19 +706,20 @@ funForCIT cname iname tname (mname@MName _ base) = do "linkq " ++ nice (MName iname base) g ++ " -> " ++ nice target g)) linkq (MName iname base) target funForCIT cname iname tname mname -- try again - Nothing -> E.fatal ali.pos (msgdoc ("Link to nowhere: " ++ nicer ali g)) - Just osym -> E.fatal osym.pos (text ("funForCIT: expected type member, found " ++ osym.nice g)) + Nothing -> E.fatal ali.pos (msgdoc ("Link to nowhere: " ++ nicer (SymbolT.L ali) g)) + Just osym -> E.fatal (view SymbolT.pos osym) (text ("funForCIT: expected type member, found " ++ osym.nice g)) funForCIT cname iname tname mname = error "funForCIT: not a member" --- check if 'Symbol' is an implemented function -implemented SymD{} = true -implemented vsym = isJust (Symbol.expr vsym) || isJust (Symbol.nativ vsym) +implemented :: Symbol -> Bool +implemented (SymbolT.D _) = true +implemented (SymbolT.V vsym) = isJust vsym.expr || isJust vsym.nativ {-- check for each method in an instance if the type is more specific than the class type -} tcInstMethods :: [Symbol] -> Symbol -> StG () -tcInstMethods supers inst = foreach (values inst.env) (tcInstMethod supers inst) +tcInstMethods supers inst = foreach (values (unsafePartialView SymbolT.env inst)) (tcInstMethod supers inst) {-- check if the type of an instance method is more specific than the type of the class method @@ -706,31 +727,28 @@ tcInstMethods supers inst = foreach (values inst.env) (tcInstMethod supers inst) tcInstMethod :: [Symbol] -> Symbol -> Symbol -> StG () tcInstMethod [] isym msym = do g <- getST - E.error msym.pos (msgdoc (msym.nice g ++ " is not a class member function")) - -tcInstMethod (sc:scs) isym msym - -- | SymL{} <- msym = do - -- g <- getST - -- case g.follow msym of - -- Just realmsym -> tcInstMethod (sc:scs) isym realmsym - -- Nothing -> E.fatal msym.pos (text (msym.nice g) <+> text " links nowhere.") - | msym.{typ?} || msym.{alias?} = do + E.error (view SymbolT.pos msym) (msgdoc (msym.nice g ++ " is not a class member function")) + +tcInstMethod (sc':scs) isym msym + | hasTyp msym || isSymL msym = do + let unsafeToSymC (SymbolT.C x) = x + sc = unsafeToSymC sc' g <- getST - case sc.env.lookupS msym.name.key of + case sc.env.lookupS (view SymbolT.name msym).key of Nothing -> tcInstMethod scs isym msym - Just (SymV {typ=(s@ForAll sbnd srho)}) | not (isPSigma s) = do + Just (SymbolT.V SymV{typ=(s@ForAll sbnd srho)}) | not (isPSigma s) = do g <- getST let !mtnice = case isPSigma sig of true -> "None"; false -> sig.nicer g !csig = ForAll (filter ((sc.tau.var!=) . _.var) sbnd) srho - !sig = case g.findit msym.name of - Just xsym | xsym.{typ?} -> xsym.typ + !sig = case g.findit (view SymbolT.name msym) of + Just xsym | Just typ <- preview SymbolT.typ xsym -> typ other -> error ("tcInstMethod: link to nothing: " ++ nice msym g) - E.logmsg TRACE6 msym.pos (text (msym.nice g - ++ " class: " ++ sc.nice g + E.logmsg TRACE6 (view SymbolT.pos msym) (text (msym.nice g + ++ " class: " ++ (SymbolT.C sc).nice g ++ " class method type: " ++ s.nicer g ++ " own type: " ++ mtnice)) -- forall i. S i => I i ==> S 42 => I 42 - rhotau <- T.instantiate isym.typ + rhotau <- T.instantiate (unsafePartialView SymbolT.typ isym) case tauRho rhotau of RhoTau ctx tau -> do -- must be RhoTau, see Enter -- C c => c a -> c b ==> forall a b.C (I 42) => I 42 a -> I 42 b @@ -749,35 +767,42 @@ tcInstMethod (sc:scs) isym msym -- of Eq.== for Int adapt = filter (not • T.sameCtx (Ctx Position.null sc.name tau)) -- msig1 = msig - E.logmsg TRACE6 msym.pos (text (msym.nice g ++ " adapted type " ++ msig.nicer g)) + E.logmsg TRACE6 (view SymbolT.pos msym) (text (msym.nice g ++ " adapted type " ++ msig.nicer g)) msig <- T.canonicSignature msig - E.logmsg TRACE6 msym.pos (text (msym.nice g ++ " instance type " ++ msig.nicer g)) + E.logmsg TRACE6 (view SymbolT.pos msym) (text (msym.nice g ++ " instance type " ++ msig.nicer g)) -- let inst = U.sigmaInst g csig msig -- E.logmsg TRACE6 msym.pos ("sigmaInst: " ++ show (map (flip nice g) inst)) -- let mfinal = msig.{bound = [ var | TVar {var} <- inst]} -- E.logmsg TRACE6 msym.pos (msym.nice g ++ " instance type " ++ mfinal.nicer g) case isPSigma sig of true -> do - changeSym msym.{typ = msig, anno = true} + case msym of + SymbolT.V msymv -> + changeSym $ SymbolT.V msymv.{typ = msig, anno = true} false -> do T.subsCheck msym sig msig T.checkConstraints msym sig msig T.checkConstraints msym msig sig - when (msym.{expr?}) do - changeSym msym.{typ = msig, anno = true} - other -> E.fatal isym.pos (msgdoc ("RhoTau expected, got " ++ rhotau.nicer g)) - Just (symv@SymV {typ=sig}) | isPSigma sig -> do - E.fatal symv.pos (text (symv.nice g ++ " of " ++ sc.nice g ++ " is not annotated")) + case msym of + SymbolT.V msymv -> changeSym $ SymbolT.V msymv.{typ = msig, anno = true} + _ -> pure () + other -> E.fatal (view SymbolT.pos isym) (msgdoc ("RhoTau expected, got " ++ rhotau.nicer g)) + Just (SymbolT.V (symv@SymV {typ=sig})) | isPSigma sig -> do + E.fatal symv.pos (text ((SymbolT.V symv).nice g ++ " of " ++ (SymbolT.C sc).nice g ++ " is not annotated")) -- Some class has a default method that links somewhere else -- The method was introduced in a super class - Just SymL{} -> tcInstMethod scs isym msym + Just (SymbolT.L _) -> tcInstMethod scs isym msym Just other -> do - E.fatal other.pos (text (other.nice g ++ " in " ++ sc.nice g)) + E.fatal (view SymbolT.pos other) (text (other.nice g ++ " in " ++ (SymbolT.C sc).nice g)) + where + hasTyp = isJust . preview SymbolT.typ + isSymL (SymbolT.L _) = true + isSymL _ = false -tcInstMethod (sc:scs) isym (msym@SymV {typ=s}) | not (isPSigma s) = do +tcInstMethod (sc:scs) isym (msym@SymbolT.V (SymV{pos, typ=s})) | not (isPSigma s) = do g <- getST - E.fatal msym.pos (text ("tcInstMethod: " ++ msym.nice g ++ " annotated with " ++ s.nicer g)) + E.fatal pos (text ("tcInstMethod: " ++ msym.nice g ++ " annotated with " ++ s.nicer g)) tcInstMethod (sc:scs) isym msym = do g <- getST - E.fatal msym.pos (text ("tcInstMethod: strange symbol " ++ msym.nice g)) + E.fatal (view SymbolT.pos msym) (text ("tcInstMethod: strange symbol " ++ msym.nice g)) diff --git a/frege/compiler/GenMeta.fr b/frege/compiler/GenMeta.fr index 2dd42006..c5292c63 100644 --- a/frege/compiler/GenMeta.fr +++ b/frege/compiler/GenMeta.fr @@ -141,14 +141,14 @@ genmeta = do -- let ops = [ mkOp (s,x) | (s,x) <- each g.optab, x >= LOP0 ] - let asyms = [sym | sym@SymA {pos} <- values g.thisTab, sym.vis!=Private] + let asyms = [sym | sym@(SymbolT.A SymA{vis}) <- values g.thisTab, vis!=Private] symas <- liftStG $ mapSt annoSymA asyms - let csyms = [sym | sym@SymC {pos} <- values g.thisTab, sym.vis!=Private] + let csyms = [sym | sym@(SymbolT.C SymC{vis}) <- values g.thisTab, vis!=Private] symcs <- liftStG $ mapSt annoSymC csyms - let isyms = [sym | sym@SymI {pos} <- values g.thisTab, sym.vis!=Private] + let isyms = [sym | sym@(SymbolT.I SymI{vis}) <- values g.thisTab, vis!=Private] symis <- liftStG $ mapSt annoSymI isyms let tsyms = [sym | sym@(SymbolT.T SymT{vis}) <- values g.thisTab, vis!=Private] @@ -202,7 +202,7 @@ genmeta = do --- create annotations for all SymV in an environment envValues :: Symtab -> StG [DOCUMENT] envValues env = do - let vsyms = [sym | sym@SymV {pos} <- values env, sym.vis != Private] + let vsyms = [sym | sym@(SymbolT.V SymV{vis}) <- values env, vis != Private] symvs <- mapSt annoSymV vsyms stio symvs @@ -210,13 +210,13 @@ envValues env = do envLinks :: Symtab -> StG [DOCUMENT] envLinks env = do g <- getST - let syms = [ sym | sym@SymL {alias} <- values env, sym.vis != Private] + let syms = [ sym | sym@(SymbolT.L SymL{vis}) <- values env, vis != Private] mapM annoSymL syms --- create annotations for all SymD in an environment envCons :: Symtab -> StG [DOCUMENT] envCons env = do - let syms = [sym | sym@SymD {pos} <- values env] + let syms = [sym | sym@(SymbolT.D _) <- values env] mapSt annoSymD syms @@ -427,11 +427,12 @@ expIndex exp = encodeX exp >>= mbIndex let var = Vbl{pos=Position.null, name=Local 0 "", typ=Nothing} qexs ← mapM (expIndex . var.{name=}) env -- the list of symbols corresponding to the let bound names - syms ← mapM U.findV env + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + syms ← mapM (fmap unsafeToSymV . U.findV) env -- make (and encode) the list of sigmas - sigs ← mapM (\s -> if Symbol.anno s then sigIndex s.typ else return (-1)) syms + sigs ← mapM (\s -> if SymV.anno s then sigIndex s.typ else return (-1)) syms -- make and encode the list of expressions - exps ← mapM (maybe (return 0) (>>=expIndex) . Symbol.expr) syms + exps ← mapM (maybe (return 0) (>>=expIndex) . _.expr) syms exp ← expIndex ex if exp == 0 || any (<1) exps || any (<1) qexs then return Nothing @@ -444,7 +445,8 @@ expIndex exp = encodeX exp >>= mbIndex where k = if negated then -(ord kind) else ord kind encodeX (Vbl {name=Local u s}) = stio (Just defEA.{subx1 = u}) encodeX (Vbl {name}) = do -- no private data - sym <- U.findV name + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> U.findV name stio (if sym.vis != Private then Just defEA.{xkind = 8, name = Just name} else Nothing) encodeX exp = stio Nothing encodeP (PAnn {pat, typ}) = do @@ -503,33 +505,35 @@ eaIndex expa = do changeST Global.{gen <- GenSt.{xunique <- (1+)} • GenSt.{xTree <- insert expa g.xunique}} stio g.xunique -annoSymA syma = do +annoSymA syma' = do g ← getST - vars <- mapSt tauIndex (Symbol.vars syma) - typ <- sigIndex (Symbol.typ syma) + let syma = case syma' of { SymbolT.A x -> x; } + vars <- mapSt tauIndex syma.vars + typ <- sigIndex syma.typ kind <- kindIndex syma.kind let a = meta g "SymA" [ ("offset", anno syma.pos.first.offset), - ("name", annoG g (Symbol.name syma)), + ("name", annoG g syma.name), ("vars", anno vars), ("typ", anno typ), ("kind", anno kind), ("publik", if syma.vis == Public then PP.nil else anno false), - ("doc", maybe PP.nil anno (Symbol.doc syma)) + ("doc", maybe PP.nil anno syma.doc) ] stio a -annoSymV symv = do +annoSymV symv' = do g <- getST + let symv = case symv' of { SymbolT.V x -> x; } gargs ← mapM tauIndex symv.gargs - case isPSigma (Symbol.typ symv) of - true -> E.fatal symv.pos (text (symv.nice g ++ " has no type.")) + case isPSigma symv.typ of + true -> E.fatal symv.pos (text ((SymbolT.V symv).nice g ++ " has no type.")) false -> do - sig <- sigIndex (Symbol.typ symv) + sig <- sigIndex symv.typ -- inline candidates must be safe tail calls and no loops let !classop | MName tname _ <- symv.name, - Just SymC{} <- g.find tname = isJust symv.expr -- this is a class member + Just (SymbolT.C _) <- g.find tname = isJust symv.expr -- this is a class member | otherwise = false !candidate = classop || symv.exported -- U.logmsg TRACE9 symv.pos (text ((nicer symv g) @@ -555,7 +559,7 @@ annoSymV symv = do when (sorry) do (if classop then E.error else E.hint) symv.pos - (text ("The code of " ++ nice symv g + (text ("The code of " ++ nice (SymbolT.V symv) g ++ " cannot be exported because it " ++ reason ++ ". ")) ttaus <- mapM (tauIndex) symv.throwing let a = meta g "SymV" [ @@ -580,32 +584,30 @@ annoSymV symv = do changeST Global.{gen <- _.{expSym <- insert symv.name exp}} stio a -annoSymL sym = do +annoSymL sym' = do g ← getST + let sym = case sym' of { SymbolT.L x -> x; } pure $ meta g "SymL" [ - ("offset", anno (Symbol.pos sym).first.offset), - ("name", annoG g (Symbol.name sym)), - ("alias", annoG g (Symbol.alias sym)), + ("offset", anno sym.pos.first.offset), + ("name", annoG g sym.name), + ("alias", annoG g sym.alias), ("publik", if sym.vis == Public then PP.nil else anno false), - -- ("doc", maybe PP.nil anno (Symbol.doc sym)) ] -annoSymD sym = do +annoSymD sym' = do g <- getST - typ <- sigIndex (Symbol.typ sym) + let sym = case sym' of { SymbolT.D x -> x; } + typ <- sigIndex sym.typ fields <- mapSt conFieldA sym.flds let a = meta g "SymD" [ - ("offset", anno (Symbol.pos sym).first.offset), - ("name", annoG g (Symbol.name sym)), - -- ("stri", lit sym.strsig.show), - ("cid", anno (Symbol.cid sym)), + ("offset", anno sym.pos.first.offset), + ("name", annoG g sym.name), + ("cid", anno sym.cid), ("typ", anno typ), ("fields", annoListG g fields), - -- ("fnms", if null fnms || all null fnms then PP.nil else anno fnms), - -- ("ftys", if null ftys then PP.nil else anno ftys), ("priv", if sym.vis == Private then anno true else PP.nil), ("publik", if sym.vis == Public then PP.nil else anno false), - ("doc", maybe PP.nil anno (Symbol.doc sym)), + ("doc", maybe PP.nil anno sym.doc), ("op", if sym.op == defaultInfix then PP.nil else anno (ord sym.op))] stio a @@ -626,14 +628,15 @@ instance AnnoG ConFieldA where ] -annoSymC sym = do +annoSymC sym' = do g ← getST - tau <- tauIndex (Symbol.tau sym) - meml <- envLinks (Symbol.env sym) - memv <- envValues (Symbol.env sym) + let sym = case sym' of { SymbolT.C x -> x; } + tau <- tauIndex sym.tau + meml <- envLinks sym.env + memv <- envValues sym.env let a = meta g "SymC" [ - ("offset", anno (Symbol.pos sym).first.offset), - ("name", annoG g (Symbol.name sym)), + ("offset", anno sym.pos.first.offset), + ("name", annoG g sym.name), ("tau", anno tau), ("sups", if null sym.supers then PP.nil else annoListG g sym.supers), ("ins1", if null sym.insts then PP.nil else annoListG g (map fst sym.insts)), @@ -641,22 +644,23 @@ annoSymC sym = do ("lnks", some meml), ("funs", some memv), ("publik", if sym.vis == Public then PP.nil else anno false), - ("doc", maybe PP.nil anno (Symbol.doc sym))] + ("doc", maybe PP.nil anno sym.doc)] stio a -annoSymI sym = do +annoSymI sym' = do g ← getST - typ <- sigIndex (Symbol.typ sym) - meml <- envLinks (Symbol.env sym) - memv <- envValues (Symbol.env sym) + let sym = case sym' of { SymbolT.I x -> x; } + typ <- sigIndex sym.typ + meml <- envLinks sym.env + memv <- envValues sym.env let a = meta g "SymI" [ - ("offset", anno (Symbol.pos sym).first.offset), - ("name", annoG g (Symbol.name sym)), - ("clas", annoG g (Symbol.clas sym)), + ("offset", anno sym.pos.first.offset), + ("name", annoG g sym.name), + ("clas", annoG g sym.clas), ("typ", anno typ), ("lnks", some meml), ("funs", some memv), - ("doc", maybe PP.nil anno (Symbol.doc sym))] + ("doc", maybe PP.nil anno sym.doc)] stio a annoSymT :: Symbol -> StG DOCUMENT diff --git a/frege/compiler/Javatypes.fr b/frege/compiler/Javatypes.fr index 34956f4b..7e7474de 100644 --- a/frege/compiler/Javatypes.fr +++ b/frege/compiler/Javatypes.fr @@ -44,6 +44,9 @@ package frege.compiler.Javatypes where import frege.compiler.Utilities as U() import frege.lib.PP (text) +import frege.compiler.common.Lens (view) + +import Compiler.types.Symbols(SymbolT) import Compiler.types.Positions(Position) import Compiler.types.Global as G @@ -107,7 +110,7 @@ findAllSupers name g <- getST syms <- mapM U.findT (U.typesOfNativ name g) let oss = filter (g.ourSym) syms - pos = if null oss then Position.null else (head oss).pos + pos = if null oss then Position.null else view SymbolT.pos (head oss) E.error pos (text ("`" ++ name ++ "` is not a known java class")) changeST Global.{javaEnv <- _.delete name} Right c -> do diff --git a/frege/compiler/Kinds.fr b/frege/compiler/Kinds.fr index 1fb61057..be636cb5 100644 --- a/frege/compiler/Kinds.fr +++ b/frege/compiler/Kinds.fr @@ -41,6 +41,8 @@ module frege.compiler.Kinds where import frege.Prelude hiding(<+>, break) +import frege.compiler.common.Lens (set, unsafePartialView, view) + import Compiler.enums.Flags as Compilerflags(TRACEK) import Compiler.types.Positions(Positioned) @@ -71,47 +73,45 @@ kiTypes = do g <- getST let tsyms = typeSyms g deps = map (typeDep g) tsyms - tdeps = zip (map Symbol.name tsyms) deps + tdeps = zip (map (view SymbolT.name) tsyms) deps groups = tsort tdeps foreach groups kiTypeGroup return () --- do kind inference on a group of types kiTypeGroup qns = do - types <- mapM U.findT qns - let vartypes = filter (varKind . Symbol.kind) types -- with kinds that contain KVar - names = map Symbol.name vartypes - foreach vartypes (kiTypeSym names) - --- refresh :: Symbol -> StG Symbol --- refresh sym = getST >>= (return . unJust . sym.name.findit) + let unsafeToSymT s = case s of { SymbolT.T x -> x; } + types <- mapM (fmap unsafeToSymT . U.findT) qns + let vartypes = filter (varKind . SymT.kind) types -- with kinds that contain KVar + names = map SymT.name vartypes + foreach vartypes (kiTypeSym names . SymbolT.T) - kiTypeSym :: [QName] -> Symbol -> StG () kiTypeSym names sym = do g <- getST - E.logmsg TRACEK (Symbol.pos sym) (text ("kind check for " ++ nice sym g)) + E.logmsg TRACEK (view SymbolT.pos sym) (text ("kind check for " ++ nice sym g)) -- kind check all constructor sigmas - let cons = [ con | con@SymD{typ} <- values sym.env ] + let cons = [ con | con@(SymbolT.D _) <- values $ unsafePartialView SymbolT.env sym ] foreach cons (kiConSym names) g ← getST - sym ← U.findT sym.name + let unsafeToSymT s = case s of { SymbolT.T x -> x; } + sym <- fmap unsafeToSymT $ U.findT $ view SymbolT.name sym let kflat (KApp k ks) = k : kflat ks kflat ks = [ks] typ = ForAll (zipWith Tau.{kind=} (sym.typ.bound) (kflat sym.kind)) sym.typ.rho showbnds = text . joined " " . map (flip nice g) - changeSym sym.{typ} - E.logmsg TRACEK (Symbol.pos sym) (text "type is now ∀" + changeSym $ SymbolT.T sym.{typ} + E.logmsg TRACEK sym.pos (text "type is now ∀" <+> showbnds typ.bound <+> text "." <+> text (nicer typ.rho g) ) kiConSym names con = do g <- getST - E.logmsg TRACEK (Symbol.pos con) (text ("kind check for " ++ nice con g)) - (sigma,_) <- kiSigma names [] con.typ - changeSym con.{typ=sigma} + E.logmsg TRACEK (view SymbolT.pos con) (text ("kind check for " ++ nice con g)) + (sigma,_) <- kiSigma names [] (unsafePartialView SymbolT.typ con) + changeSym $ set SymbolT.typ sigma con -- kind inference on a 'Sigma' type where something else than 'KType' is expected kiSigmaX :: Sigma -> Kind -> StG (Sigma, Kind) @@ -221,11 +221,13 @@ kiRho names env (it@RhoFun{context,sigma,rho}) = do --- kind inference on a 'Ctx', takes into account kind checked classes only kiCtx names env Ctx{cname, tau} = do cls <- U.findC cname - case cls.tau.kind of - KVar -> return env -- not yet kind checked - k -> do - (_, env) <- unifyTauKind names env tau k - return env + case cls of + SymbolT.C symc -> + case symc.tau.kind of + KVar -> return env -- not yet kind checked + k -> do + (_, env) <- unifyTauKind names env tau k + return env type Envs = [TreeMap String Kind] @@ -293,24 +295,25 @@ unifyTauKind names env (TVar{pos,var,kind}) exp = do unifyTauKind names env (TCon{pos,name}) exp = do g <- getST sym <- U.findT name - - E.logmsg TRACEK pos (text ("unifyTauKind: " ++ nice name g - ++ " initial " ++ show sym.kind - ++ " expected " ++ show exp)) - - case unifyKind sym.kind exp of - Just k -> do - when (! (k `keq` sym.kind) && sym.name `elem` names) do - changeSym sym.{kind=k} - E.logmsg TRACEK pos (text ("unifyTauKind: " ++ nice name g ++ " result " ++ show k)) - return (k, env) - Nothing -> do - g <- getST - E.error pos (text ("kind error, type constructor `" ++ name.nice g - ++ "` has kind " - ++ show sym.kind - ++ ", expected was " ++ show exp)) - return (sym.kind, env) + case sym of + SymbolT.T symt -> do + E.logmsg TRACEK pos (text ("unifyTauKind: " ++ nice name g + ++ " initial " ++ show symt.kind + ++ " expected " ++ show exp)) + + case unifyKind symt.kind exp of + Just k -> do + when (! (k `keq` symt.kind) && symt.name `elem` names) do + changeSym $ SymbolT.T symt.{kind=k} + E.logmsg TRACEK pos (text ("unifyTauKind: " ++ nice name g ++ " result " ++ show k)) + return (k, env) + Nothing -> do + g <- getST + E.error pos (text ("kind error, type constructor `" ++ name.nice g + ++ "` has kind " + ++ show symt.kind + ++ ", expected was " ++ show exp)) + return (symt.kind, env) -- TCon b ~ exp => check TCon for kb -> exp and b for kb unifyTauKind names env (it@TApp a b) exp = do @@ -409,7 +412,7 @@ varKind (KApp a b) = varKind a || varKind b varKind _ = false --- find the 'Sigmas' of all constructors of the given type 'Symbol' -conSigmas (SymbolT.T SymT{env}) = [ typ | SymD{typ} <- values env ] +conSigmas (SymbolT.T SymT{env}) = [ typ | SymbolT.D SymD{typ} <- values env ] conSigmas _ = [] --- give the direct dependencies of a type symbol diff --git a/frege/compiler/Main.fr b/frege/compiler/Main.fr index 20bd573c..9588e9ca 100644 --- a/frege/compiler/Main.fr +++ b/frege/compiler/Main.fr @@ -46,6 +46,9 @@ import Control.monad.State import Data.TreeMap as TM(TreeMap, each, values, keys, insert, delete) import Data.List (sort, uniq) +import frege.compiler.common.Lens (preview, set, view) +import frege.data.Foldable (for_) + import frege.Version(version) import Compiler.enums.Flags @@ -59,6 +62,7 @@ import Compiler.types.Tokens import Compiler.enums.TokenID import Compiler.types.Packs import Compiler.types.Positions +import Compiler.types.Symbols (SymbolT) import Compiler.grammar.Lexer as L() import Compiler.grammar.Frege as F() @@ -258,18 +262,20 @@ makeFile glob sts = do foreach (values st) mergeSym mergeSym sym = do g ← getST - when (sym.vis != Private || sym.name.{tynm?}) do - case g.find sym.name of + when (view SymbolT.vis sym != Private || (view SymbolT.name sym).{tynm?}) do + case g.find (view SymbolT.name sym) of Just _ → return () none → do u ← uniqid - if sym.{env?} then enter sym.{sid=u, env=empty} else enter sym.{sid=u} + case preview SymbolT.env sym of + Just _ -> enter $ set SymbolT.sid u $ set SymbolT.env empty $ sym + Nothing -> enter $ set SymbolT.sid u $ sym E.logmsg TRACEZ Position.null ( text "makeFile: entered" <+> (text (sym.nice g)) <+> (text (show u)) ) - when sym.{env?} (mergeSymtab sym.env) + for_ (preview SymbolT.env sym) mergeSymtab --- make filename from package name @x.y.z.Packet@ => @dest/x/y/z/Packet.java@ targetPath :: Global -> String -> String diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index b170f898..7eae49fd 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -79,6 +79,8 @@ import Data.TreeMap as TM(TreeMap, values, lookup, insert, import Data.Graph (stronglyConnectedComponents tsort) import Data.List(groupBy, sortBy) +import frege.compiler.common.Lens (preview, unsafePartialView, view) + import Compiler.enums.Flags as Compilerflags(flagSet, OVERLOADING, TRACEO, TRACET, TRACEZ) import Compiler.enums.TokenID import Compiler.enums.Visibility @@ -121,26 +123,29 @@ post = stio true --- construct a tree of all our member functions memberTree = do g <- getST - let envs = g.thisTab : [ Symbol.env sy | sy <- values g.thisTab, Symbol.{env?} sy ] - mems = fold ins empty [ sy | env <- envs, sy@SymV {name=MName _ _} <- values env, g.ourSym sy] + let envs = g.thisTab : mapMaybe (preview SymbolT.env) (values g.thisTab) + mems = fold ins empty [ sy | env <- envs, sy@(SymbolT.V SymV{name=MName _ _}) <- values env, g.ourSym sy] ins :: TreeMap String [Symbol] -> Symbol -> TreeMap String [Symbol] ins t sy | Just list <- t.lookup b = if sy `elem` list then t else t.insert b (sy:list) | otherwise = insert b [sy] t - where b = (Symbol.name sy).base + where b = (view SymbolT.name sy).base stio mems -fundep mtree (SymV {name, expr=Just dx}) = do +fundep mtree (SymbolT.V (SymV{name, expr=Just dx})) = do g <- getST deptree <- dx >>= U.ourGlobalFuns mtree - let dep = [ Symbol.name sy | sy <- keys deptree, g.ourSym sy, - -- leave annotated symbols and symbols with sigmas out - sy.{expr?} && isPSigma sy.typ || not sy.{expr?} ] + let needed sy = + -- leave annotated symbols and symbols with sigmas out + case sy of + SymbolT.V SymV{typ} -> isPSigma typ + _ -> true + dep = [ view SymbolT.name sy | sy <- keys deptree, g.ourSym sy, needed sy ] stio (name, dep) -fundep mtree (SymV {name, expr=Nothing}) = stio (name, []) +fundep mtree (SymbolT.V (SymV{name, expr=Nothing})) = stio (name, []) fundep mtree other = do g <- getST - E.fatal other.pos (text ("fundep: strange symbol: " ++ other.nice g)) + E.fatal (view SymbolT.pos other) (text ("fundep: strange symbol: " ++ other.nice g)) --- collect all variable symbols and their dependencies @@ -211,30 +216,32 @@ mainSimple sigma = sigma annotateMain = do g <- getST case g.findit (VName g.thisPack "main") of - Just sym | sym.name.pack == g.thisPack, - Just dx <- sym.expr, - not sym.anno = do + Just (SymbolT.V sym) + | sym.name.pack == g.thisPack + , Just dx <- sym.expr + , not sym.anno -> do x <- dx if U.lambdaDepth x > 0 - then changeSym sym.{typ = mainSigma, anno = true} - else changeSym sym.{typ = mainSimple mainSigma, anno = true} - _ -> stio () + then changeSym $ SymbolT.V sym.{typ = mainSigma, anno = true} + else changeSym $ SymbolT.V sym.{typ = mainSimple mainSigma, anno = true} + | otherwise -> stio () + Nothing -> stio () checkMain = do g <- getST tau <- Util.newMeta2 ("a", KType) case g.findit (VName g.thisPack "main") of - Just sym | sym.name.pack == g.thisPack -> do - let m = Vbl {pos = sym.pos, name = sym.name, typ = Just pSigma} + Just sym | (view SymbolT.name sym).pack == g.thisPack -> do + let m = Vbl {pos = view SymbolT.pos sym, name = view SymbolT.name sym, typ = Just pSigma} sigma - | RhoFun{} <- sym.typ.rho = mainSigmaA tau + | RhoFun{} <- (unsafePartialView SymbolT.typ sym).rho = mainSigmaA tau | otherwise = mainSimple (mainSigmaA tau) checkAnnotated m sigma gnew <- getST when (g.errors < gnew.errors) do - E.error sym.pos (msgdoc ("The main function must have type " ++ nicer sigma g)) - when (g.errors == gnew.errors && not (null sym.typ.rho.context)) do - E.error sym.pos (msgdoc ("The main function type must not have type class constraints.")) + E.error (view SymbolT.pos sym) (msgdoc ("The main function must have type " ++ nicer sigma g)) + when (g.errors == gnew.errors && not (null (unsafePartialView SymbolT.typ sym).rho.context)) do + E.error (view SymbolT.pos sym) (msgdoc ("The main function type must not have type class constraints.")) _ -> stio () -- type check one group after the other as long as there are fewer than 7 errors -- checkgroups [] = stio () @@ -277,8 +284,9 @@ checkgroup7 nms = do -- foreach syms (\sym -> U.linkq (Local (show (Symbol.sid sym))) sym) -- foreach nms verbose foreach nms checkName - syms <- mapSt findV nms - when (length syms > 1 || any ((==Recursive) • Symbol.state) syms) + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + syms <- mapSt (fmap unsafeToSymV . findV) nms + when (length syms > 1 || any ((==Recursive) . _.state) syms) (foreach nms checkName) changeST Global.{typEnv <- drop (length nms)} g <- getST @@ -296,15 +304,16 @@ checkgroup7 nms = do where verbose nm = do g <- getST - sym <- findV nm - let sig = Symbol.typ sym - E.explain (Symbol.pos sym) (text (sym.nice g ++ " :: " ++ sig.nicer g)) + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> findV nm + let sig = sym.typ + E.explain sym.pos (text ((SymbolT.V sym).nice g ++ " :: " ++ sig.nicer g)) typeSanity nm = do sym <- findV nm - sym <- checkKind sym - checkAmbiguous sym sym.typ - checkReturn sym sym.typ - -- sym <- removeCheckedCtx sym sym.typ + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> checkKind sym + checkAmbiguous (SymbolT.V sym) sym.typ + checkReturn (SymbolT.V sym) sym.typ case sym.name of Local{} -> return () aGlobalName -> do -- issue #23 @@ -318,47 +327,46 @@ checkgroup7 nms = do Just dx -> do x <- dx ex <- U.mapEx false removeCtx x - changeSym sym.{expr = Just (return ex)} + changeSym $ SymbolT.V sym.{expr = Just (return ex)} where scrapCtx it = do - let sig = (Symbol.typ it).{rho <- clear} + let sig = it.typ.{rho <- clear} clear ∷ Rho → Rho clear RhoFun{context, sigma, rho} = RhoFun{context=[], sigma, rho = clear rho} clear RhoTau{context, tau} = RhoTau{context=[], tau} nex <- case it.expr of Just x -> x >>= U.mapEx false removeCtx >>= (return . Just . return) Nothing -> return Nothing - changeSym it.{typ=sig, expr = nex} + changeSym $ SymbolT.V it.{typ=sig, expr = nex} removeCtx (it@Let{env}) = do - syms <- mapM U.findV env + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + syms <- mapM (fmap unsafeToSymV . U.findV) env foreach syms scrapCtx return (Left it) removeCtx x = return (Left x) checkKind ∷ Symbol → StG Symbol -checkKind sym = correctK empty sym +checkKind sym = fmap SymbolT.V $ correctK empty $ unsafeToSymV sym where - correctK ∷ TreeMap String Tau → Symbol → StG Symbol + unsafeToSymV s = case s of { SymbolT.V x -> x; } + correctK :: TreeMap String Tau -> SymV Global -> StG (SymV Global) correctK subst (sym@SymV{typ,expr}) = do - --g ← getST - --E.logmsg TRACEZ sym.pos (text "Checking kind of" <+> text (nice sym g)) sig ← bool (pure typ) (fst <$> K.kiSigma [] [] typ) (null typ.bound) - let rsubst = sig.extendEnv subst -- (zip sig.vars (sig.tvars sym.pos)) + let rsubst = sig.extendEnv subst ex ← maybe (pure Nothing) (\x → Just <$> (x >>= mapEx false (correctKind rsubst))) expr let new = sym.{typ=sig, expr = fmap pure ex} return new - correctK subst sym = error "only SymV allowed" correctKind subst Let{env, ex, typ} = do - syms ← mapM U.findV env + syms <- mapM (fmap unsafeToSymV . U.findV) env mapM_ (correctK subst) syms - ex' ← mapEx false (correctKind subst) ex + ex' <- mapEx false (correctKind subst) ex pure $ Right Let{env, ex = ex', typ = fmap (substSigma subst) typ } correctKind subst x = pure $ Left x.{typ ← fmap (substSigma subst)} @@ -371,14 +379,14 @@ checkAmbiguous sym (ForAll bnd r) = do if null bad then stio () else do g <- getST - E.error (Symbol.pos sym) (msgdoc ("Ambiguous type " + E.error (view SymbolT.pos sym) (msgdoc ("Ambiguous type " ++ nicer r g ++ " in " ++ nice sym g)) - E.hint (Symbol.pos sym) (msgdoc ("It is not clear at what types to instantiate " + E.hint (view SymbolT.pos sym) (msgdoc ("It is not clear at what types to instantiate " ++ (if length bad == 1 then "type variable " else "type variables ") ++ joined ", " bad ++ " that " ++ (if length bad == 1 then "occurs" else "occur") ++ " in the context, but not in the type.")) - E.hint (Symbol.pos sym) (msgdoc ("This can happen through constructs like (Enum.ord • Enum.from) " + E.hint (view SymbolT.pos sym) (msgdoc ("This can happen through constructs like (Enum.ord • Enum.from) " ++ " where a class context is both introduced and eliminated locally so " ++ "that a caller can not know which type is meant.")) @@ -396,7 +404,7 @@ checkReturn sym sigma = if all (`elem` svars) tvars then stio () else do g <- getST - U.symWarning E.warn sym (msgdoc ("application of " ++ sym.name.nice g ++ " will diverge.")) + U.symWarning E.warn sym (msgdoc ("application of " ++ (view SymbolT.name sym).nice g ++ " will diverge.")) {- removeCheckedCtx :: Symbol -> Sigma -> StG Symbol removeCheckedCtx sym sigma @@ -409,11 +417,11 @@ removeCheckedCtx sym sigma resolveConstraints :: Symbol -> StG () resolveConstraints sym - | SymV{typ, expr=Just x, anno=false, state} <- sym, state != Recursive = do + | SymbolT.V (symv@SymV{typ, expr=Just x, anno=false, state}) <- sym, state != Recursive = do x <- x >>= resolveHas cxs <- collectConstrs x - rho <- simplify sym.pos typ.rho.{context=cxs} - >>= simplify sym.pos -- remove duplicates + rho <- simplify symv.pos typ.rho.{context=cxs} + >>= simplify symv.pos -- remove duplicates -- Drop the contexts that contain a rigid tvar that is not occurring in the type itself. -- Those stem from typechecking applications of higher rank functions where -- there is a constraint in an inner forall. @@ -424,7 +432,7 @@ resolveConstraints sym ctxmetas = map (ctxTvs g) rho.context let filteredCtx = [ ctx | (metas, ctx) <- zip ctxmetas rho.context, all (`elem` rhometas) (filter (not . MetaTv.isFlexi) metas)] - changeSym sym.{typ <- Sigma.{rho <- rmtrailing . Rho.{context=filteredCtx}}, + changeSym $ SymbolT.V symv.{typ <- Sigma.{rho <- rmtrailing . Rho.{context=filteredCtx}}, expr = Just (return x)} | otherwise = return () where @@ -443,13 +451,14 @@ substInstMethod :: QName -> StG () substInstMethod qname = do g <- getST -- when (U.isOn g.options.flags OPTIMIZE) do - sym <- findV qname + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> findV qname case sym.expr of Nothing -> stio () Just dx -> do x <- dx x <- mapEx true substInst x - changeSym sym.{expr = Just (return x)} + changeSym $ SymbolT.V sym.{expr = Just (return x)} --- replace class member with instance member, if possible substInst (vbl@Vbl {pos, name = MName tn bs, typ = Just (ForAll [] rho)}) @@ -460,36 +469,38 @@ substInst (vbl@Vbl {pos, name = MName tn bs, typ = Just (ForAll [] rho)}) let tau = reducedTau g ctau case instTauSym tau g of Just symt -> do -- we have a type name - symc <- findC tn -- must be a class because it appears in a contexts cname - case filter ((symt.name ==) • fst) symc.insts of -- find instance - [] -> E.fatal pos (text (symc.nice g ++ " has no instance for " ++ symt.nice g)) + let unsafeToSymC s = case s of { SymbolT.C x -> x; } + symc <- unsafeToSymC <$> findC tn -- must be a class because it appears in a contexts cname + case filter ((view SymbolT.name symt ==) • fst) symc.insts of -- find instance + [] -> E.fatal pos (text ((SymbolT.C symc).nice g ++ " has no instance for " ++ symt.nice g)) [(_,iname)] {- | MName iname bs != qname -} -> do - mem <- findV vbl.name + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + mem <- unsafeToSymV <$> findV vbl.name case g.findit (MName iname bs) of Just imem -> do let nrho = rho.{context <- filter (not • sameCtx ctx)} strho = substRho - (unifySigma g imem.typ ForAll{bound=[], rho=nrho}) - imem.typ.rho - !repl | SymV{} <- imem = vbl.{name=imem.name, + (unifySigma g (unsafePartialView SymbolT.typ imem) ForAll{bound=[], rho=nrho}) + (unsafePartialView SymbolT.typ imem).rho + !repl | SymbolT.V _ <- imem = vbl.{name=view SymbolT.name imem, typ = Just (ForAll [] strho)} - | SymD{} <- imem = Con{pos=vbl.pos, - name=imem.name, + | SymbolT.D _ <- imem = Con{pos=vbl.pos, + name=view SymbolT.name imem, typ = Just (ForAll [] strho)} | otherwise = error ("substInst WTF??? : " ++ nicer imem g) E.logmsg TRACEO pos ( - text ("replace " ++ vbl.name.nice g) + text ("replace " ++ vbl.name.nice g) nest 4 ( text (":: " ++ vbl.typ.nicer g) text ("sigma :: " ++ mem.typ.nicer g) - text ("with " ++ imem.name.nice g) - <+> text (" :: " ++ imem.typ.nicer g) + text ("with " ++ (view SymbolT.name imem).nice g) + <+> text (" :: " ++ (unsafePartialView SymbolT.typ imem).nicer g) text ("@@ " ++ nrho.nicer g) text ("?? " ++ strho.nicer g))) changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk vbl.pos.first) (Right imem.name)}} - weUse imem.name + idKind <- insert (KeyTk vbl.pos.first) (Right (view SymbolT.name imem))}} + weUse (view SymbolT.name imem) stio (Left repl) Nothing -> E.fatal vbl.pos (msgdoc ("substInst: trying " ++ nice vbl g ++ ", but " @@ -498,7 +509,7 @@ substInst (vbl@Vbl {pos, name = MName tn bs, typ = Just (ForAll [] rho)}) -- | otherwise = do -- E.logmsg TRACEO pos (text ("mustn't substitute " ++ qname.nice g ++ " in its own body.")) -- stio (Left vbl) - _ -> E.fatal pos (text (symc.nice g ++ " has multiple instances for " ++ symt.nice g)) + _ -> E.fatal pos (text ((SymbolT.C symc).nice g ++ " has multiple instances for " ++ symt.nice g)) _ -> do E.logmsg TRACEO pos (text ("no suitable instance: " ++ vbl.nice g ++ " :: " ++ rho.nicer g)) stio (Left vbl) -- TVar or Meta @@ -513,11 +524,11 @@ substInst (lit@Lit{pos, kind, value, typ=Just (ForAll [] rho)}) substInst x = stio (Left x) renameSigma ∷ Symbol -> StG () -renameSigma sym | sym.name.isLocal && sym.anno = do +renameSigma sym' | sym.name.isLocal && sym.anno = do g ← getST - outer ← mapSt findV g.typEnv - let avoid = \c → c `elem` concatMap (Sigma.vars . Symbol.typ) outer - || (any (null . Sigma.vars . Symbol.typ) outer && avoidBinders g c) + outer <- mapSt (fmap unsafeToSymV . findV) g.typEnv + let avoid = \c → c `elem` concatMap (Sigma.vars . _.typ) outer + || (any (null . Sigma.vars . _.typ) outer && avoidBinders g c) newsym = sym.{typ ← avoidSigma avoid } when (sym.typ.vars != newsym.typ.vars) do E.warn sym.pos ((text "Renamed type variables in annotated type of let bound function " @@ -525,17 +536,19 @@ renameSigma sym | sym.name.isLocal && sym.anno = do (text "was: " <+> text (sym.typ.nicer g)) (text "now: " <+> text (newsym.typ.nicer g)) text "because of (potential) type variable naming conflicts.") - changeSym newsym + changeSym $ SymbolT.V newsym pure () + where + unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym = unsafeToSymV sym' renameSigma other = pure () checkName nm = do g <- getST - sym <- findV nm - -- sym <- if nm.isLocal && sym.anno then renameSigma sym else pure sym + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> findV nm E.logmsg TRACEZ sym.pos (text ("checkName: " ++ sym.name.nice g ++ " :: " ++ sym.typ.nice g)) - -- E.logmsg TRACET sym.pos (text ("checkName: " ++ sym.name.nice g ++ " :: " ++ sym.typ.nice g)) sigma <- checkSym sym unless (nm.isLocal) do sym <- findV nm @@ -543,27 +556,25 @@ checkName nm = do where checkSym sym = do g <- getST - -- E.logmsg TRACEZ (Symbol.pos sym) (text ("typechecking " ++ sym.nice g ++ ", state=" ++ show sym.state)) - -- E.logmsg TRACET (Symbol.pos sym) (text ("typechecking " ++ sym.nice g ++ ", state=" ++ show sym.state)) case sym of SymV {nativ = Just _, typ = t} | not (isPSigma t) -> do (sig, _) <- K.kiSigma [] [] t E.logmsg TRACEZ sym.pos (text "after kind inference: " <+> text (sig.nicer g)) - changeSym sym.{typ=sig} - M.sanity sym.{typ=sig} + changeSym $ SymbolT.V sym.{typ=sig} + M.sanity $ SymbolT.V sym.{typ=sig} return sig SymV {expr = Nothing, name, pos, typ = t} | not (isPSigma t), MName c _ <- name, - Just (SymC {pos}) <- g.findit c = do + Just (SymbolT.C _) <- g.findit c = do (sig, _) <- K.kiSigma [] [] t - changeSym sym.{state=Typechecked, vis=Abstract, typ = sig} + changeSym $ SymbolT.V sym.{state=Typechecked, vis=Abstract, typ = sig} stio t | otherwise = do - E.error pos (msgdoc ("implementation missing for " ++ sym.nice g)) + E.error pos (msgdoc ("implementation missing for " ++ (SymbolT.V sym).nice g)) (sig, _) <- K.kiSigma [] [] t - changeSym sym.{state=Typechecked, typ=sig} + changeSym $ SymbolT.V sym.{state=Typechecked, typ=sig} stio t SymV {expr = Just dx, typ = t} | isPSigma t, @@ -572,16 +583,17 @@ checkName nm = do rho0 <- approxRho x ex <- case rho0 of RhoTau{} -> do - changeSym sym.{state=Typechecking} + changeSym $ SymbolT.V sym.{state=Typechecking} (rho, ex) <- inferRho x -- CAF ? return ex RhoFun{} -> do - changeSym sym.{state=Typechecking, typ = ForAll [] rho0} + changeSym $ SymbolT.V sym.{state=Typechecking, typ = ForAll [] rho0} checkRho x rho0 - sym <- findV sym.name -- refresh, might be updated meanwhile + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> findV sym.name -- refresh, might be updated meanwhile let newstate = if sym.state != Recursive then Typechecked else Recursive newsig <- maybe (error "untyped after checkRho") pure ex.typ - changeSym sym.{typ = newsig, expr=Just (return ex), state = newstate} + changeSym $ SymbolT.V sym.{typ = newsig, expr=Just (return ex), state = newstate} stio newsig SymV {expr = Just dx, typ = t, state, anno} @@ -592,36 +604,40 @@ checkName nm = do <+> text (nice sig g)) x <- checkAnnotated x sig -- t <- canonicSignature t - changeSym sym.{state = Typechecked, expr = Just (return x), typ = sig } + changeSym $ SymbolT.V sym.{state = Typechecked, expr = Just (return x), typ = sig } stio sig | not (isPSigma t), state == Typechecked && anno = stio t -- opt: do not recheck annotated | not (isPSigma t), state == Recursive || state == Typechecked = do x <- dx (rho, ex) <- inferRho x rho <- zonkRho rho - sym <- findV sym.name -- refresh, might be updated meanwhile + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> findV sym.name -- refresh, might be updated meanwhile let newsig = ForAll [] rho - changeSym sym.{typ = newsig, expr=Just (return ex), state = Typechecked} + changeSym $ SymbolT.V sym.{typ = newsig, expr=Just (return ex), state = Typechecked} stio newsig - wrongsy -> E.fatal wrongsy.pos (text ("checkSym: wrong symbol: " ++ wrongsy.nice g + wrongsy -> E.fatal wrongsy.pos (text ("checkSym: wrong symbol: " ++ (SymbolT.V wrongsy).nice g ++ ", state=" ++ show wrongsy.state ++ ", expr isJust: " ++ show (isJust wrongsy.expr) ++ ", typ : " ++ wrongsy.typ.nice g)) quantifyOne nms = do g <- getST - sym <- U.findV (head nms) + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> U.findV (head nms) lsyms <- mapSt U.findV g.typEnv - let rec = [ Symbol.typ sym | sym <- lsyms, - sym <- (g.follow sym), -- follow aliases - Symbol.state sym == Recursive] + let rec = [ sym.typ + | sym <- lsyms + , sym <- unsafeToSymV <$> g.follow sym -- follow aliases + , sym.state == Recursive] when (false && null sym.typ.rho.context && not (TH.isFun sym.typ g) && null rec) do quantifyWith (quantifiedExcept sym.sid) nms stio () quantifyMany = quantifyWith quantified quantifyWith f nms = do - syms <- mapSt findV nms -- unquantified symbols + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + syms <- mapSt (fmap unsafeToSymV . findV) nms -- unquantified symbols g <- getST unless (null syms) do E.logmsg TRACET (head syms).pos (text ("quantify " ++ joined ", " (map (flip QName.nice g) nms))) @@ -631,7 +647,7 @@ quantifyWith f nms = do nativ = Nothing, anno = false, typ = (ForAll [] rho)}) <- syms, not (isPSigma sy.typ)] - asyms = [ (name, typ) | sy@SymV {name, expr = Just _, + asyms = [ (name, typ) | SymV {name, expr = Just _, nativ = Nothing, anno = true, typ} <- syms ] -- sigRho (ForAll [] rho) = rho @@ -642,17 +658,18 @@ quantifyWith f nms = do foreach asyms changeSig where changeSig (qnm, sigm) = do - sym <- findV qnm + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> findV qnm case sym of SymV {expr = Just dx} -> do x <- dx zex <- zonkExpr x -- from here on no bound Meta anywhere zex <- zonkRigid (Sigma.vars sigm) zex -- replace Rigid#nnn a where a is bound let sigma = substRigidSigma (Sigma.vars sigm) sigm - changeSym sym.{typ = sigma, expr = Just (return zex), anno = true} + changeSym $ SymbolT.V sym.{typ = sigma, expr = Just (return zex), anno = true} g <- getST - E.logmsg TRACET (Symbol.pos sym) (text ("qfy: " ++ sym.nice g ++ " :: " ++ sigma.nice g)) - E.explain (Symbol.pos sym) (text (sym.nice g ++ " :: " ++ sigma.nicer g)) + E.logmsg TRACET sym.pos (text ("qfy: " ++ (SymbolT.V sym).nice g ++ " :: " ++ sigma.nice g)) + E.explain sym.pos (text ((SymbolT.V sym).nice g ++ " :: " ++ sigma.nicer g)) other = Prelude.error "findV behaves badly" @@ -662,7 +679,7 @@ zonkRigid bound ex = do -- g <- getST mapEx false zonk ex where - symWork (symv@ SymV {pos, expr, typ = sig}) = do + symWork (SymbolT.V (symv@SymV{expr, typ = sig})) = do g <- getST -- E.logmsg TRACEZ (getpos ex) (text ("symWork: " ++ show (bound ++ sig.vars) ++ " " ++ nice ex g)) rhoz ← zonkRho sig.rho @@ -673,7 +690,7 @@ zonkRigid bound ex = do x <- zonkRigid (bound ++ sig.vars) x return (Just (return x)) Nothing -> return Nothing - changeSym symv.{expr, typ = ForAll sig.bound rho} + changeSym $ SymbolT.V symv.{expr, typ = ForAll sig.bound rho} symWork _ = error "symWork: not a variable" zonk (x@Let {env,ex,typ = Just sigm}) = do @@ -720,11 +737,11 @@ zonkExpr x = mapEx false zonk x foreach syms symWork stio (Left x.{typ = Just sig}) where - symWork (symv@ SymV {pos, expr = Just dex, typ = sig}) = do + symWork (SymbolT.V (symv@SymV{expr = Just dex, typ = sig})) = do sig <- zonkSigma sig ex <- dex ex <- zonkExpr ex - changeSym symv.{expr = Just (return ex), typ = sig} + changeSym $ SymbolT.V symv.{expr = Just (return ex), typ = sig} symWork _ = error "symWork: not a variable" zonk x | Just sig <- Expr.typ x = do @@ -934,36 +951,38 @@ tcRho' (x@Vbl{name}) (ety@Check erho) tcRho' (x@Vbl {name}) ety = do sym <- findVD name - case sym of - SymD{} -> tcRho' Con{pos=x.pos, name=x.name, typ=x.typ} ety - other -> case isPSigma sym.typ of - false -> if sym.state != Typechecked + case sym of + SymbolT.D _ -> tcRho' Con{pos=x.pos, name=x.name, typ=x.typ} ety + SymbolT.V symv -> case isPSigma symv.typ of + false -> if symv.state != Typechecked then do - sig ← fst <$> K.kiSigma [] [] sym.typ - changeSym sym.{typ=sig} + sig ← fst <$> K.kiSigma [] [] symv.typ + changeSym $ SymbolT.V symv.{typ=sig} rho <- instantiate sig instRho x rho ety else do - rho <- instantiate sym.typ + rho <- instantiate symv.typ instRho x rho ety - true -> if sym.state == Unchecked + true -> if symv.state == Unchecked then do checkName name - sym <- findV name + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> findV name rho <- instantiate sym.typ instRho x rho ety - else if sym.state == Typechecking - || sym.state == Recursive then do + else if symv.state == Typechecking + || symv.state == Recursive then do -- unavoidable in mutual recursive definitions - changeSym sym.{state=Recursive} + changeSym $ SymbolT.V symv.{state=Recursive} rho <- approxRho x instRho x rho ety else do g <- getST - E.fatal (getpos x) (text ("tcRho: untyped " ++ x.nice g ++ ", state=" ++ show sym.state)) + E.fatal (getpos x) (text ("tcRho: untyped " ++ x.nice g ++ ", state=" ++ show symv.state)) tcRho' (x@Con {name}) ety = do - sym <- U.findD name + let unsafeToSymD s = case s of { SymbolT.D x -> x; } + sym <- unsafeToSymD <$> U.findD name rho <- instantiate sym.typ instRho x rho ety @@ -1074,12 +1093,12 @@ tcRho' (x@Mem {ex,member}) ety = do case instTauSym tau g of Just (SymbolT.T SymT{name, env, nativ, newt}) - | Just (SymV {name}) <- env.lookup member.value = do + | Just (SymbolT.V (SymV{name})) <- env.lookup member.value = do changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk original) (Right name)}} weUse name tcRho (nApp (Vbl mpos name Nothing) ex) ety - | Just (SymL {alias}) <- env.lookup member.value = do + | Just (SymbolT.L SymL{alias}) <- env.lookup member.value = do changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk original) (Right alias)}} weUse alias @@ -1092,8 +1111,8 @@ tcRho' (x@Mem {ex,member}) ety = do -- traceLn ("types " ++ show qns) || true, h:_ <- [ h | q <- qns, h <- g.findit (MName q member.value) ] = do let m = case h of - SymV {name} -> name - SymL {alias} -> alias + SymbolT.V SymV{name} -> name + SymbolT.L SymL{alias} -> alias _ -> error "no symbol or alias" changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk original) (Right m)}} @@ -1104,16 +1123,18 @@ tcRho' (x@Mem {ex,member}) ety = do TApp _ ntau <- tau, -- Mutable x ntau TCon{name=tcon}:_ <- ntau.flat, Just (SymbolT.T SymT{nativ=Just s}) <- g.findit tcon, - SymV{name=m}:_ <- [ h | sup <- s:U.supersOfNativ s g, - q <- U.typesOfNativ sup g, - h <- g.findit (MName q member.value) ] + (SymbolT.V SymV{name=m}):_ <- + [ h + | sup <- s:U.supersOfNativ s g + , q <- U.typesOfNativ sup g + , h <- g.findit (MName q member.value) ] = do changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk original) (Right m)}} weUse m tcRho (nApp (Vbl mpos m Nothing) ex) ety - other | Just (m@SymV {name=MName clas _}) <- g.findit (VName g.thisPack member.value), - Just (SymC {tau}) <- g.findit clas = do + other | Just (SymbolT.V (m@SymV {name=MName clas _})) <- g.findit (VName g.thisPack member.value), + Just (SymbolT.C _) <- g.findit clas = do changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk original) (Right m.name)}} weUse m.name @@ -1194,20 +1215,20 @@ tcPat' (p@PLit {pos,kind}) ety = case kind of LRegex -> instPatSigma p (sigString) ety tcPat' (p@PVar {uid,var}) (ety@Check sig) = do - sym <- findV (Local{uid, base=var}) - -- E.logmsg TRACET p.pos (text("lookup PVar{uid=" ++ show uid ++ "} --> " ++ show sym.name)) + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> findV (Local{uid, base=var}) case isPSigma sym.typ of - true -> do changeSym sym.{typ=sig, state=Typechecked} + true -> do changeSym $ SymbolT.V sym.{typ=sig, state=Typechecked} instPatSigma p sig ety false -> instPatSigma p sym.typ ety tcPat' (p@PVar {uid,var}) ety = do - sym <- findV (Local{uid, base=var}) - -- E.logmsg TRACET p.pos (text("lookup PVar{uid=" ++ show uid ++ "} --> " ++ show sym.name)) + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> findV (Local{uid, base=var}) case isPSigma sym.typ of true -> do sig <- newSigmaTyVar (var, KType) - changeSym sym.{typ = sig, state = Typechecked} + changeSym $ SymbolT.V sym.{typ = sig, state = Typechecked} instPatSigma p sig ety false -> instPatSigma p sym.typ ety @@ -1216,7 +1237,8 @@ tcPat' (p@PMat {pos,uid,var}) ety = do instPatSigma p sigString ety tcPat' (p@PCon {qname,pats}) ety = do - sym <- findD qname + let unsafeToSymD s = case s of { SymbolT.D x -> x; } + sym <- unsafeToSymD <$> findD qname rho <- instantiate sym.typ let spRho (RhoFun _ s r) = case spRho r of (args, ret) -> (s:args,ret) @@ -1337,7 +1359,8 @@ resolveHas expr = do countMem !acc Mem{} = return . Left $! (acc+1) countMem !acc Vbl{name} | not name.isLocal = do - sym <- U.findV name + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> U.findV name case sym.over of [] -> return . Right $! acc -- not overloaded _ -> return . Right $! (acc+1) -- overloaded @@ -1387,10 +1410,11 @@ rHas _ (x@Mem{ex, member, typ = Nothing}) = do error ("expression " ++ x.nicer g ++ " is untyped") rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do - sym <- U.findV name + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> U.findV name case sym.over of [] -> return (Right v) - _ -> resolveOver v sym + _ -> resolveOver v $ SymbolT.V sym where -- resolve overloaded variable resolveOver :: Expr -> Symbol -> StG (Expr|Expr) @@ -1402,11 +1426,11 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do let candidates = overloads g sym groups - | MName{} <- sym.name = groupBy (using (QName.tynm . Symbol.name)) candidates + | MName{} <- view SymbolT.name sym = groupBy (using (QName.tynm . view SymbolT.name)) candidates | otherwise = [candidates] E.logmsg TRACET v.pos (text ("by " - ++ joined ", " (map (flip nice g . Symbol.name) candidates))) + ++ joined ", " (map (flip nice g . view SymbolT.name) candidates))) checked <- mapM (resolve v.pos sigma) groups case filter (not . null) checked of @@ -1429,19 +1453,19 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do <> text "´ is ambiguous at type " <+/> text (nicer sigma g) text "It could mean one of " - stack [ text (nicer (Symbol.name s) g) - <+> text " :: " - <+> text (nicer s.typ g) + stack [ text (nicer (view SymbolT.name s) g) + <+> text " :: " + <+> text (nicer (unsafePartialView SymbolT.typ s) g) | s <- some ]) let s = head some diag = if length some > 1 then E.warn else E.explain diag v.pos (msgdoc ("overloaded " ++ nicer v.name g ++ " :: " ++ nicer sigma g ++ " resolved to " - ++ nicer s.name g)) - x <- checkSigma Vbl{pos=v.pos, name=s.name, typ=Nothing} sigma + ++ nicer (view SymbolT.name s) g)) + x <- checkSigma Vbl{pos=v.pos, name=view SymbolT.name s, typ=Nothing} sigma changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk v.pos.first) (Right s.name)}} + idKind <- insert (KeyTk v.pos.first) (Right (view SymbolT.name s))}} return (Right x) where resolve ∷ Position → Sigma → [Symbol] → StG [Symbol] @@ -1449,7 +1473,7 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do resolve pos sigma (sym:syms) = do g1 <- getST changeST Global.{options <- Options.{flags <- flagSet OVERLOADING}} - x <- checkSigma Vbl{pos, name=Symbol.name sym, typ=Nothing} sigma + x <- checkSigma Vbl{pos, name=view SymbolT.name sym, typ=Nothing} sigma g <- getST putST g1 if (g.errors > g1.errors) @@ -1459,16 +1483,16 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do return (sym:rs) overloads ∷ Global → Symbol → [Symbol] overloads g sym = case sym of - SymV{over=[]} -> [sym] - SymV{pos, name = MName{tynm, base}, over=(_:_)} + SymbolT.V SymV{over=[]} -> [sym] + SymbolT.V SymV{name = MName{tynm, base}, over=over@(_:_)} | Just (SymbolT.T SymT{nativ = Just this}) <- g.findit tynm, - ov <- [ sy | m <- sym.over, sy <- g.findit m ], + ov <- [ sy | m <- over, sy <- g.findit m ], syms <- [ sy | s <- U.supersOfNativ this g, q <- U.typesOfNativ s g, h <- g.findit (MName q base), sy <- overloads g h] = ov++syms - SymV{} -> [ sy | m <- sym.over, sy <- g.findit m] + SymbolT.V SymV{over} -> [ sy | m <- over, sy <- g.findit m] _ -> [] rHas _ x = pure (Left x) diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index 687f56dc..46caad7a 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -50,6 +50,8 @@ import Data.List as DL(partitioned, sortBy, minimumBy, \\) import Lib.PP(fill, break, pretty, text, nest, msgdoc, <+>, <>, DOCUMENT) +import frege.compiler.common.Lens (over, preview, set, unsafePartialView, view) + -- import Compiler.enums.Flags import Compiler.enums.TokenID(defaultInfix, VARID) import Compiler.enums.RFlag(RState) @@ -121,8 +123,8 @@ supersOfNativ nativ g = case g.javaEnv.lookup nativ of findC qname = do g <- getST case g.findit qname of - Just (symc@SymC {pos}) -> stio symc - Just sym -> E.fatal sym.pos (fill (break ("looked for class " ++ qname.nice g ++ ", found " + Just (symc@(SymbolT.C _)) -> stio symc + Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for class " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for class " ++ qname.nice g ++ ", found Nothing"))) @@ -130,8 +132,8 @@ findC qname = do findI qname = do g <- getST case g.findit qname of - Just (symc@SymI {pos}) -> stio symc - Just sym -> E.fatal sym.pos (fill (break ("looked for instance " ++ qname.nice g ++ ", found " + Just (symc@(SymbolT.I _)) -> stio symc + Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for instance " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for instance " ++ qname.nice g ++ ", found Nothing"))) @@ -139,8 +141,8 @@ findI qname = do findT qname = do g <- getST case g.findit qname of - Just (symc@SymbolT.T _) -> stio symc - Just sym -> E.fatal sym.pos (fill (break("looked for type " ++ qname.nice g ++ ", found " + Just (symc@(SymbolT.T _)) -> stio symc + Just sym -> E.fatal (view SymbolT.pos sym) (fill (break("looked for type " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for type " ++ qname.nice g ++ ", found Nothing"))) @@ -148,8 +150,8 @@ findT qname = do findV qname = do g <- getST case g.findit qname of - Just (symc@SymV {pos}) -> stio symc - Just sym -> E.fatal sym.pos (fill (break ("looked for function " ++ qname.nice g ++ ", found " + Just (symc@(SymbolT.V _)) -> stio symc + Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for function " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for function " ++ qname.nice g ++ ", found Nothing"))) @@ -157,9 +159,9 @@ findV qname = do findVD qname = do g <- getST case g.findit qname of - Just (symc@SymV {pos}) -> stio symc - Just (symc@SymD {pos}) -> stio symc - Just sym -> E.fatal sym.pos (fill (break ("looked for function or constructor " ++ qname.nice g ++ ", found " + Just (symc@(SymbolT.V _)) -> stio symc + Just (symc@(SymbolT.D _)) -> stio symc + Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for function or constructor " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for function " ++ qname.nice g ++ ", found Nothing"))) @@ -167,8 +169,8 @@ findVD qname = do findD qname = do g <- getST case g.findit qname of - Just (symc@SymD {pos}) -> stio symc - Just sym -> E.fatal sym.pos (fill (break ("looked for constructor " ++ qname.nice g ++ ", found " + Just (symc@SymbolT.D _) -> stio symc + Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for constructor " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for constructor " ++ qname.nice g ++ ", found Nothing"))) @@ -224,7 +226,7 @@ freeTauTVars _ collected _ = collected --- return a list of constructors in this environment ordered by constructor number envConstructors :: Symtab -> [Symbol] -envConstructors env = sortBy (comparing Symbol.cid) [ sy | (sy::Symbol) <- values env, sy.{cid?} ] +envConstructors env = map SymbolT.D $ sortBy (comparing SymD.cid) [ syd | SymbolT.D syd <- values env ] --- provide a new Position for a Pattern @@ -285,7 +287,7 @@ patLocal pos uid name = vSym pos (Local uid name) --- set uid for a local symbol -setuid uid = Symbol.{sid=uid, name <- QName.{uid}} +setuid uid = over SymbolT.name QName.{uid} . set SymbolT.sid uid {-- @@ -307,9 +309,9 @@ freshVar pos = do --- update the local names uids in an expression that match one of the symbols by name replaceLocals :: [Symbol] -> Expr -> StG (Either Expr Expr) -replaceLocals syms (v@Vbl {name = Local 0 s}) = - case DL.find (\sym -> sym.name.base == s) syms of - Just sym -> stio (Right v.{name = sym.name}) +replaceLocals syms (v@Vbl {name = Local 0 s}) = + case DL.find (\sym -> (view SymbolT.name sym).base == s) syms of + Just sym -> stio (Right v.{name = view SymbolT.name sym}) other -> stio (Right v) replaceLocals syms x = stio (Left x) @@ -319,7 +321,7 @@ replaceLocals syms x = stio (Left x) * and 'Symbol.name' set to standard values. * If the name is a 'Local' one, the 'Symbol.sid' is set to the 'QName.uid' -} -vSym pos name = SymV {pos, +vSym pos name = SymbolT.V $ SymV {pos, sid= if QName.{uid?} name then name.uid else 0, name, vis=Private, doc=Nothing, typ=pSigma, expr=Nothing, nativ=Nothing, @@ -524,7 +526,7 @@ transTApp (con:as) = do as <- mapSt transTau as appTauSigmas ncon as -- checkTApp partial (ncon:as) - Just (alias@SymA {typ}) + Just (SymbolT.A (alias@SymA {typ})) | ForAll _ (RhoTau _ tau) <- typ, length as >= length alias.vars = do as <- mapSt transTau as -- partial args allowed in alias @@ -539,7 +541,7 @@ transTApp (con:as) = do appTauSigmas posnt ras | ForAll _ (RhoTau _ tau) <- typ, length as < length alias.vars = do - E.error pos (msgdoc ("apply " ++ alias.nice g ++ " to at least " + E.error pos (msgdoc ("apply " ++ (SymbolT.A alias).nice g ++ " to at least " ++ show (length alias.vars) ++ " type arguments")) unit @@ -553,7 +555,7 @@ transTApp (con:as) = do targs <- mapSt forceTau sargs let env = TM.fromList (zip (map Tau.var alias.vars) targs) return (substSigma env alias.typ) - | otherwise = do E.error pos (msgdoc("Apply " ++ alias.nice g + | otherwise = do E.error pos (msgdoc("Apply " ++ (SymbolT.A alias).nice g ++ " to exactly " ++ show alias.vars.length ++ " type arguments.")) unit @@ -621,9 +623,9 @@ appTauSigmas tau sigs = foldM appTauSig tau sigs >>= return . tauAsSigma -} symWarning :: (Position -> DOCUMENT -> StG ()) -> Symbol -> DOCUMENT -> StG () symWarning warn sym msg = do - case sym.doc of + case unsafePartialView SymbolT.doc sym of Just ´^\s*nowarn:´ -> return () - other -> warn sym.pos msg + other -> warn (view SymbolT.pos sym) msg {- ################# functions introduced through Classes.fr ############## -} @@ -636,7 +638,7 @@ symWarning warn sym msg = do isSuper x g y | x == y = true - | ysym@Just (SymC {supers}) <- Global.findit g y = any (isSuper x g) supers + | ysym@Just (SymbolT.C SymC{supers}) <- Global.findit g y = any (isSuper x g) supers | otherwise = false @@ -691,7 +693,7 @@ foldEx b f a ex = do Let {env,ex} | b = do syms <- mapSt findV env - xs <- sequence [ x | SymV {expr=Just x} <- syms ] + xs <- sequence [ x | SymbolT.V SymV{expr=Just x} <- syms ] a <- foldSt (foldEx b f) a xs foldEx b f a ex | otherwise = foldEx b f a ex @@ -738,20 +740,20 @@ mapEx b f x = do Let {env,ex,typ} | b = do syms <- mapSt findV env - let xs = [ sy | sy@SymV {expr=Just _} <- syms ] + let xs = [ sy | sy@(SymbolT.V SymV{expr=Just _}) <- syms ] foreach xs mapsub ex <- mapEx b f ex stio (Let {env,ex,typ}) | otherwise = do ex <- mapEx b f ex stio (Let {env,ex,typ}) - where mapsub (sy@SymV {expr=Just dx}) = do + where mapsub (SymbolT.V (sy@SymV {expr=Just dx})) = do x <- dx x <- mapEx b f x - changeSym sy.{expr=Just (return x)} + changeSym $ SymbolT.V sy.{expr=Just (return x)} mapsub sy = do g <- getST - E.fatal sy.pos (text ("mapEx: strange symbol in let def rhs: " + E.fatal (view SymbolT.pos sy) (text ("mapEx: strange symbol in let def rhs: " ++ sy.nice g)) Lam {pat,ex,typ} = do ex <- mapEx b f ex @@ -856,17 +858,17 @@ copyExpr mbp t x = mapEx false (copy t) x where --- copy a local symbol copySym mbp tree qname = do sym <- findV qname - case tree.lookupI (Symbol.sid sym) of + case sym of + SymbolT.V symt -> case tree.lookupI symt.sid of Just nuid -> do - mex <- maybeST sym.expr id + mex <- maybeST symt.expr id mbx <- maybeST mex (copyExpr mbp tree) - let name = sym.name.{uid=nuid} - npos = (fromMaybe sym.pos mbp).change VARID name.base - -- nsig = if sym.anno || isNothing sym.expr then sym.typ else pSigma - nsym = sym.{pos = npos, name, expr = fmap return mbx, sid = nuid} - enter nsym + let name = symt.name.{uid=nuid} + npos = (fromMaybe symt.pos mbp).change VARID name.base + nsym = symt.{pos = npos, name, expr = fmap return mbx, sid = nuid} + enter $ SymbolT.V nsym stio name - Nothing -> Prelude.error ("Can't find sid " ++ show sym.sid ++ " for name " ++ show sym.name) + Nothing -> Prelude.error ("Can't find sid " ++ show symt.sid ++ " for name " ++ show symt.name) maybeST (Just f) act = do @@ -885,8 +887,11 @@ untypeExpr x = mapEx true unty x where untySy qn = do sym <- findV qn - changeSym sym.{typ = if sym.anno then sym.typ else pSigma, - state = Unchecked} + case sym of + SymbolT.V symv -> + changeSym $ SymbolT.V + symv.{ typ = if symv.anno then symv.typ else pSigma + , state = Unchecked } unty (x@Ann{}) = return (Left x) -- keep type signatures intact unty (x@Lam{pat}) = do foreach (patNames pat) untySy @@ -913,8 +918,8 @@ ourGlobalFuns mtree ex = foldEx true collect empty ex where | otherwise = do sym <- findVD name case sym of - SymV{} -> stio (Left (acc `including` sym)) - sonst -> stio (Left acc) + SymbolT.V _ -> stio (Left (acc `including` sym)) + sonst -> stio (Left acc) collect acc (Mem {member}) | Just list <- TreeMap.lookupS mtree member.value = stio (Left (fold including acc list)) @@ -923,41 +928,41 @@ ourGlobalFuns mtree ex = foldEx true collect empty ex where symVD f g sym = case sym of - SymV{} -> f sym - SymD{} -> g sym - other -> Prelude.error (sym.name.base ++ " is neither SymV nor SymD") + SymbolT.V _ -> f sym + SymbolT.D _ -> g sym + other -> Prelude.error ((view SymbolT.name sym).base ++ " is neither SymV nor SymD") {-- * [usage] @fundep expr@ * [returns] a list of our 'QName's that are directly mentioned in _ex_ -} -fundep (SymV {name, expr=Just dx}) = do +fundep (SymbolT.V SymV{name, expr=Just dx}) = do g <- getST x <- dx deptree <- ourGlobalFuns empty x - let dep = [ Symbol.name sy | sy <- keys deptree, g.our sy.name ] + let dep = [ name | sy <- keys deptree, let name = view SymbolT.name sy, g.our name ] stio (name, dep) -fundep (SymV {name, expr=Nothing}) = stio (name, []) +fundep (SymbolT.V SymV{name, expr=Nothing}) = stio (name, []) fundep other = do g <- getST - E.fatal other.pos (text("fundep: strange symbol: " ++ other.nice g)) + E.fatal (view SymbolT.pos other) (text("fundep: strange symbol: " ++ other.nice g)) --- find all our 'SymV' symbols allourvars :: Global -> [Symbol] allourvars g = - let collectedenvs = g.thisTab : [ Symbol.env sy | sy <- values g.thisTab, Symbol.{env?} sy ] - in [ v | env <- collectedenvs, v@SymV {name} <- values env, g.our name] + let collectedenvs = g.thisTab : mapMaybe (preview SymbolT.env) (values g.thisTab) + in [ v | env <- collectedenvs, v@(SymbolT.V SymV{name}) <- values env, g.our name] --- find all 'SymV' symbols, be they ours or not allvars = do g <- getST - let envEnvs env = env : [Symbol.env sy | sy <- values env, Symbol.{env?} sy] + let envEnvs env = env : mapMaybe (preview SymbolT.env) (values g.thisTab) packEnvs = values g.packages collectedenvs = fold (++) [] (map envEnvs packEnvs) - collectedvars = [ v | env::Symtab <- collectedenvs, v@SymV {name} <- values env] + collectedvars = [ v | env::Symtab <- collectedenvs, v@(SymbolT.V _) <- values env] stio collectedvars @@ -1019,7 +1024,8 @@ returnTypeN n rho = Prelude.error "returnTypeN: too many arguments" --- tell if a given type is a java type isJavaType (TCon {name}) = do sym <- findT name - stio (isJust sym.nativ) + case sym of + SymbolT.T symt -> stio (isJust symt.nativ) isJavaType (tapp@TApp _ _) = isJavaType (head tapp.flat) isJavaType (Meta tv) | tv.isFlexi = do g <- getST @@ -1029,7 +1035,7 @@ isJavaType _ = stio false {-- Arity of a 'Symbol' based on its type -} -arity sym = case returnType (Symbol.typ sym).rho of +arity sym = case returnType (unsafePartialView SymbolT.typ sym).rho of (_, xs) -> length xs @@ -1076,10 +1082,10 @@ isThrowable g ty = case instTauSym ty g of If @sym@ is a class member, return the class it belongs to, otherwise 'Nothing'. -} -isClassMember SymV{name} g +isClassMember (SymbolT.V SymV{name}) g | MName{tynm} <- name, found <- Global.findit g tynm, - Just SymC{} <- found = found + Just (SymbolT.C _) <- found = found isClassMember _ _ = Nothing diff --git a/frege/compiler/classes/Nice.fr b/frege/compiler/classes/Nice.fr index a87a378c..03c1de27 100644 --- a/frege/compiler/classes/Nice.fr +++ b/frege/compiler/classes/Nice.fr @@ -44,6 +44,7 @@ package frege.compiler.classes.Nice import Data.TreeMap as TM(TreeMap, each) import Lib.PP(DOCUMENT,text) +import frege.compiler.common.Lens (view) import frege.compiler.types.NSNames import frege.compiler.types.SNames import frege.compiler.types.Packs @@ -91,26 +92,26 @@ instance Nice SName where instance Nice Symbol where - nice (sym@SymL {alias}) g = category sym g ++ " `" ++ alias.nice g ++ "`" - nice sym g = category sym g ++ " `" ++ sym.name.nice g ++ "`" - nicer (sym@SymL {alias}) g = category sym g ++ " `" ++ alias.nicer g ++ "`" - nicer sym g = category sym g ++ " `" ++ sym.name.nicer g ++ "`" + nice (sym@(SymbolT.L SymL{alias})) g = category sym g ++ " `" ++ alias.nice g ++ "`" + nice sym g = category sym g ++ " `" ++ (view SymbolT.name sym).nice g ++ "`" + nicer (sym@(SymbolT.L SymL{alias})) g = category sym g ++ " `" ++ alias.nicer g ++ "`" + nicer sym g = category sym g ++ " `" ++ (view SymbolT.name sym).nicer g ++ "`" -protected category (SymbolT.T _) g = "data type" -protected category (SymD {name}) g = "constructor" -protected category (SymC {name}) g = "class" -protected category (SymI {name}) g = "instance" -protected category (symv@SymV {name,nativ, expr}) g = if isJust nativ then "native " ++ fun else fun +protected category (SymbolT.T _) _ = "data type" +protected category (SymbolT.D _) _ = "constructor" +protected category (SymbolT.C _) _ = "class" +protected category (SymbolT.I _) _ = "instance" +protected category (SymbolT.V SymV{name, nativ, typ}) g = if isJust nativ then "native " ++ fun else fun where fun | MName t b <- name, Just sym <- Global.find g t = category sym g ++ " member " ++ funval | MName _ _ <- name = "member " ++ funval | otherwise = funval funval | isJust nativ = "function" - | ForAll _ RhoFun{} <- symv.typ = "function" + | ForAll _ RhoFun{} <- typ = "function" | otherwise = "value" -protected category (SymA {name}) g = "type alias" -protected category (SymL {alias}) g = case g.find alias of +protected category (SymbolT.A _) _ = "type alias" +protected category (SymbolT.L SymL{alias}) g = case g.find alias of Just sym -> "alias for " ++ category sym g Nothing -> "alias" diff --git a/frege/compiler/common/ImpExp.fr b/frege/compiler/common/ImpExp.fr index 1e3ecebe..3034fab0 100644 --- a/frege/compiler/common/ImpExp.fr +++ b/frege/compiler/common/ImpExp.fr @@ -34,6 +34,8 @@ module frege.compiler.common.ImpExp inline (maybeQN, ctContext, ctTau, ctSigma) where +import frege.compiler.common.Lens (view) + import Compiler.types.External as E import Compiler.Classtools as CT() import Compiler.types.Expression @@ -43,6 +45,7 @@ import Compiler.types.Positions import Compiler.types.QNames import Compiler.types.Packs import Compiler.types.Global +import Compiler.types.Symbols (SymbolT) import Compiler.enums.SymState import Compiler.types.Strictness import Compiler.Utilities as U() @@ -212,23 +215,26 @@ exprFromA sarray earray exa = case exa.xkind of triples xs = error "list size must be multiple of 3" mklet triples body = do syms ← mapSt letbound triples - syms `foreach` - \sym → changeSym sym.{ - expr ← fmap (>>= U.mapEx true (U.replaceLocals syms))} + syms `foreach` + \sym -> case sym of + SymbolT.V symv -> + changeSym $ SymbolT.V symv.{expr <- fmap (>>= U.mapEx true (U.replaceLocals syms))} ex ← xref body >>= U.mapEx true (U.replaceLocals syms) - return Let{env=map Symbol.name syms, ex, typ=Nothing} + return Let{env=map (view SymbolT.name) syms, ex, typ=Nothing} letbound (varix, sigix, rhsix) = do pat ← pref varix >>= U.pReturn let pvar = patVars pat case pvar of [p@PVar{}] → do sym ← U.mkLocal p - let bound = sym.{expr = Just (xref rhsix), - typ = if sigix >= 0 - then nSigma sigix - else pSigma} - changeSym bound - return bound + case sym of + SymbolT.V symv -> do + let bound = symv.{expr = Just (xref rhsix), + typ = if sigix >= 0 + then nSigma sigix + else pSigma} + changeSym $ SymbolT.V bound + return $ SymbolT.V bound _ -> do g <- getST Err.fatal (getpos pat) ( @@ -238,7 +244,9 @@ exprFromA sarray earray exa = case exa.xkind of mkStrictPVars PUser{pat,lazy} | PVar{pos,uid,var} <- pat = do sym <- U.findV (Local {base=var, uid}) - changeSym sym.{state=StrictChecked, strsig=if lazy then U else S[]} + case sym of + SymbolT.V symv -> + changeSym $ SymbolT.V symv.{state=StrictChecked, strsig=if lazy then U else S[]} | otherwise = mkStrictPVars pat mkStrictPVars PAnn{pat} = mkStrictPVars pat mkStrictPVars PAt{pat} = mkStrictPVars pat diff --git a/frege/compiler/common/JavaName.fr b/frege/compiler/common/JavaName.fr index e84ac2d0..cf3c4ee9 100644 --- a/frege/compiler/common/JavaName.fr +++ b/frege/compiler/common/JavaName.fr @@ -30,31 +30,32 @@ javaName g qname = case g.findit qname of For 'SymV', it is guaranteed that the name is of the form (JName pack base) -} -symJavaName g SymV{name=Local uid s} = JName "" (mangled s ++ "$" ++ show uid) +symJavaName g (SymbolT.V SymV{name=Local uid s}) = JName "" (mangled s ++ "$" ++ show uid) symJavaName g sym = case sym of - SymbolT.T (SymT{name}) -> t "T" name - SymD {name = MName tname base} -> case g.findit tname of + SymbolT.T SymT{name} -> t "T" name + SymbolT.D SymD{name = MName tname base} -> case g.findit tname of Just (SymbolT.T SymT{product,enum}) -> if enum then memberOf (t "T" tname) (mangled base) else if product then t "T" tname else memberOf (t "T" tname) ("D" ++ mangled base) fail -> Prelude.error "javaName: tname is no SymT" - SymC {name} -> t "C" name - SymI {name} -> t "I" name - SymV {name = MName tname base} = case g.findit tname of + SymbolT.C SymC{name} -> t "C" name + SymbolT.I SymI{name} -> t "I" name + SymbolT.V SymV{name = name@(MName tname base)} = case g.findit tname of Just (SymbolT.T SymT{product=false,enum=false,newt=false,nativ=Nothing}) = memberOf tjname mbase - Just (SymC {sid}) = memberOf (memberOf tjname "I") mbase + Just (SymbolT.C SymC{sid}) + = memberOf (memberOf tjname "I") mbase other = memberOf tjname mbase where tjname = javaName g tname - mbase = mangled sym.name.base - SymV {name = VName pname base} + mbase = mangled name.base + SymbolT.V SymV{name = name@(VName pname base)} | pname == g.thisPack = JName jpack.base vbase | hasJavaImport pname g = JName jpack.base vbase | otherwise = memberOf jpack vbase where - vbase = mangled sym.name.base + vbase = mangled name.base jpack = g.packClass pname other -> Prelude.error ("javaName: strange symbol " ++ nice sym g) where diff --git a/frege/compiler/common/Lens.fr b/frege/compiler/common/Lens.fr new file mode 100644 index 00000000..a46aeac9 --- /dev/null +++ b/frege/compiler/common/Lens.fr @@ -0,0 +1,46 @@ +module frege.compiler.common.Lens where + +import frege.data.Monoid (First) +import frege.data.wrapper.Const (Const) +import frege.data.wrapper.Identity (Identity) + +-- note: currently the compiler fails to infer the correct kinds of @f@ +-- when incrementally compiling, so you have to write type annotations without the aliases + +type ASetter s t a b = (a -> Identity b) -> s -> Identity t +type ASetter' s a = ASetter s s a a +type Getting r s a = (a -> Const r a) -> s -> Const r s +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t +type Lens' s a = Lens s s a a +type LensLike f s t a b = (a -> f b) -> s -> f t +type LensLike' f s a = LensLike f s s a a +type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t +type Traversal' s a = Traversal s s a a + +-- getters + +-- dealing with Lenses + +view :: Getting a s a -> (s -> a) +view l = Const.get . (l Const) + +views :: Getting r s a -> (a -> r) -> (s -> r) +views l f = Const.get . l (Const . f) + +-- dealing with optional fields (Traversals) + +preview :: Getting (First a) s a -> s -> Maybe a +preview l s = First.getFirst $ views l (First . Just) s + +-- setters + +over :: ASetter s t a b -> (a -> b) -> s -> t +over l f = Identity.run . l (Identity . f) + +set :: ASetter s t a b -> b -> s -> t +set l b = Identity.run . l (\_ -> Identity b) + +--- warning: this function is partial +-- TODO eliminate the uses of these functions +unsafePartialView :: Getting (First a) s a -> s -> a +unsafePartialView l s = unJust $ preview l s diff --git a/frege/compiler/common/PatternCompiler.fr b/frege/compiler/common/PatternCompiler.fr index ba85a913..692829d0 100644 --- a/frege/compiler/common/PatternCompiler.fr +++ b/frege/compiler/common/PatternCompiler.fr @@ -24,6 +24,8 @@ module frege.compiler.common.PatternCompiler where import frege.Prelude hiding (<+>) +import frege.compiler.common.Lens (view) + import Compiler.enums.Flags(TRACE7, STRICTLRPATS) import Compiler.enums.CaseKind import Compiler.enums.Literals @@ -48,14 +50,14 @@ import Compiler.Utilities as U(freshVar) -ccSym (vsym@SymV {pos}) +ccSym (SymbolT.V (vsym@SymV {pos})) | Just x ← vsym.expr = do nx ← x >>= ccExpr - changeSym vsym.{expr = Just (return nx)} + changeSym $ SymbolT.V vsym.{expr = Just (return nx)} | otherwise = pure () ccSym sym = do g <- getST - E.fatal sym.pos (text ("ccSym no SymV : " ++ sym.nice g)) + E.fatal (view SymbolT.pos sym) (text ("ccSym no SymV : " ++ sym.nice g)) diff --git a/frege/compiler/common/Resolve.fr b/frege/compiler/common/Resolve.fr index 035a2c31..1735f8ce 100644 --- a/frege/compiler/common/Resolve.fr +++ b/frege/compiler/common/Resolve.fr @@ -6,6 +6,7 @@ import frege.Prelude hiding(break, <+>) import frege.data.TreeMap as TM(TreeMap, lookup, each, insert, union, including, contains, keys, values, fromKeys) import frege.data.List as DL(partitioned, sortBy, minimumBy) import frege.lib.PP(break, fill, text, nest, msgdoc, <+>, <>, DOCUMENT) +import frege.compiler.common.Lens (preview, set, unsafePartialView, view) import frege.compiler.enums.Flags import frege.compiler.enums.Visibility import frege.compiler.types.Positions @@ -33,12 +34,12 @@ canonical g qname = case Global.findit g qname of -- access is forbidden to global private symbols from a different package -accessforbidden we sym - | Local {} <- Symbol.name sym = false - | VName p _ <- Symbol.name sym = sym.vis == Private && p != we - | TName p _ <- Symbol.name sym = sym.vis == Private && p != we - | MName (TName p _) _ <- Symbol.name sym = sym.vis == Private && p != we - | otherwise = Prelude.error ("Strange symbol") +accessforbidden we sym = case view SymbolT.name sym of + Local {} -> false + VName p _ -> view SymbolT.vis sym == Private && p != we + TName p _ -> view SymbolT.vis sym == Private && p != we + MName (TName p _) _ -> view SymbolT.vis sym == Private && p != we + _ -> Prelude.error ("Strange symbol") protected resolve :: (String -> QName) -> Position -> SName -> StG [QName] @@ -58,18 +59,18 @@ protected resolve fname pos sname = do foreach ss docWarningSym foreach ss (traceSym sname) foreach ss registerNS - stio (map Symbol.name ss) -- some public ones found + stio (map (view SymbolT.name) ss) -- some public ones found where - registerNS sym = weUse sym.name + registerNS sym = weUse (view SymbolT.name sym) docWarningSym :: Symbol -> StG () docWarningSym sym = do g <- getST - docWarning pos (sym.name.nicer g) sym.doc + docWarning pos ((view SymbolT.name sym).nicer g) (unsafePartialView SymbolT.doc sym) traceSym :: SName -> Symbol -> StG () traceSym sname symbol = do E.logmsg TRACE5 pos (text (show sname ++ " resolved to " ++ nice symbol g ++ " (" - ++ QName.show symbol.name ++ ", " ++ show symbol.vis ++ ")")) + ++ QName.show (view SymbolT.name symbol) ++ ", " ++ show (view SymbolT.vis symbol) ++ ")")) {-- Note in the state that we need the import that is associated @@ -123,13 +124,15 @@ private resolve3 fname pos (Simple Token{value=qs}) = do rs -> stio rs where scope g (MName t _) | Just sym <- g.findit t - = scopefrom [sym.env, g.thisTab] + = scopefrom [unsafePartialView SymbolT.env sym, g.thisTab] scope g _ = scopefrom [g.thisTab] scopefrom envs = fold more [] envs where more :: [String] -> Symtab -> [String] - more acc env = foldr (:) acc [ v.name.base | v <- values env, - not (v::Symbol).{clas?} ] + more acc env = foldr (:) acc [ (view SymbolT.name v).base | v <- values env, + not (isSymI v) ] + isSymI (SymbolT.I _) = true + isSymI _ = false -- T.v T.C N.v N.C N.T private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do g <- getST @@ -137,7 +140,7 @@ private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do let tname = TName g.thisPack n mname = MName tname v -- T.v or T.C member = g.findit mname - mlist = map (canonical g • Symbol.name) member.toList -- [MName _ _ ] or [] + mlist = map (canonical g . view SymbolT.name) member.toList -- [MName _ _ ] or [] mbtsym = g.findit tname msts | Just sym <- mbtsym = ms sym | otherwise = [] @@ -160,7 +163,7 @@ private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do case mbtsym of -- re-register qualifier as type name Just sym -> changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk snm.ty) (Right sym.name)}} + idKind <- insert (KeyTk snm.ty) (Right $ view SymbolT.name sym)}} sonst -> return () stio mlist (Just s, Nothing) -> do @@ -179,8 +182,8 @@ private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do Just sym -> do -- register qualifier as type name changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk snm.ty) (Right sym.name)}} - weUse sym.name + idKind <- insert (KeyTk snm.ty) (Right $ view SymbolT.name sym)}} + weUse $ view SymbolT.name sym case member of Just mem -> stio [mem] Nothing -> do @@ -191,12 +194,12 @@ private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do -- all known type and namespace names tsns :: Global -> [String] tsns g = [ n | NSX n <- keys g.namespaces ] - ++ [ s.name.base | (s::Symbol) <- values g.thisTab, isTName s.name] + ++ [ (view SymbolT.name s).base | (s::Symbol) <- values g.thisTab, isTName (view SymbolT.name s)] ms :: Symbol -> [String] - ms s | s.{env?} = map (QName.base • Symbol.name) (values s.env) + ms s | Just env <- preview SymbolT.env s = map (QName.base . view SymbolT.name) (values env) | otherwise = [] es :: Symtab -> [String] - es e = map (QName.base • Symbol.name) (values e) + es e = map (QName.base . view SymbolT.name) (values e) private resolve3 _ pos (snm@With2 Token{value=n} Token{value=t} Token{value=qm}) = do g <- getST @@ -217,8 +220,8 @@ private resolve3 _ pos (snm@With2 Token{value=n} Token{value=t} Token{value=qm}) Just sym -> do -- register 2nd qualifier as type name changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk snm.ty) (Right sym.name)}} - weUse sym.name + idKind <- insert (KeyTk snm.ty) (Right $ view SymbolT.name sym)}} + weUse $ view SymbolT.name sym let mname = MName tname m case g.findit mname of Nothing -> do @@ -238,13 +241,10 @@ private resolve3 _ pos (snm@With2 Token{value=n} Token{value=t} Token{value=qm}) ns :: Global -> [String] ns g = [ n | NSX n <- keys g.namespaces ] ms :: Symbol -> [String] - ms s | s.{env?} = map (QName.base • Symbol.name) (values s.env) + ms s | Just env <- preview SymbolT.env s = map (QName.base . view SymbolT.name) (values env) | otherwise = [] - -- es :: Symtab -> [String] - -- es e = map (QName.base • Symbol.name) (values e) - -- all type names from a given package ts :: Symtab -> [String] - ts e = [ x | TName _ x <- map Symbol.name (values e) ] + ts e = [ x | TName _ x <- map (view SymbolT.name) (values e) ] resolveVName fname pos name = do @@ -258,11 +258,11 @@ resolveVName fname pos name = do -- but only if it is linked from the global level. | Simple{} <- name, -- simple name was resolved MName iname op <- x, -- found member name - Just (SymI{}) <- g.findit iname, -- of an instance + Just (SymbolT.I _) <- g.findit iname, -- of an instance -- same is known globally - Just (SymV{name=cop}) <- g.findit (VName g.thisPack op), + Just (SymbolT.V SymV{name=cop}) <- g.findit (VName g.thisPack op), MName cname _ <- cop, -- and is linked to a member - Just (SymC{}) <- g.findit cname = do -- of a type class + Just (SymbolT.C _) <- g.findit cname = do -- of a type class -- register id changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk name.id) (Right cop)}} @@ -332,9 +332,9 @@ checkXName pos sym name = do g <- getST case g.findit name of Nothing -> stio Nothing -- error should have come from resolve - Just it | constructor sym == constructor it = stio (Just it.name) + Just it | constructor sym == constructor it = stio (Just $ view SymbolT.name it) | otherwise = do - E.error pos (fill ([text "expected", text ((Symbol.{name=name} sym).nice g) <> text ","] + E.error pos (fill ([text "expected", text ((set SymbolT.name name sym).nice g) <> text ","] ++ break "but found " ++ [text (it.nice g)])) stio Nothing diff --git a/frege/compiler/common/SymbolTable.fr b/frege/compiler/common/SymbolTable.fr index 00d03b53..560959c9 100644 --- a/frege/compiler/common/SymbolTable.fr +++ b/frege/compiler/common/SymbolTable.fr @@ -5,6 +5,7 @@ module frege.compiler.common.SymbolTable where import frege.Prelude hiding(error, print, println, break, <+>) import frege.data.TreeMap as TM(TreeMap, lookup, each, insert, union, including, contains, keys, values, fromKeys) import frege.lib.PP(fill, break, pretty, text, nest, msgdoc, <+>, <>, DOCUMENT) +import frege.compiler.common.Lens (preview, set, view) import frege.compiler.enums.Flags import frege.compiler.enums.SymState import frege.compiler.enums.Visibility @@ -33,7 +34,7 @@ private enterWith insupd p n s = do changeST Global.{packages <- insert p ntab} Nothing -> do let sp = g.unpack p - E.error (Symbol.pos s) (fill ([text "module", text "`" <> text sp <> text "`"] + E.error (view SymbolT.pos s) (fill ([text "module", text "`" <> text sp <> text "`"] ++ break "does not exist.")) @@ -46,11 +47,11 @@ private insertSym tab key value = case tab.lookupS key of let on = Symbol.nice old g qn = Symbol.nice value g case value of - SymV {pos} -> E.error pos (msgdoc("duplicate function or pattern binding for `" - ++ value.name.nice g ++ "`, already bound on line " - ++ show old.pos)) - _ -> E.error value.pos (msgdoc("redefinition of " ++ on ++ " with " ++ qn - ++ " introduced on line " ++ show old.pos)) + SymbolT.V SymV{pos, name} -> E.error pos (msgdoc("duplicate function or pattern binding for `" + ++ name.nice g ++ "`, already bound on line " + ++ show (view SymbolT.pos old))) + _ -> E.error (view SymbolT.pos value) (msgdoc("redefinition of " ++ on ++ " with " ++ qn + ++ " introduced on line " ++ show (view SymbolT.pos old))) stio (tab.insertS key value) @@ -61,7 +62,7 @@ private updateSym tab key value = case tab.lookupS key of Nothing -> do g <- getST let qn = Symbol.nice value g - E.error value.pos (fill (break ("cannot update " ++ qn ++ " " ++ show (keys tab)))) + E.error (view SymbolT.pos value) (fill (break ("cannot update " ++ qn ++ " " ++ show (keys tab)))) stio (tab.insert key value) @@ -77,41 +78,45 @@ private updateSym tab key value = case tab.lookupS key of - an annotation finds that a non native variable is already there -} enter :: Symbol -> StG () -enter sym - | sym.{alias?} = do - g <- getST - let asy = g.find sym.alias - case asy of - Nothing | g.our sym.alias -> do - let sa = sym.nicer g - -- st = sym.alias.nice g - E.fatal sym.pos (fill (break ("can't enter " ++ sa ++ " for unknown target"))) - sonst -> enterOrUpdate - | otherwise = enterOrUpdate +enter sym = case sym of + SymbolT.L syml -> do + g <- getST + let asy = g.find syml.alias + case asy of + Nothing | g.our syml.alias -> do + let sa = sym.nicer g + E.fatal syml.pos (fill (break ("can't enter " ++ sa ++ " for unknown target"))) + sonst -> enterOrUpdate + _ -> enterOrUpdate where - enterOrUpdate - | Local{uid} <- sym.name = do + enterOrUpdate = + let name = view SymbolT.name sym + in + case name of + Local{uid} -> do g <- getST uid <- if uid > 0 then return uid else uniqid - case g.find sym.name of + case g.find name of Nothing - | uid == sym.sid -> do - E.logmsg TRACE3 sym.pos (text("enterLocal: " ++ - show sym.sid ++ - " " ++ sym.nice g ++ " :: " ++ sym.typ.nice g ++ - ", " ++ show sym.state)) + | uid == view SymbolT.sid sym -> do + E.logmsg TRACE3 (view SymbolT.pos sym) (text("enterLocal: " ++ + case sym of + SymbolT.V symv -> + show symv.sid ++ + " " ++ sym.nice g ++ " :: " ++ symv.typ.nice g ++ + ", " ++ show symv.state)) changeST Global.{locals <- TreeMap.insertkvI uid sym} - | otherwise = E.fatal sym.pos (text ("enterLocal: uid=" ++ - show uid ++ ", sid=" ++ show sym.sid ++ " for " ++ show sym.name)) - Just that -> E.error sym.pos (text ("already entered: " ++ nice sym g ++ " with uid " ++ show uid)) - | otherwise = do + | otherwise = E.fatal (view SymbolT.pos sym) (text ("enterLocal: uid=" ++ + show uid ++ ", sid=" ++ show (view SymbolT.sid sym) ++ " for " ++ show name)) + Just that -> E.error (view SymbolT.pos sym) (text ("already entered: " ++ nice sym g ++ " with uid " ++ show uid)) + _ -> do g <- getST - case g.find sym.name of + case g.find name of Nothing -> enterByName sym Just that - | SymL{} <- that, SymL{} <- sym, that.alias == sym.alias = pure () -- do nothing - | SymL {alias} <- that, alias.getpack != sym.name.getpack = do - E.warn sym.pos (fill (break("hiding previously (line " ++ show that.pos + | SymbolT.L SymL{alias=thatAlias} <- that, SymbolT.L SymL{alias=symAlias} <- sym, thatAlias == symAlias = pure () -- do nothing + | SymbolT.L SymL{alias} <- that, alias.getpack != name.getpack = do + E.warn (view SymbolT.pos sym) (fill (break("hiding previously (line " ++ show (view SymbolT.pos that) ++ ") imported " ++ that.nice g ++ " through " ++ sym.nice g))) changeSym sym @@ -119,76 +124,78 @@ enter sym changeSym :: Symbol -> StG () -changeSym sym | sym.sid == 0 = do +changeSym sym | view SymbolT.sid sym == 0 = do u <- uniqid - changeSym sym.{sid=u} + changeSym $ set SymbolT.sid u sym changeSym sym = do g <- getST - E.logmsg TRACE3 sym.pos (fill [text "changeSym", lit sym.sid, text (sym.nice g ++ " :: " ++ - (if sym.{typ?} then sym.typ.nice g else "") ++ ", " ++ - (if sym.{state?} then show sym.state else ""))]) - case sym.name of - TName p b -> updateGlobal p sym.name.key sym - VName p b -> updateGlobal p sym.name.key sym + E.logmsg TRACE3 (view SymbolT.pos sym) (fill [text "changeSym", lit (view SymbolT.sid sym), text (sym.nice g ++ " :: " ++ + (maybe "" (\typ -> typ.nice g) $ preview SymbolT.typ sym) ++ ", " ++ + (case sym of { SymbolT.V SymV{state} -> show state; _ -> "" }))]) + let name = view SymbolT.name sym + case name of + TName p b -> updateGlobal p name.key sym + VName p b -> updateGlobal p name.key sym MName t b -> do g <- getST let tsy = g.findit t case tsy of Nothing -> do let qn = t.nice g - E.error sym.pos (fill ([text "namespace", text "`" <> text qn <> text "`"] ++ break "does not exist")) - Just typ | typ.{env?} = do - env <- updateSym typ.env sym.name.key sym - updateGlobal t.pack t.key typ.{env} - | otherwise = E.fatal sym.pos (text "no environment:" <+> text (t.nice g)) + E.error (view SymbolT.pos sym) (fill ([text "namespace", text "`" <> text qn <> text "`"] ++ break "does not exist")) + Just typ -> case preview SymbolT.env typ of + Just typEnv -> do + env <- updateSym typEnv name.key sym + updateGlobal t.pack t.key (set SymbolT.env env typ) + Nothing -> E.fatal (view SymbolT.pos sym) (text "no environment:" <+> text (t.nice g)) Local uid s -> do -- g <- getST - when (sym.sid != uid) do - E.fatal sym.pos (text("changeSym: name =" ++ show sym.name - ++ ", sid=" ++ show sym.sid)) + when (view SymbolT.sid sym != uid) do + E.fatal (view SymbolT.pos sym) (text("changeSym: name =" ++ show name + ++ ", sid=" ++ show (view SymbolT.sid sym))) changeST Global.{locals <- TreeMap.updatekvI uid sym} private enterByName :: Symbol -> StG () -private enterByName sym | sym.sid == 0 = do +private enterByName sym | view SymbolT.sid sym == 0 = do u <- uniqid - enterByName sym.{sid=u} + enterByName $ set SymbolT.sid u sym private enterByName sym = do g <- getST - E.logmsg TRACE3 sym.pos (fill (break ("enterByName " ++ sym.nice g ++ " " ++ show sym.sid ++ " " - ++ (if sym.{expr?} && not (isPSigma sym.typ) - then " :: " ++ sym.typ.nicer g else "")))) - case sym.name of - TName p b -> insertGlobal p sym.name.key sym - VName p b -> insertGlobal p sym.name.key sym + E.logmsg TRACE3 (view SymbolT.pos sym) (fill (break ("enterByName " ++ sym.nice g ++ " " ++ show (view SymbolT.sid sym) ++ " " + ++ (case sym of + SymbolT.V symv | not (isPSigma symv.typ) -> " :: " ++ symv.typ.nicer g + _ -> "")))) + let name = view SymbolT.name sym + pos = view SymbolT.pos sym + case name of + TName p b -> insertGlobal p name.key sym + VName p b -> insertGlobal p name.key sym MName t b -> do g <- getST let tsy = g.findit t case tsy of Nothing -> do let qn = t.nice g - E.error sym.pos (msgdoc("namespace `" ++ qn ++ "` does not exist")) - Just typ | typ.{env?} = do - env <- insertSym typ.env sym.name.key sym - updateGlobal t.pack (t.key) typ.{env} - | otherwise = E.fatal sym.pos (msgdoc ("no environment: " ++ t.nice g)) + E.error pos (msgdoc("namespace `" ++ qn ++ "` does not exist")) + Just typ -> case preview SymbolT.env typ of + Just typEnv -> do + env <- insertSym typEnv name.key sym + updateGlobal t.pack t.key (set SymbolT.env env typ) + Nothing -> E.fatal pos (msgdoc ("no environment: " ++ t.nice g)) Local {} -> do g <- getST - E.fatal sym.pos (text ("local passed to enterbyname " ++ nice sym g)) + E.fatal pos (text ("local passed to enterbyname " ++ nice sym g)) {-- create a symbolic link to given qname -} linkq :: QName -> Symbol -> StG () -linkq from sym = linkqv from sym sym.vis +linkq from sym = linkqv from sym (view SymbolT.vis sym) --- create a symbolic link to a given 'Symbol' with a given 'Visibility' linkqv :: QName -> Symbol -> Visibility -> StG () -linkqv from sym vis = do - g <- getST - E.logmsg TRACE3 sym.pos (text ("`" ++ from.nice g ++ "` link to " ++ sym.nice g)) - enter (SymL {sid=0, pos=sym.pos, vis, -- doc=Nothing, - name=from, alias=sym.name}) +linkqv from sym vis = linkqvp from sym vis (view SymbolT.pos sym) -- create a symbolic link to a given 'Symbol' with a given 'Visibility' and 'Position' @@ -196,6 +203,7 @@ linkqvp :: QName -> Symbol -> Visibility -> Position -> StG () linkqvp from sym vis pos = do g <- getST E.logmsg TRACE3 pos (text ("`" ++ from.nice g ++ "` link to " ++ sym.nice g)) - enter (SymL {sid=0, pos=pos, vis, -- doc=Nothing, - name=from, alias=sym.name}) + enter $ SymbolT.L + (SymL {sid=0, pos=pos, vis, -- doc=Nothing, + name=from, alias=view SymbolT.name sym}) diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index 37d19918..47c6919c 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -6,6 +6,8 @@ import Data.TreeMap as TM(TreeMap, TreeSet, lookup, insert, keys, values, eac import Data.List (partitioned) import Lib.PP(text, msgdoc, <+>, text) +import frege.compiler.common.Lens (unsafePartialView, view) + import Compiler.enums.TokenID(VARID) import Compiler.enums.SymState(Typechecked) import Compiler.enums.CaseKind(CWhen) @@ -44,7 +46,7 @@ references sids x = U.foldEx true refs 0 x -- g <- getST -- E.logmsg TRACE7 pos ("references " ++ show n ++ " " ++ show sids ++ " " ++ nice name g) sym <- U.findVD name - if sym.sid `elem` sids then stio (Right (n+1)) else stio (Left n) + if view SymbolT.sid sym `elem` sids then stio (Right (n+1)) else stio (Left n) refs n (Ifte c t e _) = do crefs <- references sids c trefs <- references sids t @@ -59,7 +61,7 @@ references sids x = U.foldEx true refs 0 x stio (Right (n + lrefs)) refs n (Let {env,ex}) = do syms <- mapSt U.findV env - srefs <-sequence [ subex | SymV{expr = Just subex} <- syms ] >>= mapSt (references sids) + srefs <-sequence [ subex | SymbolT.V SymV{expr = Just subex} <- syms ] >>= mapSt (references sids) lrefs <- references sids ex stio (Right (n + 2*sum srefs + lrefs)) refs n x = do @@ -97,7 +99,8 @@ isEasy :: Global -> Expr -> Bool isEasy g (App a b _) = isSimple g a && isSimple g b isEasy g (Let {env,ex}) = isEasy g ex && all (isEasy g) xprs where - xprs = [ ex | q <- env, sym <- g.findit q, ex <- sym.gExpr g] + xprs = [ ex | q <- env, sym <- g.findit q, ex <- (unsafeToSymV sym).gExpr g] + unsafeToSymV s = case s of { SymbolT.V x -> x; } isEasy g (Case {ex,alts}) = isSimple g ex && all (isEasy g • _.ex) alts isEasy g (Ifte a b c _) = isSimple g a && isEasy g b && isEasy g c @@ -111,7 +114,7 @@ replSid sid r ex = U.mapEx true action ex where action (v@Vbl {name=Local {}}) = do sym <- U.findVD v.name - if sym.sid == sid then stio (Right r) else stio (Right v) + if view SymbolT.sid sym == sid then stio (Right r) else stio (Right v) action x = stio (Left x) @@ -120,7 +123,7 @@ replName sid nm ex = U.mapEx true action ex where action (v@Vbl {name,pos}) = do sym <- U.findVD name - if sym.sid == sid then do + if view SymbolT.sid sym == sid then do changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk pos.first) (Right nm)}} stio (Right v.{name=nm}) @@ -159,10 +162,12 @@ patternRefutable g p = case p of * A pattern is _refutable_ if the match can possibly fail. Variables and product constructor * applications that contain only irrefutable patterns are irrefutable. -} +patternStrictness :: Pattern -> StG Strictness patternStrictness p = case p of PVar {uid,var} -> do g ← getST - v <- U.findV (Local uid var) + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + v <- unsafeToSymV <$> U.findV (Local uid var) E.logmsg TRACES (getpos p) ( text "patternStrictness: " <+> text (nicer p g) @@ -184,8 +189,9 @@ patternStrictness p = case p of ps <- patternStrictness pat if lazy then case pat of PVar{uid, var} -> do - v <- U.findV (Local uid var) - when v.strsig.isStrict do changeSym v.{strsig = U} + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + v <- unsafeToSymV <$> U.findV (Local uid var) + when v.strsig.isStrict do changeSym $ SymbolT.V v.{strsig = U} pure U other → pure U else if ps == U then stio (S[]) else stio ps @@ -278,7 +284,7 @@ patsComplete g ps else missingLiteral ps missing (ps@(PLit {pos}:_)) = missingLiteral ps missing (ps@(PCon {qname}:_)) - | s:_ <- filter (not • (`elem` pnames) • Symbol.name) (cons qname) = Just (mkCon s) + | s:_ <- filter (not . (`elem` pnames) . view SymbolT.name) (cons qname) = Just (mkCon s) | otherwise = case (filter isJust • map groupcheck) (group ps) of some:_ -> some [] -> Nothing @@ -288,7 +294,7 @@ patsComplete g ps Just (SymbolT.T (SymT {env})) -> U.envConstructors env _ -> [] cons _ = [] - mkCon (SymD {name,flds}) = PCon {pos=Position.null, qname=name, + mkCon (SymbolT.D SymD{name,flds}) = PCon {pos=Position.null, qname=name, pats = map (const pany) flds} mkCon _ = error "mkCon: no constructor" group :: [Pattern] -> [(QName, [[Pattern]])] @@ -327,8 +333,10 @@ patsComplete g ps constructors (lit@PLit {kind=LBool}) = [ lit.{value=s} | s <- ["true", "false"] ] constructors (con@PCon {qname=MName tname _}) = case g.findit tname of Just (SymbolT.T (SymT {env})) -> + let unsafeToSymD s = case s of { SymbolT.D x -> x; } + in [ PCon con.pos sym.name (take (length sym.flds) dummies) | - (sym::Symbol) <- U.envConstructors env ] where + sym <- unsafeToSymD <$> U.envConstructors env ] where dummies = repeat (PVar con.pos 0 "_") _ -> [] constructors _ = [] @@ -376,11 +384,11 @@ classMethodOfInstMethod :: Position -> QName -> String -> StG Symbol classMethodOfInstMethod pos inst base = do g <- getST case g.findit inst of - Just isym | SymI{clas} <- isym = case g.findit clas of - Just csym | SymC{supers} <- csym = do - let sym = head [ sym | c <- clas:supers, SymC{env} <- g.findit c, + Just isym | SymbolT.I SymI{clas} <- isym = case g.findit clas of + Just csym | SymbolT.C SymC{supers} <- csym = do + let sym = head [ sym | c <- clas:supers, SymbolT.C SymC{env} <- g.findit c, sym <- values env, - sym.name.base == base ] + (view SymbolT.name sym).base == base ] return sym other -> E.fatal pos (text ("classMethodOfInstMethod: " ++ nice clas g ++ " not a type class.")) other -> E.fatal pos (text ("classMethodOfInstMethod: " ++ nice inst g ++ " not an instance.")) @@ -425,12 +433,12 @@ etaExpand x = case x.typ of -- all other expressions pos = (getpos x).change VARID var arg = ForAll [] (RhoTau [] farg) res = RhoTau [] fret - sym = U.patLocal pos uniq var + sym = unsafeToSymV $ U.patLocal pos uniq var y = cleanVarType g x app = App y (Vbl {pos, name=sym.name, typ = Just arg}) (Just (ForAll [] res)) pat = PVar {pos=pos, uid=uniq, var} -- env = insert Nil pat.var (U.patLocal pos pat.var).{sid=uniq} - enter sym.{state=Typechecked, typ=arg} + enter $ SymbolT.V sym.{state=Typechecked, typ=arg} body <- etaExpand app stio Lam {pat, ex=body, typ = Just (ForAll [] (RhoFun ctx arg res))} | otherwise = stio x @@ -441,12 +449,11 @@ etaExpand x = case x.typ of -- all other expressions let pos = (getpos x).change VARID name name = "η" ++ show uniq pat = PVar{pos=getpos x, uid=uniq, var=name} - sym = U.patLocal pos uniq name + sym = unsafeToSymV $ U.patLocal pos uniq name iarg = ForAll [] (snd sarg) -- Num t42#a => t42#a -> t42#a y = cleanVarType g x app = App y (Vbl {pos, name=sym.name, typ = Just iarg}) (Just (ForAll [] res)) - -- sym <- U.mkLocal pat - enter sym.{state=Typechecked, typ=arg} + enter $ SymbolT.V sym.{state=Typechecked, typ=arg} body <- etaExpand app stio Lam {pat, ex=body, typ = x.typ} @@ -467,10 +474,11 @@ etaExpand x = case x.typ of -- all other expressions case g.findit name of Just sym → v.{typ = Just vtyp} where - subst = unifySigma g sym.typ sigma - vtyp = ForAll [b | b ← sym.typ.bound, not (TM.member b.var subst)] (T.substRho subst sym.typ.rho) + subst = unifySigma g (unsafePartialView SymbolT.typ sym) sigma + vtyp = ForAll [b | b ← (unsafePartialView SymbolT.typ sym).bound, not (TM.member b.var subst)] (T.substRho subst (unsafePartialView SymbolT.typ sym).rho) other → error ("etaExpand: variable not found:" ++ nicer name g) cleanVarType g novar = novar + unsafeToSymV s = case s of { SymbolT.V x -> x; } @@ -490,7 +498,7 @@ isMeager _ = false --- - native functions or CAFs simpleCAF :: Global -> Bool -> Expr -> Bool simpleCAF g local Vbl{pos, name, typ} = case g.findit name of - Just (sym@SymV{}) + Just (SymbolT.V sym) | Just _ <- sym.nativ = true | otherwise = local || sym.depth == 0 other = false diff --git a/frege/compiler/common/UnAlias.fr b/frege/compiler/common/UnAlias.fr index 7ad54c9a..f28e69e2 100644 --- a/frege/compiler/common/UnAlias.fr +++ b/frege/compiler/common/UnAlias.fr @@ -71,7 +71,7 @@ unAlias g tau _ -> tau where - aliased (tau1@TApp a b) (SymA{pos,name,typ,vars}) = case rho of + aliased (tau1@TApp a b) (SymbolT.A SymA{pos,name,typ,vars}) = case rho of -- the expansion of the type alias must be more than a tvar RhoTau [] tau2 | not (isTvApp tau2) -> case unify empty tau2 tau1 of Just subst -> Just (substTau env aApp) @@ -86,7 +86,7 @@ unAlias g tau aliased _ _ = Nothing - aliases = [ sym | any <- values g.thisTab, sym@SymA{} <- g.follow any ] + aliases = [ sym | any <- values g.thisTab, sym@(SymbolT.A _) <- g.follow any ] -- substTau env (TFun a b) = TFun (substTau env a) (substTau env b) diff --git a/frege/compiler/gen/java/Common.fr b/frege/compiler/gen/java/Common.fr index eb4496d6..0560f720 100644 --- a/frege/compiler/gen/java/Common.fr +++ b/frege/compiler/gen/java/Common.fr @@ -4,6 +4,8 @@ module frege.compiler.gen.java.Common where import frege.Prelude hiding (<+>) +import frege.compiler.common.Lens (unsafePartialView, view) + import Data.TreeMap(values, insert, lookup, TreeMap Map, fromList) import Data.Bits(BitSet.member) import Lib.PP(pretty, text, <+>, ) @@ -249,20 +251,20 @@ tauJT g (TSig sig) = sigmaJT g sig taujtApp g qname rest app | Just (sym@(SymbolT.T symt)) <- g.findit qname = case symt of SymT{product=true, kind, newt=true} -> - let sigmas = [ ConField.typ f | sym@SymD {flds} <- values sym.env, f <- flds ] + let sigmas = [ ConField.typ f | sym@(SymbolT.D SymD{flds}) <- values symt.env, f <- flds ] in case sigmas of [] -> Prelude.error (nice sym g ++ " has no fields") (s:_) -> case (substJT subst . lambdaType . sigmaJT g) s of other → other where -- k = kArity kind - subst = fromList (zip sym.typ.vars (map (boxed . tauJT g) rest ++ wilds)) + subst = fromList (zip symt.typ.vars (map (boxed . tauJT g) rest ++ wilds)) -- rsig = ForAll [] (RhoTau [] app) SymT {product,nativ,enum,pur} -- U.pri | Just s <- nativ = if s `elem` primitiveTypes then Nativ {typ=s, gargs=[], generic=true} - else if null sym.gargs + else if null symt.gargs then Nativ {typ=s, gargs=args, generic=false} else Nativ {typ=s, gargs, generic=true} | enum = jtEnum @@ -271,9 +273,9 @@ taujtApp g qname rest app | otherwise = Ref {jname = symJavaName g sym, gargs = args} where restPlusWilds = (map (boxed . tauJT g) rest ++ wilds) - args = map fst (zip restPlusWilds sym.typ.bound) - subst = fromList (zip sym.typ.vars restPlusWilds) - gargs = mapMaybe (subst.lookup . _.var) sym.gargs + args = map fst (zip restPlusWilds symt.typ.bound) + subst = fromList (zip symt.typ.vars restPlusWilds) + gargs = mapMaybe (subst.lookup . _.var) symt.gargs other -> undefined -- can not happen because catched in U.findT | otherwise = Prelude.error (nice qname g ++ " not a type") @@ -588,35 +590,35 @@ symInfo sym = do g <- getST case g.gen.symi8.lookup sym of Just si -> do - E.logmsg TRACEG sym.pos ( - text "got symInfo:" <+> text (nice sym g) <+> text (show sym.sid) + E.logmsg TRACEG (view SymbolT.pos sym) ( + text "got symInfo:" <+> text (nice sym g) <+> text (show (view SymbolT.sid sym)) text "si.returnJT" <+> annoG g si.returnJT text "si.retSig " <+> text (nice si.retSig g) -- text " ) return si other -> case sym of - SymV{} -> do - let (r, as) = U.returnTypeN sym.depth sym.typ.rho + SymbolT.V symv -> do + let (r, as) = U.returnTypeN symv.depth symv.typ.rho rjt = lambdaType (rhoJT g r) - sjts = zipWith (argType g) (strictFuns sym.strsig) as + sjts = zipWith (argType g) (strictFuns symv.strsig) as fjts = map lambdaType sjts - si = SI8{returnJT = returnJType sym.rkind rjt, retSig = ForAll [] r, argJTs = fjts, argSigs = as} + si = SI8{returnJT = returnJType symv.rkind rjt, retSig = ForAll [] r, argJTs = fjts, argSigs = as} changeST Global.{gen <- GenSt.{symi8 <- insert sym si}} - E.logmsg TRACEG sym.pos ( - text "put symInfo:" <+> text (nice sym g) <+> text (show sym.sid) + E.logmsg TRACEG symv.pos ( + text "put symInfo:" <+> text (nice sym g) <+> text (show symv.sid) text "si.returnJT" <+> annoG g si.returnJT text "si.retSig " <+> text (nice si.retSig g) -- text " ) - zipWithM_ (\s j → E.logmsg TRACEG sym.pos ( + zipWithM_ (\s j → E.logmsg TRACEG symv.pos ( text "arg :: " <+> text (nicer s g) <+> text " @@ " <+> text (show j) )) si.argSigs si.argJTs return si - SymD{} -> do - let (r, as) = U.returnType sym.typ.rho + SymbolT.D symd -> do + let (r, as) = U.returnType symd.typ.rho rjt = lambdaType (tauJT g r) - sjts = zipWith (argType g) (map (bool strict lazy . ConField.strict) sym.flds) as + sjts = zipWith (argType g) (map (bool strict lazy . ConField.strict) symd.flds) as fjts = map lambdaType sjts si = SI8{returnJT = rjt, argJTs = fjts, argSigs = as, retSig = ForAll [] (RhoTau [] r)} changeST Global.{gen <- GenSt.{symi8 <- insert sym si}} @@ -654,7 +656,8 @@ memNames = xxxNames "mem" getArgs ∷ Global → [String] getArgs g = drop used argNames where - used = sum (map _.depth g.genEnv) + used = sum (map unsafeGetDepth g.genEnv) + unsafeGetDepth (SymbolT.V SymV{depth}) = depth --- Compute a list of context names we can use for a new function @@ -662,7 +665,7 @@ getArgs g = drop used argNames getCtxs ∷ Global -> [String] getCtxs g = drop used ctxNames where - used = sum . map (length . _.context . _.rho . _.typ) $ g.genEnv + used = sum . map (length . _.context . _.rho . unsafePartialView SymbolT.typ) $ g.genEnv {-- @makeConstraintDef (Ctx cname tau) "ctx3"@ = final Ccname ctx3 @@ -835,8 +838,8 @@ isArrayClass SymC{name} = isArrayClassName name isArrayClass _ = false --- check if a type class is higher kinded -isHigherKindedClass ∷ Symbols.SymbolT α → Bool -isHigherKindedClass SymC{tau} = case tau.kind of +isHigherKindedClass :: SymbolT a -> Bool +isHigherKindedClass (SymbolT.C SymC{tau}) = case tau.kind of KApp{} → true other → false isHigherKindedClass other = false @@ -872,13 +875,13 @@ needsUnchecked which cmem jty = case cmem `lookup` haveDoubleCast of --- check if this is an implementation for a class method, and must suppress unsafe cast warnings unsafeCast :: Global -> Symbol -> Bool -unsafeCast g sym = case sym.name of +unsafeCast g sym = case (view SymbolT.name sym) of MName{tynm, base} - | Just SymI{clas} ← g.findit tynm, - Just SymC{supers} ← g.findit clas, - mems ← [ cmem | Just (symc@SymC{}) ← map g.findit (clas:supers), - cmem ← symc.env.lookupS base, - needsUnchecked snd cmem.name Something] + | Just (SymbolT.I SymI{clas}) <- g.findit tynm + , Just (SymbolT.C SymC{supers}) <- g.findit clas + , mems <- [ cmem | Just (SymbolT.C symc) <- map g.findit (clas:supers) + , cmem <- symc.env.lookupS base + , needsUnchecked snd (view SymbolT.name cmem) Something] = not (null mems) _ = false diff --git a/frege/compiler/gen/java/DataCode.fr b/frege/compiler/gen/java/DataCode.fr index 373ebc4b..cadbf493 100644 --- a/frege/compiler/gen/java/DataCode.fr +++ b/frege/compiler/gen/java/DataCode.fr @@ -3,6 +3,8 @@ module frege.compiler.gen.java.DataCode where import frege.Prelude hiding (<+>) +import frege.compiler.common.Lens (unsafePartialView, view) + import Compiler.common.Errors as E() import Compiler.common.Binders(allBinders) import Compiler.common.JavaName @@ -21,7 +23,6 @@ import Compiler.enums.Flags(TRACEG) --- Generate code for @data@ definitions dataCode :: Symbol → StG [JDecl] --- dataCode (sym@SymT{}) = return [] {-- Enumerations (that is, data types where no constructor has any fields) @@ -30,11 +31,11 @@ dataCode :: Symbol → StG [JDecl] names of the constructors and the function definitions found in the where clause of the @data@. -} -dataCode (sym@(SymbolT.T SymT{enum = true})) = do +dataCode (SymbolT.T (sym@SymT{enum = true})) = do g ← getST - E.logmsg TRACEG sym.pos (text ("dataCode for enum " ++ nicer sym g)) + E.logmsg TRACEG sym.pos (text ("dataCode for enum " ++ nicer (SymbolT.T sym) g)) - sub <- subDecls sym + sub <- subDecls (SymbolT.T sym) let result = JClass{attr = attrTop, name = (javaName g sym.name).base, @@ -45,7 +46,7 @@ dataCode (sym@(SymbolT.T SymT{enum = true})) = do constrs = [JMember{attr = attrTop, jtype = jtEnum, name = (javaName g s.name).base, - init = Just (JAtom (show s.cid))} | s@SymD{} ← values sym.env] + init = Just (JAtom (show s.cid))} | SymbolT.D s <- values sym.env] comment = JComment ("data " ++ sym.name.base ++ " :: " ++ show sym.kind) pure [comment, result] @@ -55,11 +56,11 @@ dataCode (sym@(SymbolT.T SymT{enum = true})) = do We generate an @abstract static class@ as a namespace for the definitions in the where clause, if any. Otherwise, nothing is generated. -} -dataCode (sym@(SymbolT.T SymT{product = true, newt = true})) = do +dataCode (SymbolT.T (sym@SymT{product = true, newt = true})) = do g ← getST - E.logmsg TRACEG sym.pos (text ("dataCode for newtype " ++ nicer sym g)) + E.logmsg TRACEG sym.pos (text ("dataCode for newtype " ++ nicer (SymbolT.T sym) g)) - sub <- subDecls sym + sub <- subDecls (SymbolT.T sym) let result = JClass{attr = attrs [JAbstract, JPublic, JStatic], name = (javaName g sym.name).base, gvars = [], @@ -76,12 +77,12 @@ dataCode (sym@(SymbolT.T SymT{product = true, newt = true})) = do In this case, also the appropriate Kinded instances will be generated. -} -dataCode (sym@(SymbolT.T SymT{ product = true })) = do +dataCode (SymbolT.T (sym@SymT{ product = true })) = do g ← getST - E.logmsg TRACEG sym.pos (text ("dataCode for product " ++ nicer sym g)) + E.logmsg TRACEG sym.pos (text ("dataCode for product " ++ nicer (SymbolT.T sym) g)) - con <- conDecls $ head [ con | con@SymD{} ← values sym.env ] - sub <- subDecls sym + con <- conDecls $ head [ con | SymbolT.D con <- values sym.env ] + sub <- subDecls (SymbolT.T sym) let jtype = rhoJT g sym.typ.rho kindeds = map (asKinded jtype) [1..kArity sym.kind] @@ -129,15 +130,15 @@ dataCode (sym@(SymbolT.T SymT{ product = true })) = do > // sub definitions > } -} -dataCode (sym@(SymbolT.T SymT{ nativ = Nothing, product = false, newt = false })) = do +dataCode (SymbolT.T (sym@SymT{ nativ = Nothing, product = false, newt = false })) = do g ← getST - E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer sym g)) + E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer (SymbolT.T sym) g)) -- constructors - let csyms = [ con | con@SymD{} ← values sym.env ] + let csyms = [ con | SymbolT.D con <- values sym.env ] - sub ← subDecls sym - cons ← mapM conDecls csyms + sub <- subDecls (SymbolT.T sym) + cons <- mapM conDecls csyms let jtype = rhoJT g sym.typ.rho kindeds = map (asKinded jtype) [1..kArity sym.kind] @@ -148,7 +149,7 @@ dataCode (sym@(SymbolT.T SymT{ nativ = Nothing, product = false, newt = false }) -- public isXXX() { return null; } asMethod what con = JMethod{attr=attrs [JPublic], gvars=[], - jtype = variantType g jtype con, + jtype = variantType g jtype (SymbolT.D con), name = conGetter con.name, args = [], body = JBlock{stmts = [JReturn (JAtom what)]}} @@ -172,17 +173,17 @@ dataCode (sym@(SymbolT.T SymT{ nativ = Nothing, product = false, newt = false }) return (if null csyms then [] -- no code for empty data (i.e. a -> b) - else [JComment (nice sym g), result]) + else [JComment (nice (SymbolT.T sym) g), result]) {-- Native data types are mapped to a class that acts as namespace for the subdefinitions, if any. -} -dataCode (sym@(SymbolT.T SymT{ nativ = Just _ })) = do -- nativ +dataCode (SymbolT.T (sym@SymT{ nativ = Just _ })) = do -- nativ g ← getST - E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer sym g)) + E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer (SymbolT.T sym) g)) - sub ← subDecls sym + sub <- subDecls (SymbolT.T sym) -- lazyDefs <- lazyDeclarations vals let result @@ -192,11 +193,11 @@ dataCode (sym@(SymbolT.T SymT{ nativ = Just _ })) = do gvars = [], extend = Nothing, implement = [], defs = sub} - pure [JComment (nice sym g), result] + pure [JComment (nice (SymbolT.T sym) g), result] dataCode sym = do g ← getST - E.fatal sym.pos ( + E.fatal (view SymbolT.pos sym) ( text "dataCode: argument is " <+> text (nice sym g) ) @@ -223,7 +224,7 @@ dataCode sym = do Of course, Java forbids this cast. It works by first casting to @Object@, yet it raises the "unchecked" warning. Hence we do it with magic. -} -simsalabim ∷ Global → Symbol → JType → [JTVar] → JDecl +simsalabim :: Global -> SymT Global -> JType -> [JTVar] -> JDecl simsalabim g sym jt gvars = JMethod{attr = attrs [JUnchecked, JPublic, JFinal], gvars = unusedvars, jtype = newtyp, @@ -235,9 +236,9 @@ simsalabim g sym jt gvars = JMethod{attr = attrs [JUnchecked, JPublic, JFinal], newtyp = jt.{gargs=map (TArg . _.var) unusedvars} -- just give the type variables different names for the return type, -- as this is an instance method - unusedvars = targs g sym.typ.{bound = zipWith _.{var=} + unusedvars = targs g sym.typ.{bound = zipWith _.{var=} sym.typ.bound - (filter (`notElem` sym.typ.vars) (allBinders g)) + (filter (`notElem` sym.typ.vars) (allBinders g)) } {-- Generate the method that coerces from a 'Kinded' representation @@ -263,18 +264,18 @@ coerceDecl gvars jt = - a private java constructor that initializes the arguments - a public "mk" method with the same argument list as the constructor -} -conDecls ∷ Symbol → StG [JDecl] -conDecls (sym@SymD{}) = do - si ← symInfo sym - g ← getST +conDecls :: SymD Global -> StG [JDecl] +conDecls sym = do + si <- symInfo (SymbolT.D sym) + g <- getST let arity = length sym.flds decls = [comment, constr, constructorMethod sym.cid] ++ (if arity == 0 then [single, singleton] else [make]) -- (if isTupleLike then [makeStrict] else []) ++ members - comment = JComment (nice sym g) + comment = JComment (nice (SymbolT.D sym) g) ttype = si.returnJT - ctype = variantType g si.returnJT sym + ctype = variantType g si.returnJT (SymbolT.D sym) constrargs = argDefs attrFinal si (getArgs g) args = take arity (map JAtom (getArgs g)) constr = JConstr {attr = attrs [JPrivate], @@ -334,14 +335,16 @@ asThunkMethod t = atomMethod "asThunk" (inThunk t) "null" that is not a constructor. --} subDecls ∷ Symbol → StG [JDecl] -subDecls (sym@(SymbolT.T _)) = do +subDecls (SymbolT.T sym) = do g ← getST - E.logmsg TRACEG sym.pos (text ("subDecls for " ++ nicer sym g)) - let subdefs = filter (not . _.{flds?}) (values sym.env) -- no constructors + E.logmsg TRACEG sym.pos (text ("subDecls for " ++ nicer (SymbolT.T sym) g)) + let isSymD (SymbolT.D _) = true + isSymD _ = false + let subdefs = filter (not . isSymD) (values sym.env) -- no constructors concat <$> mapM (varCode emptyTree) subdefs subDecls sym = do g ← getST - E.fatal sym.pos ( + E.fatal (view SymbolT.pos sym) ( text "subDecls: argument is " <+> text (nice sym g) ) \ No newline at end of file diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index f7969882..f78c4a58 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -7,6 +7,8 @@ import Lib.PP (text, <+>, , <+/>, <>) import Data.TreeMap as Map(values, lookup, delete, insert, TreeMap) import Data.List(zip4) +import frege.compiler.common.Lens (over, unsafePartialView, view) + import Compiler.Utilities(findC, findV, forceTau, returnType) import Compiler.Javatypes(subTypeOf) @@ -74,16 +76,14 @@ import Compiler.gen.java.VarCode(varCode, compiling, genExpression, genExpr) the class operations, like (++) and 'length'. -} -classCode ∷ Symbol → StG [JDecl] - - - -classCode (sym@SymC{tau = TVar{var,kind}}) = do -- type class +classCode :: Symbol -> StG [JDecl] +classCode (SymbolT.C (sym@SymC{tau = TVar{var,kind}})) = do -- type class g <- getST - let vals = values sym.env + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + let vals = map unsafeToSymV $ values sym.env special = isSpecialClass sym abstrFuns ← mapSt (abstractFun sym) vals - let name = (symJavaName g sym).base + let name = (symJavaName g (SymbolT.C sym)).base -- this = Constr (JName "" name) gargs gvars = if special then [targ g var KType] @@ -99,12 +99,12 @@ classCode (sym@SymC{tau = TVar{var,kind}}) = do -- type class name, gvars, implement = superclasses, defs = concat abstrFuns} - stio [JComment (nice sym g), result] + stio [JComment (nice (SymbolT.C sym) g), result] --- If given something else than a type class this is a fatal compiler error classCode sym = do g ← getST - E.fatal sym.pos ( + E.fatal (view SymbolT.pos sym) ( text "classCode: argument is " <+> text (nice sym g) ) @@ -113,16 +113,17 @@ classCode sym = do --- Returns the compiler state prior to this action, which must be restored afterwards. lowerKindSpecialClasses = do g ← getST - let items = [ (c,v) | n ← specialClassNames, - c ← g.findit (TName pPreludeList n), - v ← Map.values c.env ] + let unsafeToSymC s = case s of { SymbolT.C x -> x; } + let items = [ (c,v) | n <- specialClassNames + , c <- unsafeToSymC <$> g.findit (TName pPreludeList n) + , v <- Map.values c.env ] mapM_ (uncurry lowerKindAbstractFun) items return g -lowerKindAbstractFun ∷ Symbol → Symbol → StG () +lowerKindAbstractFun :: SymC Global -> Symbol -> StG () lowerKindAbstractFun symc sym = do let classvar = symc.tau.var - newsym = sym.{typ <- lowerKind classvar} + newsym = over SymbolT.typ (lowerKind classvar) sym changeSym newsym -- force syminfo to regenerate information, if already present changeST Global.{gen ← _.{symi8 ← delete sym}} @@ -141,13 +142,13 @@ lowerKindAbstractFun symc sym = do --- declare abstract class Member function -abstractFun ∷ Symbol → Symbol → StG [JDecl] -abstractFun symc (sym@SymV{}) = do +abstractFun :: SymC Global -> SymV Global -> StG [JDecl] +abstractFun symc sym = do g <- getST - si <- symInfo sym + si <- symInfo (SymbolT.V sym) let !classCtx = Ctx {pos=symc.pos, - cname = Symbol.name symc, - tau = Symbol.tau symc } + cname = symc.name, + tau = symc.tau } !ctxs = filter (not . sameCtx classCtx) sym.typ.rho.context -- special = isSpecialClass symc arrays = isArrayClass symc -- are we compiling one of the array classes? @@ -168,10 +169,10 @@ abstractFun symc (sym@SymV{}) = do let !result = JMethod {attr = attrs [JPublic], gvars, jtype = (strict . adapt . tauJT g . fst . returnType . _.{context=ctxs} . _.rho) sym.typ, - name = latinF ++ (symJavaName g sym).base, + name = latinF ++ (symJavaName g (SymbolT.V sym)).base, args = formalctxs ++ formalargs, body = JEmpty} - pure [JComment ((nicer sym g) ++ " :: " ++ nicer sym.typ g), result] + pure [JComment ((nicer (SymbolT.V sym) g) ++ " :: " ++ nicer sym.typ g), result] abstractFun symc symx = do g ← getST @@ -209,35 +210,37 @@ abstractFun symc symx = do > public Eq_Maybe(CEq ctx) { ... } > } -} -instanceCode (sym@SymI {sid}) = do -- instance definition +instanceCode (SymbolT.I sym) = do -- instance definition g <- getST - csym <- findC sym.clas + let unsafeToSymC s = case s of { SymbolT.C x -> x; } + csym <- unsafeToSymC <$> findC sym.clas let classes = sym.clas:csym.supers special = isSpecialClass csym -- the functions we must provide in the instance superMethods = [ m.name.base | c <- classes, - SymC{env} <- g.findit c, - m@SymV{} <- values env ] + SymbolT.C SymC{env} <- g.findit c, + SymbolT.V m <- values env ] -- links in types that point to instance members of this class and its superclasses -- The goal is to have (links to) implementations of all super class methods. - methods2 = case instTSym (Symbol.typ sym) g of + methods2 = case instTSym sym.typ g of Just (SymbolT.T tsym) -> [ alias | - SymL {name, alias} <- values tsym.env, alias.{tynm?}, -- links + SymbolT.L SymL{name, alias} <- values tsym.env, + alias.{tynm?}, -- links alias `notElem` methods1, -- avoid duplicates alias.base `elem` superMethods, -- mentioning one of our methods name.base `notElem` map QName.base methods1, - SymI {clas} <- g.findit alias.tynm, -- pointing to an instance - SymC {supers} <- g.findit clas, -- of a class that is in our hierarchy + SymbolT.I SymI{clas} <- g.findit alias.tynm, -- pointing to an instance + SymbolT.C SymC{supers} <- g.findit clas, -- of a class that is in our hierarchy clas `elem` classes || any (`elem` classes) supers] _ -> error "unexpected result from instTSym" - methods1 = map Symbol.name (values sym.env) + methods1 = map (view SymbolT.name) (values sym.env) -- methods of super classes that are implemented in the type itself - methods3 = case instTSym (Symbol.typ sym) g of - Just (SymbolT.T tsym) -> [ sym.name | + methods3 = case instTSym sym.typ g of + Just (SymbolT.T tsym) -> [ view SymbolT.name sym | sym <- values tsym.env, - sym.name.base `elem` superMethods, - sym.name.base `notElem` methods] where + (view SymbolT.name sym).base `elem` superMethods, + (view SymbolT.name sym).base `notElem` methods] where methods = map QName.base (methods1++methods2) _ -> error "unexpected result from instTSym" methods = methods1 ++ methods2 ++ methods3 @@ -248,12 +251,12 @@ instanceCode (sym@SymI {sid}) = do -- instance definition constrargs = zipWith (constraintArg g) sym.typ.rho.context (getArgs g) - let instName = symJavaName g sym + let instName = symJavaName g $ SymbolT.I sym instjt = boxed (rhoJT g sym.typ.rho.{context=[]}) array = Nativ{typ="[]", gargs=[strict instjt], generic=false} rawinst = rawType instjt jtype = Ref instName [] - etype = Ref (symJavaName g csym) (if special + etype = Ref (symJavaName g $ SymbolT.C csym) (if special then [rawinst] else if isArrayClass csym then [array, instjt] @@ -275,7 +278,7 @@ instanceCode (sym@SymI {sid}) = do -- instance definition | null constrargs, special = [JMethod{ attr = attrs [JUnchecked, JPublic, JFinal, JStatic], gvars = [JTVar{var="r", bounds=UNBOUNDED}], - jtype = Constr (symJavaName g csym) [TArg "r"], + jtype = Constr (symJavaName g $ SymbolT.C csym) [TArg "r"], name = "mk", args = [], body = JBlock{stmts = stmtssp}}] @@ -290,7 +293,7 @@ instanceCode (sym@SymI {sid}) = do -- instance definition where gargs = map (TArg . _.var) gvars stmts = [JReturn (JCast jtype.{gargs} (JAtom "it"))] - stmtssp = [JReturn (JCast (Constr (symJavaName g csym) [TArg "r"]) (JAtom "it"))] + stmtssp = [JReturn (JCast (Constr (symJavaName g $ SymbolT.C csym) [TArg "r"]) (JAtom "it"))] singleton | null constrargs = [JMember{attr = attrTop, jtype = jtype.{gargs}, name="it", @@ -303,7 +306,7 @@ instanceCode (sym@SymI {sid}) = do -- instance definition let k = kArity csym.tau.kind kindJT = (("frege.run."++) . show . _.jname . rawType $ Kinded k []) jt = head etype.gargs - implementationRestriction = not special && isHigherKindedClass csym && not (implementsKinded g k jt) + implementationRestriction = not special && isHigherKindedClass (SymbolT.C csym) && not (implementsKinded g k jt) when (implementationRestriction) do case jt of Nativ{typ} | not (subTypeOf g typ kindJT) = E.error sym.pos ( @@ -328,7 +331,7 @@ instanceCode (sym@SymI {sid}) = do -- instance definition <+> text "re-arranging type arguments." text "Also, if this was a newtype, it'll probably help to change it to data." ) - when (isHigherKindedClass csym) do + when (isHigherKindedClass (SymbolT.C csym)) do E.logmsg TRACEG sym.pos (text "instanceCode" <+> text (csym.name.nicer g) <+> text jt.show) instFuns <- mapM (instFun csym sym) (if implementationRestriction then [] else methods) @@ -344,31 +347,34 @@ instanceCode (sym@SymI {sid}) = do -- instance definition ++ make ++ instFuns ++ concat instImpls} - pure [JComment (nice sym g ++ " :: " ++ nice sym.typ g), result] + pure [JComment (nice (SymbolT.I sym) g ++ " :: " ++ nice sym.typ g), result] --- If given something else than a type class this is a fatal compiler error instanceCode sym = do g ← getST - E.fatal sym.pos ( + E.fatal (view SymbolT.pos sym) ( text "instanceCode: argument is " <+> text (nice sym g) ) -instFun :: Symbol → Symbol → QName → StG JDecl +instFun :: SymC Global -> SymI Global -> QName -> StG JDecl instFun symc symi mname = do - g ← getST - sym ← findV mname + g <- getST + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> findV mname let classnames = symc.name:symc.supers special = isSpecialClass symc - cmems = [ m | cln ← classnames, SymC{env} ← g.findit cln, - m ← env.lookupS mname.base ] + cmems = [ m | cln <- classnames + , SymbolT.C SymC{env} <- g.findit cln + , m <- env.lookupS mname.base ] case cmems of [] → E.fatal symi.pos (text "trying to instFun " <+> text (nicer mname g) <+> text " but no class member found.") cmem:_ → do -- replace symc with class where method was introduced - symc ← findC cmem.name.tynm - E.logmsg TRACEG symi.pos (text "instFun" <+> text (nicer sym g) + let unsafeToSymC s = case s of { SymbolT.C x -> x; } + symc <- unsafeToSymC <$> findC (view SymbolT.name cmem).tynm + E.logmsg TRACEG symi.pos (text "instFun" <+> text (nicer (SymbolT.V sym) g) <+> text "for" <+> text (nicer cmem g)) -- We need to tweek the types a bit so that java type variables won't conflict. -- hypothetical scenario @@ -388,14 +394,14 @@ instFun symc symi mname = do -- op :: forall a b y c. (Y b, X y) => T a b -> y -> c E.logmsg TRACEG symi.pos ( text (nicer sym.name g) <+> text " :: " <+> text (nicer sym.typ g) - text (nicer cmem.name g) <+> text " :: " <+> text (nicer cmem.typ g) + text (nicer (view SymbolT.name cmem) g) <+> text " :: " <+> text (nicer (unsafePartialView SymbolT.typ cmem) g) ) - let otvs = filter ((`elem` symi.typ.vars) . Tau.var) cmem.typ.tvars - orep = filter (`notElem` (cmem.typ.vars)) (allBinders g) + let otvs = filter ((`elem` symi.typ.vars) . Tau.var) (unsafePartialView SymbolT.typ cmem).tvars + orep = filter (`notElem` ((unsafePartialView SymbolT.typ cmem).vars)) (allBinders g) substBound :: TreeMap String Tau -> [Tau] -> [Tau] substBound subst xs = map (\tv -> maybe tv _.{kind=tv.kind} (lookup tv.var subst)) xs subst1 = Map.fromList [ (tv.var, tv.{var=s}) | (s,tv) ← zip orep otvs] - typ1 = ForAll (substBound subst1 cmem.typ.bound) (substRho subst1 cmem.typ.rho) + typ1 = ForAll (substBound subst1 (unsafePartialView SymbolT.typ cmem).bound) (substRho subst1 (unsafePartialView SymbolT.typ cmem).rho) E.logmsg TRACEG symi.pos ( text "(1) renamed type :: " <+> text (nicer typ1 g) @@ -512,7 +518,7 @@ instFun symc symi mname = do | (uid, sig, atom, jt) ← zip4 uids sigs atoms rgargs, ex = JCast (lazy jt) (JCast Something atom) ] | otherwise = binds - result ← compiling sym.{typ=fakety} (genExpr true retJT ex rawbinds) + result ← compiling (SymbolT.V sym.{typ=fakety}) (genExpr true retJT ex rawbinds) let rex | special, retJTr != retJT = JCast retJTr (JCast Something result.jex) | otherwise = result.jex @@ -536,12 +542,12 @@ instFun symc symi mname = do -- finally make the function pure JMethod{attr = if special || unchecked rex - || needsUnchecked fst cmem.name (Map.lookupDefault Something cvar.var jsubstr) + || needsUnchecked fst (view SymbolT.name cmem) (Map.lookupDefault Something cvar.var jsubstr) then attrs [JUnchecked, JPublic, JFinal, JOverride] else attrs [JPublic, JFinal, JOverride], gvars = targs g methty, jtype = retJTr, - name = latinF ++ (symJavaName g sym).base, + name = latinF ++ (symJavaName g (SymbolT.V sym)).base, args = [(attrFinal, pSigma, ctx, name) | (ctx,name) ← zip cgargs (drop (length symi.typ.rho.context) diff --git a/frege/compiler/gen/java/Instantiation.fr b/frege/compiler/gen/java/Instantiation.fr index b465dcf4..f2f4fcd1 100644 --- a/frege/compiler/gen/java/Instantiation.fr +++ b/frege/compiler/gen/java/Instantiation.fr @@ -3,6 +3,8 @@ module frege.compiler.gen.java.Instantiation where import frege.Prelude hiding(<+>) +import frege.compiler.common.Lens (unsafePartialView) + import Lib.PP(text, <+>, <>, <+>, <+/>) import Data.TreeMap(member) @@ -33,8 +35,7 @@ import Compiler.gen.java.Bindings envCtxs g = [ ctx | s <- reverse (Global.genEnv g), - -- not (null (Symbol.typ s).bound), - ctx <- (Symbol.typ s).rho.context ] + ctx <- (unsafePartialView SymbolT.typ s).rho.context ] --- takes a list of contexts and returns the ones that are resolvable resolvableCtxs ∷ Global → [Context] → [Context] @@ -80,12 +81,14 @@ resolveConstraint pos (ctx@Ctx {cname, tau}) = do pure (JAtom "UNKNOWN_CONTEXT") else pure ((JAtom • head) ok) makeCtx = do - csym <- U.findC cname + let unsafeToSymC (SymbolT.C x) = x + csym <- unsafeToSymC <$> U.findC cname let special = isSpecialClassName cname case tcon of TCon {name} -> case filter ((name ==) • fst) csym.insts of (_,iname):_ -> do - inst <- U.findI iname + let unsafeToSymI (SymbolT.I x) = x + inst <- unsafeToSymI <$> U.findI iname g <- getST let crho = RhoTau [] tau csig = ForAll [] crho @@ -107,7 +110,7 @@ resolveConstraint pos (ctx@Ctx {cname, tau}) = do E.logmsg TRACEG pos (text ("makeCtx substituted: " ++ nice rho g)) -- let subctx = map (TC.reducedCtx g) rho.context args <- mapM (resolveConstraint pos) rho.context - let jiname = symJavaName g inst + let jiname = symJavaName g $ SymbolT.I inst let jit = Constr jiname gargs -- jitjts jex | special, null args = JInvoke (JX.static "mk" jit).{targs=[boxed taujt]} [] diff --git a/frege/compiler/gen/java/Match.fr b/frege/compiler/gen/java/Match.fr index 3b8e5436..12541cc4 100644 --- a/frege/compiler/gen/java/Match.fr +++ b/frege/compiler/gen/java/Match.fr @@ -13,6 +13,8 @@ import frege.Prelude hiding(apply, <+>) import Data.TreeMap as TM(TreeMap, values, keys, each, insert, lookup) import Data.List as DL(sortBy, partitioned) +import frege.compiler.common.Lens (unsafePartialView, view) + import Compiler.enums.Literals import Compiler.types.Strictness @@ -86,7 +88,8 @@ match :: Bool -> TreeMap Int Binding -> StG (Binding, [JStmt]) match assert (PVar {pos,uid,var}) bind cont binds = do - vsym <- U.findV local + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + vsym <- unsafeToSymV <$> U.findV local g ← getST let strict = vsym.strsig.isStrict @@ -108,7 +111,7 @@ match assert (PVar {pos,uid,var}) bind cont binds = do (rbind, code) <- if strict then realize (jname g) sbind else pure (sbind, []) let stmt | var == "_" = code - | otherwise = sComment ("bind " ++ sls ++ " var " ++ nice (Symbol.name vsym) g + | otherwise = sComment ("bind " ++ sls ++ " var " ++ nice vsym.name g ++ " to " ++ show rbind) : code nbinds = insert uid rbind binds rest <- cont nbinds @@ -124,7 +127,8 @@ match assert (p@PAt {pat,uid,var}) bind cont binds = do -- let patty = patternRMode g pat let local = Local uid var jname = (javaName g local).base - vsym <- U.findV local + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + vsym <- unsafeToSymV <$> U.findV local let comment bind = sComment ("match " ++ nice p g ++ "::" ++ nicer vsym.typ g ++ " with " ++ show bind) @@ -163,16 +167,17 @@ match assert (pat@PLit {kind=LBool, value}) bind cont binds = do match assert (pat@PCon {pos,qname,pats}) bind cont binds = do -- g <- getST - symd <- U.findD qname -- forall a.a -> List a -> List a + let unsafeToSymD s = case s of { SymbolT.D x -> x; } + symd <- unsafeToSymD <$> U.findD qname -- forall a.a -> List a -> List a symt' <- U.findT symd.name.tynm -- forall a.List a case symt' of SymbolT.T symt -> - if symt.enum then matchEnum symd (SymbolT.T symt) + if symt.enum then matchEnum (SymbolT.D symd) (SymbolT.T symt) else if symt.product then if symt.newt - then matchNew symd (SymbolT.T symt) - else matchProd symd (SymbolT.T symt) -- pat bind cont binds - else matchVariant symd (SymbolT.T symt) -- pat bind cont binds + then matchNew (SymbolT.D symd) (SymbolT.T symt) + else matchProd (SymbolT.D symd) (SymbolT.T symt) -- pat bind cont binds + else matchVariant (SymbolT.D symd) (SymbolT.T symt) -- pat bind cont binds where unKindedStrict g lbnd = case strictBind g lbnd of kbnd -> case kbnd.jtype of @@ -196,8 +201,8 @@ match assert (pat@PCon {pos,qname,pats}) bind cont binds = do matchNew symd symt = do g <- getST let -- box0 = adaptSigma g bind - arg = symd.typ.rho.sigma -- first arg of data con - tree = unifySigma g symt.typ bind.ftype -- instantiate type args a -> Int + arg = (unsafePartialView SymbolT.typ symd).rho.sigma -- first arg of data con + tree = unifySigma g (unsafePartialView SymbolT.typ symt) bind.ftype -- instantiate type args a -> Int sig = substSigma tree arg -- substitute in arg E.logmsg TRACEG (getpos pat) ( text "matchNew:" <+> text (nicer pat g) PP.nest 4 ( @@ -211,7 +216,8 @@ match assert (pat@PCon {pos,qname,pats}) bind cont binds = do match assert (head pats) box1 cont binds matchVariant :: Symbol -> Symbol -> StG (Binding, [JStmt]) - matchVariant symd (SymbolT.T symt) = do + matchVariant symd' (SymbolT.T symt) = do + let symd = case symd' of { SymbolT.D x -> x; } g <- getST E.logmsg TRACEG (getpos pat) (text "match pattern " <+> text (nicer pat g) @@ -226,14 +232,14 @@ match assert (pat@PCon {pos,qname,pats}) bind cont binds = do cname = if symt.product then "" else conGetter qname -- _DCons vbind = if symt.product then boxd else Bind boxd.stype boxd.ftype - (variantType g boxd.jtype symd) + (variantType g boxd.jtype $ SymbolT.D symd) (JInvoke (JX.jexmem boxd.jex cname) []) (varb, code2) <- if symt.product then return (boxd, []) else realize "$" vbind -- TList.DCons $2 = $1._DCons() E.logmsg TRACEG pos (text "match constructor " - <+> text (nicer symd g) + <+> text (nicer (SymbolT.D symd) g) text "realized at " <+> text (show varb) text "fields:" @@ -375,7 +381,7 @@ match _ pat b c bs = do matchCon assert (PCon {pos,qname, pats}) con bexs cont binds = do g <- getST sym <- U.findD qname - if sym.sid != Symbol.sid con + if view SymbolT.sid sym != view SymbolT.sid con then do E.fatal pos (text ("matchCon: " ++ nice qname g ++ " against " ++ nice con g)) else do diff --git a/frege/compiler/gen/java/MethodCall.fr b/frege/compiler/gen/java/MethodCall.fr index 3e018362..a5cdd06b 100644 --- a/frege/compiler/gen/java/MethodCall.fr +++ b/frege/compiler/gen/java/MethodCall.fr @@ -4,13 +4,15 @@ module frege.compiler.gen.java.MethodCall where import Data.TreeMap(TreeMap, values) import Data.List(elemBy) +import frege.compiler.common.Lens (unsafePartialView, view) + import Compiler.Utilities as U() import Compiler.classes.Nice(nice, nicer) import Compiler.types.AbstractJava import Compiler.types.Types(unST, Sigma, Tau, TauT, ForAll, RhoTau, RhoFun) -import Compiler.types.Symbols(SymbolT) +import Compiler.types.Symbols(SymD, SymV, SymbolT) import Compiler.types.Global import Compiler.types.JNames(JName, memberOf) import Compiler.types.Strictness() @@ -37,35 +39,36 @@ niSpecial g ty --- Tells if a native symbol is wrapped -wrapped g (sym@SymV {nativ = Just item, throwing}) = not (null throwing) - || niSpecial g rty - || not (null (wildReturn g sym)) +wrapped :: Global -> Symbol -> Bool +wrapped g (SymbolT.V (sym@SymV{nativ = Just item, throwing})) = + not (null throwing) + || niSpecial g rty + || not (null (wildReturn g $ SymbolT.V sym)) where (rty, _) = U.returnType sym.typ.rho -wrapped g SymV {} = false -wrapped g SymD {} = false -wrapped g _ = error "wrapped: no symv" - +wrapped _ (SymbolT.V _) = false +wrapped _ (SymbolT.D _) = false +wrapped _ _ = error "wrapped: no symv" + {-- Tell if a native function must be called through its wrapper. This is the case when it is wrapped for some other reason than that the return type is 'Maybe'. -} -wrappedOnly g (sym@SymV {nativ = Just _, throwing}) +wrappedOnly g (SymbolT.V (symv@SymV {nativ = Just _, throwing})) = not (null throwing) || niSpecial g rty && isNothing (U.isMaybe rty) - || not (null (wildReturn g sym)) + || not (null (wildReturn g $ SymbolT.V symv)) where - (rty, _) = U.returnType sym.typ.rho -wrappedOnly g sym = error "wrappedOnly - no native function" --- --- + (rty, _) = U.returnType symv.typ.rho +wrappedOnly _ sym = error "wrappedOnly - no native function" + --- returns a binding for a direct call of a native method nativeCall ∷ Global → Symbol → TreeMap String Tau → [JExpr] → Binding -nativeCall g (sym@SymV {nativ = Just item, gargs}) subst aexs = newBind g bsig (call jrty args) +nativeCall g (SymbolT.V (symv@SymV{nativ = Just item, gargs})) subst aexs = newBind g bsig (call jrty args) where - (rty, sigmas) = U.returnType sym.typ.rho + (rty, sigmas) = U.returnType symv.typ.rho taus = [ tau | Just tau <- map U.sigmaAsTau sigmas ] brty = substTau subst (baserty rty) bsig = U.tauAsSigma brty @@ -104,16 +107,16 @@ nativeCall g (sym@SymV {nativ = Just item, gargs}) subst aexs = newBind g bsig ( let evalStG :: Global -> StG a -> a evalStG g st = fst $ st.run g x = do g <- getST - si <- symInfo sym + si <- symInfo $ SymbolT.V symv let name = (head si.argSigs).rho.tau.name irsym = unJust $ g.findit name - nms = mapMaybe (_.name) [ fld | x@SymD{} <- values irsym.env, fld <- x.flds ] + nms = mapMaybe (_.name) [ fld | SymbolT.D x <- values (unsafePartialView SymbolT.env irsym), fld <- x.flds ] return $ flip mapMaybe nms $ \fldnm -> do nativrsym <- g.findit $ si.retSig.rho.tau.name - nativsym <- TreeMap.lookup fldnm nativrsym.env - nativnm <- nativsym.nativ + nativsym <- TreeMap.lookup fldnm (unsafePartialView SymbolT.env nativrsym) + nativnm <- unsafePartialView SymbolT.nativ nativsym let nativsi = evalStG g $ symInfo nativsym - fldsym <- TreeMap.lookup fldnm irsym.env + fldsym <- TreeMap.lookup fldnm (unsafePartialView SymbolT.env irsym) pure $ wrapIRMethod g (head args) (head si.argJTs) nativsi nativnm fldnm fldsym in JNewClass jrty [] (evalStG g x) NICast -> case args of @@ -148,10 +151,11 @@ nativeCall g (sym@SymV {nativ = Just item, gargs}) subst aexs = newBind g bsig ( [a,b,c] -> JBin (JArrayGet a b) "=" c _ -> JAtom "bad array set" -- error was flagged before nativeCall g sym subst aexs = error ("nativeCall: no function " - ++ show sym.pos.first.line + ++ show (view SymbolT.pos sym).first.line ++ ", " ++ nicer sym g) --- -wrapCode g jreturn rtau (sym@SymV {nativ = Just item, throwing}) subst aexs + +wrapCode :: Global -> (JExpr -> JStmt) -> Tau -> Symbol -> TreeMap String Tau -> [JExpr] -> [JStmt] +wrapCode g jreturn rtau (sym@(SymbolT.V SymV{nativ = Just item, throwing})) subst aexs | Just (stau, atau) <- unST rtau = let sjt = tauJT g stau -- type #1 for parameterization of ST s a ajt = tauJT g atau -- return type of the ST action @@ -224,9 +228,9 @@ wrapCode g jreturn rtau sym _ _ = error "wrapCode: no SymV" code for native functions and/or members -} methCode :: Global -> Symbol -> SymInfo8 -> [JDecl] -methCode g (sym@SymV {nativ = Just item}) si = [ - JComment ((nice sym g) ++ " " ++ show sym.strsig ++ " " ++ show sym.rkind), - JComment (nicer sym.typ g), +methCode g (sym@(SymbolT.V (symv@SymV {nativ = Just item}))) si = [ + JComment ((nice sym g) ++ " " ++ show symv.strsig ++ " " ++ show symv.rkind), + JComment (nicer symv.typ g), JComment ("the following type variables are probably wildcards: " ++ joined ", " (map _.var wildr)), JComment item] ++ (if arity then defs @@ -239,7 +243,7 @@ methCode g (sym@SymV {nativ = Just item}) si = [ wArgs = argDefs attrFinal si (getArgs g) wildr = wildReturn g sym name = symJavaName g sym -- X.foo - ftargs = targs g sym.typ -- + ftargs = targs g symv.typ -- args = if haswrapper then wArgs else rArgs haswrapper = arity && wrapped g sym -- (not (null bnds)) jreturn = if arity then JReturn else JEx @@ -267,10 +271,10 @@ methCode g (sym@SymV {nativ = Just item}) si = [ name = (symJavaName g sym).base, init = Just (unex wcode)} - (rty, atys) = U.returnType sym.typ.rho - arity = not (null atys) || not (null sym.typ.bound) + (rty, atys) = U.returnType symv.typ.rho + arity = not (null atys) || not (null symv.typ.bound) -methCode g sym _ = Prelude.error ("line " ++ show sym.pos.first.line +methCode g sym _ = Prelude.error ("line " ++ show (view SymbolT.pos sym).first.line ++ ": can not compile " ++ nice sym g) {-- @@ -284,11 +288,12 @@ methCode g sym _ = Prelude.error ("line " ++ show sym.pos.first.line and we need to cast the result. -} wildReturn ∷ Global → Symbol → [Tau] -wildReturn g (symv@SymV{}) = [ v | v@TVar{} ← values (U.freeTauTVars [] TreeMap.empty ret), - not (stvar v.var), - not (elemBy (using _.var) v sigvars), - not (elemBy (using _.var) v itemvars) - ] +wildReturn g (SymbolT.V symv) = + [ v | v@TVar{} ← values (U.freeTauTVars [] TreeMap.empty ret) + , not (stvar v.var) + , not (elemBy (using _.var) v sigvars) + , not (elemBy (using _.var) v itemvars) + ] where (ret, sigs) = U.returnType symv.typ.rho -- identify ST phantom type variable, if any @@ -303,7 +308,7 @@ wildReturn _ _ = [] wrapIRMethod :: Global -> JExpr -> JType -> SymInfo8 -> String -> String -> Symbol -> JDecl wrapIRMethod g this irjt nativsi nativnm fldnm fldsym = let nativargs = argDefs attrFinal (nativsi.{ argSigs <- tail, argJTs <- tail }) (getArgs g) - fldstri = case fldsym.strsig of + fldstri = case unsafePartialView SymbolT.strsig fldsym of Strictness.S xs -> tail xs _ -> [] -- how to detect strictness of result value? diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index 5bd44617..c2813675 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -9,6 +9,8 @@ import Lib.PP(text, <>, <+>, <+/>, ) import Data.Bits(BitSet, BitSet.member, BitSet.unionE, BitSet.differenceE) import Data.List(partitioned, zip4) +import frege.compiler.common.Lens (view) + import Compiler.enums.Flags(TRACEG) import Compiler.enums.RFlag as RF(RFlag) import Compiler.enums.Literals @@ -59,7 +61,7 @@ import Compiler.gen.java.Instantiation(instPatternBound, resolveConstraint, envC import Compiler.gen.java.PrettyJava(lambda7, thunkMarker) varCode ∷ TreeMap Int Binding → Symbol → StG [JDecl] -varCode _ (SymL{sid, pos, vis, name, alias}) = do +varCode _ (SymbolT.L SymL{sid, pos, vis, name, alias}) = do g ← getST pure [JComment ("alias " ++ name.base @@ -68,20 +70,20 @@ varCode _ (SymL{sid, pos, vis, name, alias}) = do varCode binds sym = do g <- getST - E.logmsg TRACEG sym.pos (text ("varCode for " ++ nicer sym g)) + E.logmsg TRACEG (view SymbolT.pos sym) (text ("varCode for " ++ nicer sym g)) si <- symInfo sym - case sym of - SymV{expr = Just{}} - | null si.argSigs = cafCode sym binds -- nust be CAF - | otherwise = funDef sym binds - SymV {nativ = Just _, over} + case sym of + SymbolT.V (symv@SymV{expr = Just _}) + | null si.argSigs = cafCode symv binds -- nust be CAF + | otherwise = funDef symv binds + SymbolT.V (symv@SymV{nativ = Just _, over}) | null over = do g ← getST - E.logmsg TRACEG sym.pos (text "native var:" - <+> text (nice sym.name g) <+> text "∷" - <+> text (nicer sym.typ.rho g) - <> text ", depth=" <> anno sym.depth - <> text ", rstate=" <> (text • show) sym.rkind) + E.logmsg TRACEG symv.pos (text "native var:" + <+> text (nice symv.name g) <+> text "∷" + <+> text (nicer symv.typ.rho g) + <> text ", depth=" <> anno symv.depth + <> text ", rstate=" <> (text • show) symv.rkind) si ← symInfo sym return (comment : methCode g sym si) | otherwise = return [] -- there is no code for overloads @@ -90,7 +92,7 @@ varCode binds sym = do _ = error ("varCode: no SymV? " ++ nicer sym g) --- Generate code for a function with arguments -funDef ∷ Symbol → TreeMap Int Binding → StG [JDecl] +funDef :: SymV Global -> TreeMap Int Binding -> StG [JDecl] funDef sym binds = do g ← getST if g.toplevel @@ -98,7 +100,7 @@ funDef sym binds = do else localFun sym binds --- Generate code for a top level function -topFun ∷ Symbol → TreeMap Int Binding → StG [JDecl] +topFun :: SymV Global -> TreeMap Int Binding -> StG [JDecl] topFun (sym@SymV {expr = Just dx}) binds = do g ← getST E.logmsg TRACEG sym.pos (text "topFun:" @@ -108,7 +110,7 @@ topFun (sym@SymV {expr = Just dx}) binds = do <> text ", rstate=" <> (text • show) sym.rkind) -- x ← dx -- get expression - si ← symInfo sym + si ← symInfo (SymbolT.V sym) let !arity = length si.argSigs when (arity != sym.depth) do @@ -116,7 +118,7 @@ topFun (sym@SymV {expr = Just dx}) binds = do return () -- check if we are an implementation for a class method, and must suppress unsafe cast warnings - let unsafe = unsafeCast g sym + let unsafe = unsafeCast g (SymbolT.V sym) let argNames = getArgs g ctxNames = getCtxs g @@ -124,7 +126,7 @@ topFun (sym@SymV {expr = Just dx}) binds = do argAttr = if isTailRec then empty else attrFinal ctxArgs = map (unFinal isTailRec) (zipWith (constraintArg g) sym.typ.rho.context ctxNames) methArgs = argDefs argAttr si argNames - methName = (symJavaName g sym).base + methName = (symJavaName g $ SymbolT.V sym).base attr | unsafe = attrs [JUnchecked, JFinal, JPublic, JStatic] | otherwise = attrs [JFinal, JPublic, JStatic] @@ -148,7 +150,7 @@ topFun (sym@SymV {expr = Just dx}) binds = do -- abinds = map (arg2Bind g) strictArgs -- ctxs = map (\(_,_,_,ctx) -> JAtom ctx) ctxArgs - stmts ← compiling sym (genFunction sym si.returnJT methArgs binds) + stmts ← compiling (SymbolT.V sym) (genFunction sym si.returnJT methArgs binds) let worker = JMethod {attr, gvars = targs g sym.typ, @@ -160,13 +162,13 @@ topFun (sym@SymV {expr = Just dx}) binds = do -- args = ctxArgs ++ strictArgs, -- body = JBlock [strictStmt]} - pure ([JComment ((nicer sym g) ++ " " ++ show sym.strsig ++ " " ++ show sym.rkind), + pure ([JComment ((nicer (SymbolT.V sym) g) ++ " " ++ show sym.strsig ++ " " ++ show sym.rkind), JComment (nicer sym.typ g), worker]) topFun sym binds = do g ← getST - error ("topFun: no SymV with expression " ++ nicer sym g) + error ("topFun: no SymV with expression " ++ nicer (SymbolT.V sym) g) {-- Code for a let/where bound function that has at least one of the following properties: @@ -180,7 +182,7 @@ topFun sym binds = do as well as other let bound items the code may reference. -} -localFun ∷ Symbol → TreeMap Int Binding → StG [JDecl] +localFun :: SymV Global -> TreeMap Int Binding -> StG [JDecl] localFun (sym@SymV {expr = Just dx}) binds = do g ← getST E.logmsg TRACEG sym.pos (text "localFun:" @@ -189,7 +191,7 @@ localFun (sym@SymV {expr = Just dx}) binds = do <> text ", depth=" <> anno sym.depth <> text ", rstate=" <> (text • show) sym.rkind) - si ← symInfo sym + si ← symInfo $ SymbolT.V sym let !arity = length si.argSigs when (arity != sym.depth) do @@ -205,7 +207,7 @@ localFun (sym@SymV {expr = Just dx}) binds = do methArgs = argDefs argAttr si argNames methName = (javaName g sym.name).base - stmts ← compiling sym (genFunction sym si.returnJT methArgs binds) + stmts ← compiling (SymbolT.V sym) (genFunction sym si.returnJT methArgs binds) let worker = JMethod {attr = attrs [JFinal, JPublic], gvars = targs g sym.typ, @@ -214,13 +216,13 @@ localFun (sym@SymV {expr = Just dx}) binds = do args = ctxArgs ++ methArgs, body = JBlock stmts} - pure ([JComment ((nicer sym g) ++ " " ++ show sym.strsig ++ " " ++ show sym.rkind), + pure ([JComment ((nicer (SymbolT.V sym) g) ++ " " ++ show sym.strsig ++ " " ++ show sym.rkind), JComment (nicer sym.typ g), worker]) localFun sym binds = do g ← getST - E.fatal sym.pos (text "invalid local fun " <+> text (sym.nice g)) + E.fatal sym.pos (text "invalid local fun " <+> text ((SymbolT.V sym).nice g)) --- Used to remove the @final@ attributes of arguments. Needed for polymorphic recursion. unFinal ∷ Bool → FormalArg → FormalArg @@ -238,7 +240,7 @@ unFinal s (arg@(a,b,c,d)) Results in a simple java lambda. -} innerFun ∷ Symbol → TreeMap Int Binding → StG [JDecl] -innerFun (sym@SymV {expr = Just dx}) binds = do +innerFun (SymbolT.V (sym@SymV {expr = Just dx})) binds = do g ← getST E.logmsg TRACEG sym.pos (text "innerFun:" <+> text (nice sym.name g) <+> text "∷" @@ -252,11 +254,11 @@ innerFun (sym@SymV {expr = Just dx}) binds = do argNames = getArgs g methArgs = [ (attrFinal, sig, lazy jt, nm) | (sig,jt,nm) <- zip3 sigs (take arity funcjt.gargs) argNames ] - methName = (symJavaName g sym).base + methName = (symJavaName g $ SymbolT.V sym).base funcjt = lambdaType (rhoJT g sym.typ.rho) symx = sym.{rkind ← _.differenceE RValue} - changeSym symx -- remember this + changeSym $ SymbolT.V symx -- remember this when (arity != length funcjt.gargs - 1) do E.error sym.pos ( text "lambda depth" <+> anno arity <+> text "does not match function type " @@ -266,18 +268,18 @@ innerFun (sym@SymV {expr = Just dx}) binds = do text "This is probably a compiler error you should report." ) ex ← dx - stmts ← compiling symx (genLambda (lazy . last . _.gargs $ funcjt) ex methArgs binds) + stmts ← compiling (SymbolT.V symx) (genLambda (lazy . last . _.gargs $ funcjt) ex methArgs binds) let !lambda = JLambda{fargs=methArgs, code=Right JBlock{stmts}} !member = JMember{attr = attrFinal, jtype = funcjt, name = methName, init = Just (JCast funcjt lambda)} - pure [JComment ((nicer sym g) ++ " :: " ++ nicer sym.typ g), + pure [JComment ((nicer (SymbolT.V sym) g) ++ " :: " ++ nicer sym.typ g), member] innerFun sym binds = do g ← getST - E.fatal sym.pos (text "invalid inner fun " <+> text (sym.nice g)) + E.fatal (view SymbolT.pos sym) (text "invalid inner fun " <+> text (sym.nice g)) {-- @@ -315,17 +317,17 @@ cafCode (sym@SymV {name, depth = 0, expr = Just dx}) binds = do then sym.rkind.unionE RMethod else sym.rkind.differenceE RMethod - changeSym sym.{rkind=xkind} + changeSym $ SymbolT.V sym.{rkind=xkind} let comments = [ - JComment ((nicer sym g) ++ " " ++ show sym.strsig ++ " " ++ show xkind), + JComment ((nicer (SymbolT.V sym) g) ++ " " ++ show sym.strsig ++ " " ++ show xkind), JComment (nicer sym.typ g), JComment (nicer x g)] - name = symJavaName g sym -- P.foo + name = symJavaName g (SymbolT.V sym) -- P.foo if not inmethod && rsimple && not self then do - ecode ← compiling sym (genExpr false rtype x binds) + ecode ← compiling (SymbolT.V sym) (genExpr false rtype x binds) pure (comments ++ [ -- T foo = .... JMember { attr = attrTop, jtype = rtype, name = name.base, @@ -335,9 +337,9 @@ cafCode (sym@SymV {name, depth = 0, expr = Just dx}) binds = do code ← do let badguard = openCaseWhen g x jthrow = [JThrow (JNew (Ref (JName "frege.runtime" "GuardFailed") []) [ - JAtom (show (nicer sym g)), + JAtom (show (nicer (SymbolT.V sym) g)), JAtom (show sym.pos)])] - code <- compiling sym (genReturn stype x binds) + code <- compiling (SymbolT.V sym) (genReturn stype x binds) case badguard of Just (Left x) -> do E.warn (getpos x) (text "guard (" <> (nicest g x) <> text ") may evaluate to false.") @@ -382,13 +384,13 @@ cafCode (sym@SymV {name, depth = 0, expr = Just dx}) binds = do cafCode _ binds = error "cafCode: no caf" -innerCaf ∷ Symbol → TreeMap Int Binding → Bool → StG [JDecl] +innerCaf :: SymV Global -> TreeMap Int Binding -> Bool -> StG [JDecl] innerCaf sym binds mutual = do g ← getST - E.logmsg TRACEG sym.pos (text ("compiling inner " ++ sym.nice g)) + E.logmsg TRACEG sym.pos (text ("compiling inner " ++ (SymbolT.V sym).nice g)) - let memName = (symJavaName g sym).base + let memName = (symJavaName g (SymbolT.V sym)).base memAttrs = attrs [JFinal] tweak :: JDecl -> JDecl tweak decl @@ -450,7 +452,7 @@ genLambda rm (Lam {pat, ex}) ((arg@(_, _, _, s)) : args) binds = do badguard = openCaseWhen g ex assert = isNothing komplett -- mustthrow = not assert && isNothing badguard - margs = map JAtom [show ((last g.genEnv).name.nice g), + margs = map JAtom [show ((view SymbolT.name (last g.genEnv)).nice g), show (getpos pat)] ++ [JAtom s] -- construct new NoMatch("Module.foo", 42, arg$1) jthrow = [JThrow (JNew jtNoMatch margs)] @@ -505,7 +507,8 @@ genStmts jret rm (x@Case {ckind,ex=cex,alts=calts}) binds = genCaseStmt jret rm genStmts jret rm (x@Let {env, ex}) binds = do case env of [k] -> do - symv <- U.findV k + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + symv <- unsafeToSymV <$> U.findV k -- change -- > let !name = simple in ex @@ -543,8 +546,8 @@ genStmts jret rm ex binds case ex of App _ _ _ | Vbl {name}:args <- map fst (flatx ex), - Just (sym@SymV {sid}) <- g.findit name, - sid == (head (g.genEnv)).sid, + Just (SymbolT.V (sym@SymV{sid})) <- g.findit name, + sid == view SymbolT.sid (head g.genEnv), length args == sym.depth = do -- tail call let argNames = map (++"f") @@ -705,7 +708,7 @@ genCaseStmt jret rm (x@Case {ckind,ex=cex,alts=calts}) binds = do pure (jthrow arg) | otherwise = pure [] -- no throw needed - throwargs exb = map JAtom [show ((Prelude.last g.genEnv).name.nice g), + throwargs exb = map JAtom [show ((view SymbolT.name (Prelude.last g.genEnv)).nice g), show (getpos x)] ++ [Binding.jex exb] jthrow exb = [JThrow (JNew jtNoMatch (throwargs exb))] @@ -749,11 +752,11 @@ genCaseStmt jret rm (x@Case {ckind,ex=cex,alts=calts}) binds = do case pat of PCon {qname} -> do sym <- U.findD qname - if sym.sid == Symbol.sid con then do + if view SymbolT.sid sym == con.sid then do let nbexs = case stri of S ss -> zipWith (bexStr g) bexs (ss ++ allLazy) _ -> bexs - code <- matchCon noif pat con nbexs (genStmts jret rm ex) binds + code <- matchCon noif pat (SymbolT.D con) nbexs (genStmts jret rm ex) binds g <- getST pure ((altComm g:code):codes, nbexs) else do @@ -779,7 +782,8 @@ genCaseStmt jret rm (x@Case {ckind,ex=cex,alts=calts}) binds = do -- check if an expression is a constructor application constrApp (ex@App _ _ _) = case map fst (flatx ex) of Con {name}:xs -> do - sym <- U.findD name + let unsafeToSymD s = case s of { SymbolT.D x -> x; } + sym <- unsafeToSymD <$> U.findD name if length sym.flds == length xs then pure (Just (sym, xs)) else pure Nothing -- for example: case (,) a of mktuple -> mktuple b @@ -789,7 +793,8 @@ genCaseStmt jret rm (x@Case {ckind,ex=cex,alts=calts}) binds = do conUVarAlt false _ = pure false conUVarAlt true (CAlt {pat = PCon {pos}}) = pure true conUVarAlt true (CAlt {pat = PVar {var,uid}, ex}) = do - sym <- U.findV (Local uid var) + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> U.findV (Local uid var) refs <- T.references [sym.sid] ex pure (refs == 0) conUVarAlt _ _ = pure false @@ -811,7 +816,7 @@ genCaseStmt jret rm nocase binds = error "genCaseStmt: no case" - Functions, i.e. things that have 'Symbol.depth' greater than 0 or a type with constraints or bound type variables. -} -needClassForLet ∷ [Symbol] → Bool +needClassForLet :: [SymV Global] -> Bool needClassForLet [SymV{typ, depth, rkind}] = RSelfRec `member` rkind || depth > 0 || not (null typ.bound) @@ -860,9 +865,10 @@ genLet jret rm x binds = do after = concat . reverse . takeWhile (not . needClassForLet) . reverse $ envxx -- the remaining elements must be in a class incls = concat (take (length envxx - length after) envxx) - genLetEnvs jret rm before incls after letex binds + genLetEnvs jret rm (map SymbolT.V before) (map SymbolT.V incls) (map SymbolT.V after) letex binds where - toSym = mapM U.findV + unsafeToSymV s = case s of { SymbolT.V x -> x; } + toSym = mapM (fmap unsafeToSymV . U.findV) (letex, envqq) = collect x [] -- collect the environments of nested lets in reverse order collect ∷ ExprT → [[QName]] → (ExprT,[[QName]]) @@ -870,7 +876,11 @@ genLet jret rm x binds = do collect x acc = (x, acc) genLetEnvs ∷ (JExpr→[JStmt]) → JType → [Symbol] → [Symbol] → [Symbol] → ExprT → TreeMap Int Binding → StG [JStmt] -genLetEnvs jret rm before inclass after ex binds = do +genLetEnvs jret rm before' inclass' after' ex binds = do + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + let before = map unsafeToSymV before' + inclass = map unsafeToSymV inclass' + after = map unsafeToSymV after' g ← getST let bbinds = fold (mkbind g JAtom) binds before bdecls ← map (map JLocal) <$> mapM (gen false bbinds) before @@ -882,21 +892,21 @@ genLetEnvs jret rm before inclass after ex binds = do where -- generate declaration of inner function or caf - gen ∷ Bool → TreeMap Int Binding → Symbol → StG [JDecl] + gen :: Bool -> TreeMap Int Binding -> SymV Global -> StG [JDecl] gen mutual binds sym | sym.depth == 0 = innerCaf sym binds mutual - | otherwise = localFun sym binds - --otherwise = innerFun sym binds + | otherwise = localFun sym binds -- set up simple bindings, generate the mutually dependent items in a class -- instantiate that class and make bindings that access the bindings from outside - genLetClass ∷ TreeMap Int Binding → [Symbol] → StG (TreeMap Int Binding,[JStmt]) + genLetClass ∷ TreeMap Int Binding → [SymV Global] → StG (TreeMap Int Binding,[JStmt]) genLetClass binds [] = pure (binds, []) genLetClass binds syms = do g <- getST - forM syms (changeSym . _.{rkind ← (BitSet.`unionE` RMethod)}) + forM syms (changeSym . SymbolT.V . _.{rkind ← (BitSet.`unionE` RMethod)}) -- refresh the symbols - syms ← mapM U.findV (map _.name syms) + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + syms <- mapM (fmap unsafeToSymV . U.findV) (map _.name syms) u <- uniqid let base = "Let$" ++ show u name = "let$" ++ show u @@ -915,7 +925,7 @@ genLetEnvs jret rm before inclass after ex binds = do -- stmts <- genStmts jret rm ex letbinds pure (letbinds, [JLocal letcl, JLocal var]) - mkbind :: Global -> (String -> JX) -> TreeMap Int Binding -> Symbol -> TreeMap Int Binding + mkbind :: Global -> (String -> JX) -> TreeMap Int Binding -> SymV Global -> TreeMap Int Binding mkbind g prefix binds sym = insert sym.sid bind binds where bind = Bind{stype=nicer sym.typ g, @@ -926,7 +936,7 @@ genLetEnvs jret rm before inclass after ex binds = do mode = if sym.depth > 0 then strict else if RValue `member` sym.rkind then strict else lazy - name = (symJavaName g sym).base + name = (symJavaName g $ SymbolT.V sym).base --- genExpression returnexpression f expr binds @@ -1021,7 +1031,8 @@ etaWrap ex sigs binds (rm@Func{gargs}) = do <+> text " as " <+> text (show rm) ) uids ← replicateM n uniqid - let syms = [ (U.patLocal (pos.change VARID ("η" ++ show u)) u "η").{typ=s} + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + let syms = [ (unsafeToSymV $ U.patLocal (pos.change VARID ("η" ++ show u)) u "η").{typ=s} | (u,s) <- zip uids sigs] atoms = map (JAtom . ("η$" ++) . show) uids ctoms = map (JAtom . ("ctx$" ++) . show) uids @@ -1039,9 +1050,9 @@ etaWrap ex sigs binds (rm@Func{gargs}) = do subrm = case drop n gargs of [x] -> lazy x gs -> Func gs - fake = (U.patLocal (getpos ex) 0 "\\lambda").{depth=a,typ=ft} - mapM_ SymTab.enter syms - call ← compiling fake (genExpr false subrm nex newbinds) + fake = (unsafeToSymV $ U.patLocal (getpos ex) 0 "\\lambda").{depth=a,typ=ft} + mapM_ (SymTab.enter . SymbolT.V) syms + call ← compiling (SymbolT.V fake) (genExpr false subrm nex newbinds) let lambda = JCast (boxed rm) JLambda{fargs = cargs ++ fargs, code} apply | n > a+length cargs = JInvoke (JX.xmem "apply" call.jex) (drop (n-a-length cargs) atoms) @@ -1074,6 +1085,7 @@ etaWrap ex _ binds rm = E.fatal (getpos ex) (text "etaWrap: " wrapHigher ∷ Bool → ExprT → TreeMap Int Binding → [Context] → Sigma → StG Binding wrapHigher rflg ex binds tctxs sigma = do g <- getST + let unsafeToSymV s = case s of { SymbolT.V x -> x; } let depth = length tctxs ctxNames = take depth (getCtxs g) ctxLnams = map ("l" ++) ctxNames @@ -1088,13 +1100,13 @@ wrapHigher rflg ex binds tctxs sigma = do (map (JX.invoke [] . JX.xmem "call" . JAtom) ctxLnams) jfunc = sigmaJT g sigma innerjt = lazy (funcResult jfunc) -- rhoJT g sigma.rho.{context = []} - fakesym = (U.patLocal (getpos ex) 0 "\\rankN").{depth = 0, typ = sigma} + fakesym = (unsafeToSymV $ U.patLocal (getpos ex) 0 "\\rankN").{depth = 0, typ = sigma} E.logmsg TRACEG (getpos ex) (text "wrapHigher: " <+> text (nicer ex g) <+/> text " :: " <+> text (nice sigma g) <+/> text " @@ " <+> text (show jfunc) <+/> text (nicerctx tctxs g)) - body <- compiling fakesym (genExpr rflg innerjt ex binds) + body <- compiling (SymbolT.V fakesym) (genExpr rflg innerjt ex binds) let eval = JLambda{fargs, code = Right JBlock{stmts=map JLocal assigns ++ [JReturn body.jex]}} pure (newBind g sigma (JCast jfunc eval)).{jtype = jfunc} @@ -1128,6 +1140,7 @@ genExpr rflg rm ex binds = do <+> text (nicer ft g) <+> text " @@ " <+> text (show rm)) + let unsafeToSymV s = case s of { SymbolT.V x -> x; } let genArgBind ∷ Sigma → JType → ExprT → StG Binding genArgBind sig arm aex @@ -1136,7 +1149,7 @@ genExpr rflg rm ex binds = do Just ft ← aex.typ = case aex of (exx@Vbl{name = Local{uid}}) | Just bind <- lookup uid binds, - Nothing <- g.findit exx.name >>= _.expr, -- pattern bound + Nothing <- g.findit exx.name >>= _.expr . unsafeToSymV, -- pattern bound not bind.ftype.bound.null, -- forall a. .... -- make sure the contexts are in the right order -- we can't pass forall a b. (Num a, Num b) => @@ -1231,51 +1244,45 @@ genExpr rflg rm ex binds = do -- Local Variables are being looked up in the bindings Vbl{name=Local{uid, base}, pos, typ} | Just b ← lookup uid binds = do - --E.logmsg TRACEG pos (text "genExpr bound at " <+> nicest g b.ftype) - --E.logmsg TRACEG pos (text "not (null bound) " <+> (text . show) (not (null b.ftype.bound))) - --let mbsym = g.findit ex.name - --E.logmsg TRACEG pos (text "g.findit ex.name " <+> (text . show . fmap (const ())) mbsym) - --let cond = case mbsym of - -- Just sym -> not (isJust sym.expr && sym.depth > 0 && RMethod `member` sym.rkind) - -- _ -> false - --E.logmsg TRACEG pos (text "not local method " <+> (text . show) cond) + let unsafeToSymV s = case s of { SymbolT.V x -> x; } case b.ftype of ForAll{bound, rho} | not (null bound), - Just sym ← g.findit ex.name, + Just sym <- g.findit ex.name, -- exclude local methods - not (isJust sym.expr && sym.depth > 0 && RMethod `member` sym.rkind), - b' ← if sym.depth == 0 && RMethod `member` sym.rkind + not (isJust (unsafeToSymV sym).expr && (unsafeToSymV sym).depth > 0 && RMethod `member` (unsafeToSymV sym).rkind), + b' ← if (unsafeToSymV sym).depth == 0 && RMethod `member` (unsafeToSymV sym).rkind then b.{jex ← JX.invoke []} -- evaluate method CAFs else b = instPatternBound pos b' ft >>= result ForAll{bound, rho} | not (null bound), - Nothing ← g.findit ex.name >>= _.expr, -- pattern bound + Nothing <- g.findit ex.name >>= _.expr . unsafeToSymV, -- pattern bound = instPatternBound pos b ft >>= result _ | Func{} ← b.jtype, - Just sym ← g.findit ex.name, - RMethod `member` sym.rkind, - sym.depth > 0 + Just sym <- g.findit ex.name, + RMethod `member` (unsafeToSymV sym).rkind, + (unsafeToSymV sym).depth > 0 = etaWrap (snd (U.returnType ft.rho)) _ = result b | otherwise = do E.error pos (text "FATAL COMPILER ERROR " <+> text (nicer ex g) <+> text " not bound") - sym <- U.findV ex.name + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> U.findV ex.name result (newBind g sym.typ (JAtom ("UNBOUND." ++ ex.name.base))) Con{pos, name} - | Just (sym@SymD{cid, flds}) ← g.findit name = + | Just (SymbolT.D (sym@SymD{cid, flds})) <- g.findit name = if (length flds > 0) then etaWrap (snd (U.returnType ft.rho)) else if case g.findit name.tynm of Just (SymbolT.T symt) -> symt.enum Nothing -> false then do - let item = symJavaName g sym + let item = symJavaName g (SymbolT.D sym) stref = JX.staticMember item result (newBind g ft stref) else do @@ -1283,7 +1290,7 @@ genExpr rflg rm ex binds = do -- rhoctx = substRho subst sym.typ.rho targs = map (boxed . tauJT g . substTau subst) sym.typ.tvars -- contexts = map (reducedCtx g) rhoctx.context - item = Ref (symJavaName g sym) targs + item = Ref (symJavaName g (SymbolT.D sym)) targs mk = JX.static "mk" item call = JInvoke mk [] result (newBind g ft.{rho ← _.{context=[]}} call) @@ -1302,9 +1309,7 @@ genExpr rflg rm ex binds = do -- bind = (newBind g ret inst).{jtype = retjt, jex ← coerce} -- pure bind Vbl{pos,name} - --| Just (sym@SymV{depth = 0, nativ = Just _}) = do - -- nativeCall g sym TreeMap.empty [] - | Just (sym@SymV{}) ← g.findit name = do + | Just (SymbolT.V sym) <- g.findit name = do let subst = unifySigma g sym.typ ft rhoctx = substRho subst sym.typ.rho targs = map (boxed . tauJT g . substTau subst) sym.typ.tvars @@ -1312,15 +1317,15 @@ genExpr rflg rm ex binds = do if (sym.depth > 0) then etaWrap (snd (U.returnType (rhoTauInSigma ft).rho)) else if isJust sym.nativ - then if wrappedOnly g sym + then if wrappedOnly g (SymbolT.V sym) then do - let method = symJavaName g sym + let method = symJavaName g (SymbolT.V sym) stref = (JX.staticMember method).{targs} call = newBind g ret (JInvoke stref []) bind = if isStrictJT rm then call else delayBind call result bind - else result (nativeCall g sym subst []) + else result (nativeCall g (SymbolT.V sym) subst []) else do let contexts = map (reducedCtx g) rhoctx.context kret = kArity (sigmaKind sym.typ) @@ -1332,7 +1337,7 @@ genExpr rflg rm ex binds = do ctxs ← mapM (resolveConstraint pos) contexts case sym.name of MName{tynm,base} - | Just (SymC {tau}) <- g.findit tynm, prevtargs ← targs + | Just (SymbolT.C SymC{tau}) <- g.findit tynm, prevtargs <- targs = do let spec = isSpecialClassName tynm -- Our class member will have a phantom type var if from a special class @@ -1361,7 +1366,7 @@ genExpr rflg rm ex binds = do ) result bind other = do - let item = symJavaName g sym + let item = symJavaName g (SymbolT.V sym) stref = (JX.staticMember item).{targs} call0 | null targs, null ctxs = newBind g ft stref @@ -1399,10 +1404,10 @@ genExpr rflg rm ex binds = do args = tail flat -- is this a getter of a product type?? getter fun = case fun of - Vbl{name} - | Just SymV{name=MName{tynm, base}} ← g.findit name, - Just SymT{env,product=true} ← g.findit tynm = - base `elem` [ s | SymD{flds} ← values env, f ← flds, s ← f.name ] + Vbl{name} + | Just (SymbolT.V SymV{name=MName{tynm, base}}) <- g.findit name, + Just (SymbolT.T SymT{env, product=true}) <- g.findit tynm -> + base `elem` [ s | SymbolT.D symd <- values env, f <- symd.flds, s <- f.name ] other -> false -- determine whether result so far needs nesting, and which one @@ -1418,8 +1423,9 @@ genExpr rflg rm ex binds = do | otherwise = result (delayBind bind) -- possibly nested! -- constructors genApp (con@Con {pos, name, typ = Just csigma}) args = do - sym ← U.findD name - symt ← U.findT sym.name.tynm + let unsafeToSymD s = case s of { SymbolT.D x -> x; } + sym <- unsafeToSymD <$> U.findD name + symt <- U.findT sym.name.tynm () ← E.logmsg TRACEG pos ( text "genApp: constructor " <+> text name.base <+> text " :: " <+> text (nice sym.typ g) @@ -1493,7 +1499,7 @@ genExpr rflg rm ex binds = do abinds ← sequence (zipWith3 genArgBind sigs argjts args) let arguments = ctxs ++ map _.jex abinds - let cons = symJavaName g sym + let cons = symJavaName g (SymbolT.D sym) jref = Ref{jname = cons, gargs = targs} make = JX.static "mk" jref call = JInvoke make arguments @@ -1502,7 +1508,8 @@ genExpr rflg rm ex binds = do _ = noGenApp "not yet" con args genApp (vbl@Vbl {pos, name, typ = Just vsigma}) args = do - symv ← U.findV name + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + symv <- unsafeToSymV <$> U.findV name --vsigma ← (_.{bound=[]} . fst) <$> kiSigma [] [] xsigma --ft ← (_.{bound=[]} . fst) <$> kiSigma [] [] ft let symtyp = rhoTauInSigma symv.typ @@ -1655,7 +1662,7 @@ genExpr rflg rm ex binds = do -- class operations SymV{name = MName{tynm,base}} - | Just (SymC {tau}) <- g.findit tynm + | Just (SymbolT.C SymC{tau}) <- g.findit tynm = do let inst = JInvoke get.{targs} (tail arguments) targs = map (substJT jsubst . TArg) @@ -1664,16 +1671,12 @@ genExpr rflg rm ex binds = do get = JX.jexmem (head ctxs) (latinF ++ mangled base) bind = (newBind g ret inst).{jtype = retjt} appResult safetc bind - --| Nothing ← g.findit tynm = noGenApp (nicer tynm g ++ " not found") fun args - --| Just other ← g.findit tynm, - -- traceLn (tynm.base ++ " is a " ++ (nicer other g)) = undefined - -- native functions SymV{nativ = Just item} → do - if wrappedOnly g symv + if wrappedOnly g (SymbolT.V symv) then do - let method = symJavaName g symv + let method = symJavaName g (SymbolT.V symv) stref = (JX.staticMember method).{targs} call0 = newBind g ret (JInvoke stref arguments) @@ -1681,16 +1684,16 @@ genExpr rflg rm ex binds = do appResult true call else do let call0 - | wrapped g symv = case wrapCode g JEx res symv subst arguments of + | wrapped g (SymbolT.V symv) = case wrapCode g JEx res (SymbolT.V symv) subst arguments of (JEx ex:_) -> newBind g ret ex _ -> error "unexpected wrapCode result" - | otherwise = nativeCall g symv subst arguments + | otherwise = nativeCall g (SymbolT.V symv) subst arguments call = call0.{jtype = retjt} appResult true call -- ordinary functions SymV{} → do - let method = symJavaName g symv + let method = symJavaName g $ SymbolT.V symv stref = (JX.staticMember method).{targs} call0 = newBind g ret (JInvoke stref arguments) @@ -1707,15 +1710,16 @@ genExpr rflg rm ex binds = do result (newBind g ft (JAtom "cannot(gen,application)")) Lam{} | Func{gargs} ← boxed rm = do + let unsafeToSymV s = case s of { SymbolT.V x -> x; } let n = length gargs - 1 us ← map (("arg$" ++) . show) <$> replicateM n uniqid let (_, sigs) = U.returnTypeN n ft.rho args = zip4 (repeat attrFinal) sigs (map lazy (take n gargs)) us - fake = (U.patLocal (getpos ex) 0 "\\lambda").{depth=n} + fake = (unsafeToSymV $ U.patLocal (getpos ex) 0 "\\lambda").{depth=n} grm = lazy $ case drop n gargs of [x] → x ys → Func ys - stmts <- compiling fake (genLambda grm ex args binds) + stmts <- compiling (SymbolT.V fake) (genLambda grm ex args binds) let jlam = JLambda{fargs=args, code = Right JBlock{stmts}} result (newBind g ft (JCast (boxed rm) jlam)).{jtype = boxed rm} diff --git a/frege/compiler/instances/Nicer.fr b/frege/compiler/instances/Nicer.fr index a7901b26..6984bc12 100644 --- a/frege/compiler/instances/Nicer.fr +++ b/frege/compiler/instances/Nicer.fr @@ -118,7 +118,7 @@ private showex nicest x global = showprec 17 x where where -- kt = keys t vt = [ s | k <- kt, s <- global.findit k ] - sv ((vsym@SymV{}):_) + sv (SymbolT.V vsym:_) | Just x <- vsym.gExpr global = if not nicest then nice x global else nicer x global -- NOT "showprec 17 x" as this imposes diff --git a/frege/compiler/passes/Easy.fr b/frege/compiler/passes/Easy.fr index dbdede78..c377b92f 100644 --- a/frege/compiler/passes/Easy.fr +++ b/frege/compiler/passes/Easy.fr @@ -3,6 +3,7 @@ module frege.compiler.passes.Easy where -- generated by Splitter import frege.Prelude hiding(<+>) import frege.data.TreeMap as TM(TreeMap, TreeSet, lookup, insert, keys, values, each, fromKeys, including, contains, union) +import frege.compiler.common.Lens (view) import frege.compiler.enums.Flags import frege.compiler.enums.Literals import frege.compiler.enums.CaseKind @@ -61,20 +62,21 @@ import frege.compiler.common.Trans -} pass = do g <- getST + let unsafeToSymV s = case s of { SymbolT.V x -> x; } -- set lambdadepth for each symbol let collectedvars = allourvars g - foreach collectedvars depthSym + foreach collectedvars (depthSym . unsafeToSymV) -- check instance member's depth g <- getST - let imembers = [ imem | inst@SymI{} <- values g.thisTab, + let imembers = [ imem | SymbolT.I inst <- values g.thisTab, g.our inst.name, imem <- values inst.env ] foreach imembers checkDepth -- make all expressions easy g <- getST let collectedvars = allourvars g - foreach collectedvars easySym + foreach collectedvars (easySym . unsafeToSymV) stio ("expressions", length collectedvars) @@ -86,52 +88,50 @@ easySym (vsym@SymV {pos}) x <- dx if isOn g.options.flags INLINE && not (defaultMethod vsym.name g) then do ux <- inlined x >>= easyExpression - changeSym vsym.{expr = Just (return ux)} + changeSym $ SymbolT.V vsym.{expr = Just (return ux)} else do nx <- easyExpression x - changeSym vsym.{expr = Just (return nx)} + changeSym $ SymbolT.V vsym.{expr = Just (return nx)} | otherwise = stio () where defaultMethod name g = case name of MName tname _ -> case g.findit tname of - Just SymC{} -> true - _ -> false + Just (SymbolT.C _) -> true + _ -> false _ -> false -easySym sym = do - g <- getST - E.fatal sym.pos (text ("easySym no SymV : " ++ sym.nice g)) - -checkDepth (vsym@SymV {pos, name = MName inst base}) = do +checkDepth (SymbolT.V (vsym@SymV {pos, name = MName inst base})) = do g <- getST - cmeth <- classMethodOfInstMethod pos inst base + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + cmeth <- unsafeToSymV <$> classMethodOfInstMethod pos inst base when (cmeth.depth > vsym.depth) do - U.symWarning E.hint vsym (msgdoc ( - nicer vsym g ++ " has depth " ++ show vsym.depth + U.symWarning E.hint (SymbolT.V vsym) (msgdoc ( + nicer (SymbolT.V vsym) g ++ " has depth " ++ show vsym.depth ++ " while " - ++ nicer cmeth g ++ " has depth " ++ show cmeth.depth)) + ++ nicer (SymbolT.V cmeth) g ++ " has depth " ++ show cmeth.depth)) when (cmeth.depth < vsym.depth) do - changeSym vsym.{depth = cmeth.depth} + changeSym $ SymbolT.V vsym.{depth = cmeth.depth} return () -checkDepth (vsym@SymL {pos, alias, name = MName inst base}) = do +checkDepth (SymbolT.L (vsym@SymL {pos, alias, name = MName inst base})) = do g <- getST - cmeth <- classMethodOfInstMethod pos inst base + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + cmeth <- unsafeToSymV <$> classMethodOfInstMethod pos inst base rmeth <- U.findVD alias - let d = if rmeth.{depth?} then rmeth.depth else U.arity rmeth + let d = case rmeth of { SymbolT.V SymV{depth} -> depth; _ -> U.arity rmeth; } when (cmeth.depth != d) do E.error pos (msgdoc ( nicer rmeth g ++ " is not a suitable implementation for " ++ nicer vsym.name g ++ " because it has depth " ++ show d ++ " while " - ++ nicer cmeth g ++ " has depth " ++ show cmeth.depth)) + ++ nicer (SymbolT.V cmeth) g ++ " has depth " ++ show cmeth.depth)) return () checkDepth bad = do g <- getST - E.fatal bad.pos (text(nicer bad g ++ " must not occur in instances.")) + E.fatal (view SymbolT.pos bad) (text(nicer bad g ++ " must not occur in instances.")) depthSym (vsym@SymV {pos}) @@ -149,26 +149,26 @@ depthSym (vsym@SymV {pos}) ++ ") of its type " ++ nicer typ g)) E.hint vsym.pos (msgdoc ("This is probably a compiler error.")) if (depth >= length sigmas) - then changeSym vsym.{expr = Just (return nx), typ, depth} -- fine, unless error + then changeSym $ SymbolT.V vsym.{expr = Just (return nx), typ, depth} -- fine, unless error else if depth == 0 && vsym.name.isLocal - then changeSym vsym.{expr = Just (pure nx), depth} -- don't change local syms that are not lambdas + then changeSym $ SymbolT.V vsym.{expr = Just (pure nx), depth} -- don't change local syms that are not lambdas else do g <- getST -- depth < sigmas, eta expand it newx <- etaExpand nx let newd = U.lambdaDepth newx - E.logmsg TRACE9 (vsym.pos) (text ("eta expanded " + E.logmsg TRACE9 vsym.pos (text ("eta expanded " ++ nice vsym.name g ++ "::" ++ nice typ g ++ " to lambda depth " ++ show newd)) E.logmsg TRACE9 vsym.pos (text ("old expr: " ++ nice nx g ++ " :: " ++ maybe "nix" (flip nice g) nx.typ)) E.logmsg TRACE9 vsym.pos (text ("new expr: " ++ nice newx g ++ " :: " ++ maybe "nix" (flip nice g) nx.typ)) - changeSym vsym.{expr = Just (return newx), typ, depth = newd} + changeSym $ SymbolT.V vsym.{expr = Just (return newx), typ, depth = newd} when (newd != (length sigmas)) do - E.fatal vsym.pos (text (nice vsym g ++ ": after eta expansion depth=" + E.fatal vsym.pos (text (nice (SymbolT.V vsym) g ++ ": after eta expansion depth=" ++ show newd ++ ", length sigmas=" ++ show (length sigmas) ++", turn on -x9")) - | otherwise = changeSym vsym.{depth = length sigmas} + | otherwise = changeSym $ SymbolT.V vsym.{depth = length sigmas} where typ = vsym.typ.{rho <- unTau} -- a -> (b->c) --> a -> b -> c (_, sigmas) = U.returnType typ.rho @@ -176,21 +176,13 @@ depthSym (vsym@SymV {pos}) depthX x | Let {env} <- x = do g ← getST - syms <- mapSt U.findV env + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + syms <- mapSt (fmap unsafeToSymV . U.findV) env foreach syms depthSym stio (Left x) | otherwise = stio (Left x) -depthSym sym = do - g <- getST - E.fatal sym.pos (text ("depthSym no SymV : " ++ sym.nice g)) - - - - - - --- copy expr and re-establish type recycle newpos expr rho = do g <- getST @@ -256,13 +248,14 @@ mkSimple x = do mkLet :: Expr -> (Expr -> Expr) -> StG Expr mkLet ex f = do uid <- uniqid + let unsafeToSymV s = case s of { SymbolT.V x -> x; } let pos = getpos ex - patsym = U.patLocal pos uid pat.var + patsym = unsafeToSymV $ U.patLocal pos uid pat.var pat = PVar{pos, uid, var="tmp"} var = Vbl{pos, name=sym.name, typ=ex.typ} aex = f var sym = patsym.{typ = fromMaybe pSigma ex.typ, expr = Just (return ex)} - enter sym + enter $ SymbolT.V sym return $! Let{env=[sym.name], ex=aex, typ=aex.typ} @@ -342,8 +335,8 @@ inlined = U.mapEx true inline Vbl {pos = newpos, name, typ = Just sig} <- fun, not name.isLocal = do g <- getST - sym <- U.findV name - -- E.logmsg TRACE9 (getpos v) (text ("can we inline " ++ nicer sym g ++ "?")) + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> U.findV name case sym.expr of Just dx -- we can't inline any class methods @@ -353,7 +346,7 @@ inlined = U.mapEx true inline -- e.g. display "foo" = "foo" -- and show "foo" = "\"foo\"" | MName tname _ <- name, - Just SymC{} <- g.findit tname = return (Left app) + Just (SymbolT.C _) <- g.findit tname = return (Left app) | sym.exported, d <- length rest, d >= sym.depth || d >= sym.depth-1 && sym.name `elem` superOpt = do @@ -366,10 +359,11 @@ inlined = U.mapEx true inline inline (vbl@Vbl{pos, name, typ = Just sig}) | not name.isLocal = do g <- getST - sym <- U.findV name + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> U.findV name case sym.expr of Just dx | MName tname _ <- name, - Just SymC{} <- g.findit tname = return (Left vbl) + Just (SymbolT.C _) <- g.findit tname = return (Left vbl) | sym.exported, sym.depth == 0 = do E.logmsg TRACE9 pos (text ("replace " ++ nice vbl g ++ " :: " ++ nicer sig g)) @@ -533,7 +527,8 @@ mkEasy (x@App f arg t) = do mkEasy (x@Let{env,ex}) = do -- TODO: handle non-recursive let/case/if g <- getST - mapM U.findV env >>= mapM_ easySym + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + mapM (fmap unsafeToSymV . U.findV) env >>= mapM_ easySym mkEasy ex >>= pure . x.{ex=} diff --git a/frege/compiler/passes/Enter.fr b/frege/compiler/passes/Enter.fr index 789ae987..0dbaa8c5 100644 --- a/frege/compiler/passes/Enter.fr +++ b/frege/compiler/passes/Enter.fr @@ -5,6 +5,7 @@ import frege.Prelude hiding (<+>) import frege.data.TreeMap as TM(TreeMap, keys, values, insert) import frege.data.List as DL(uniqBy, sort, sortBy) +import frege.compiler.common.Lens (preview, unsafePartialView, view) import frege.compiler.enums.Flags as Compilerflags(TRACE3, TRACE4, isOn, isOff) import frege.compiler.enums.TokenID(defaultInfix) @@ -50,9 +51,7 @@ symbols tree = fold (+) 0 (map oneSym (values tree)) oneSym :: Symbol -> Int -oneSym sym - | sym.{env?} = 1 + symbols sym.env - | otherwise = 1 +oneSym sym = 1 + maybe 0 symbols (preview SymbolT.env sym) isInstOrDerive :: DefinitionS -> Bool @@ -76,9 +75,10 @@ private transKind kind = case kind of link :: Symbol -> StG () link sym = do g <- getST - E.logmsg TRACE3 sym.pos (text ("`" ++ sym.name.base ++ "` link to " ++ sym.nice g)) - ST.enter (SymL {sid=0, pos=sym.pos, vis=sym.vis, -- doc=Nothing, - name=VName g.thisPack sym.name.base, alias=sym.name}) + E.logmsg TRACE3 (view SymbolT.pos sym) (text ("`" ++ (view SymbolT.name sym).base ++ "` link to " ++ sym.nice g)) + ST.enter $ SymbolT.L + (SymL {sid=0, pos=view SymbolT.pos sym, vis=view SymbolT.vis sym, -- doc=Nothing, + name=VName g.thisPack (view SymbolT.name sym).base, alias=view SymbolT.name sym}) --- reorder definitions so that annotations come last @@ -121,9 +121,11 @@ enter1FunDcl fname (d@FunDcl {positions}) = case funbinding d of Just name -> do let qname = fname name.value foreach positions (register qname) - ST.enter (vSym (positionOf name) qname).{vis=d.vis, doc=d.doc} - - sonst + case vSym (positionOf name) qname of + SymbolT.V symv -> + ST.enter $ SymbolT.V symv.{vis=d.vis, doc=d.doc} + + sonst | not (patbinding d), Vbl{name=Simple excl} <- d.lhs, excl.value == "!" || excl.value=="?", @@ -131,8 +133,10 @@ enter1FunDcl fname (d@FunDcl {positions}) = case funbinding d of Just name <- funbinding d.{lhs=pat, pats=[]} -> do let !qname = fname name.value register qname name - ST.enter (vSym (positionOf name) qname).{vis=d.vis, doc=d.doc, - strsig = if excl.value == "!" then S[] else U} + case vSym (positionOf name) qname of + SymbolT.V symv -> + ST.enter $ SymbolT.V symv.{vis=d.vis, doc=d.doc, + strsig = if excl.value == "!" then S[] else U} | otherwise = do g <- getST E.error (getpos d.lhs) (msgdoc ("Strange declaration: " @@ -150,8 +154,10 @@ enter1NatDcl fname (d@NatDcl {pos}) = do changeST Global.{ sub <- SubSt.{ idKind <- insert (KeyTk pos.first) (Right qname)}} - ST.enter (vSym pos qname).{vis=d.vis, doc=d.doc, - nativ=Just d.meth, pur=d.isPure} + case vSym pos qname of + SymbolT.V symv -> + ST.enter $ SymbolT.V + symv.{vis=d.vis, doc=d.doc, nativ=Just d.meth, pur=d.isPure} enter1AnnDcl :: (String -> QName) -> AnnDcl -> StG () enter1AnnDcl fname (d@AnnDcl {pos}) = do @@ -164,23 +170,26 @@ enter1AnnDcl fname (d@AnnDcl {pos}) = do merge a _ _ _ = a case g.findit qname of - Just (sym@SymV {nativ = Nothing, anno = false}) -> do - when (sym.vis != d.vis) do + Just (SymbolT.V (symv@SymV{nativ = Nothing, anno = false})) -> do + when (symv.vis != d.vis) do E.error pos (msgdoc ("Visibility of annotation and implementation must match," - ++ " implementation was announced as " ++ show sym.vis - ++ " at line " ++ show sym.pos)) - ST.changeSym sym.{pos <- d.pos.merge, - doc = merge sym.doc sym.pos d.doc d.pos, + ++ " implementation was announced as " ++ show symv.vis + ++ " at line " ++ show symv.pos)) + ST.changeSym $ SymbolT.V + symv.{pos <- d.pos.merge, + doc = merge symv.doc symv.pos d.doc d.pos, anno = true} changeST Global.{ sub <- SubSt.{ - idKind <- insert (KeyTk pos.first) (Right sym.name)}} - Just (sym@SymV {anno = true}) -> + idKind <- insert (KeyTk pos.first) (Right symv.name)}} + Just (sym@(SymbolT.V SymV{anno = true})) -> E.error pos (msgdoc ("cannot annotate " ++ sym.nice g ++ " again")) Just sym -> E.error pos (msgdoc ("cannot annotate " ++ sym.nice g)) Nothing -> do -- either class method or implementation missing. - ST.enter (vSym d.pos qname).{vis=d.vis, doc=d.doc, anno = true} + case vSym d.pos qname of + SymbolT.V symv -> + ST.enter $ SymbolT.V symv.{vis=d.vis, doc=d.doc, anno = true} changeST Global.{ sub <- SubSt.{ idKind <- insert (KeyTk pos.first) (Right qname)}} @@ -191,7 +200,8 @@ enter1ClaDcl fname (d@ClaDcl {pos}) = do let tname = TName g.thisPack d.name changeST Global.{sub <- SubSt.{idKind <- insert (KeyTk pos.first) (Right tname)}} - ST.enter (SymC {sid=0, pos=d.pos, vis=d.vis, doc=d.doc, name=tname, + ST.enter $ SymbolT.C + (SymC {sid=0, pos=d.pos, vis=d.vis, doc=d.doc, name=tname, tau=transTVar d.clvar, supers=[], insts=[], env=empty}) let vdefs = map (\def -> def.chgVis $ max d.vis) d.members @@ -223,10 +233,12 @@ enter1ClaDcl fname (d@ClaDcl {pos}) = do define a method with the same name.) -} g <- getST - let vs = (filter (maybe true (not • Symbol.{alias?}) - • g.find • VName g.thisPack - • QName.base • Symbol.name) - • values • maybe empty Symbol.env) (g.findit tname) + let isSymL (SymbolT.L _) = true + isSymL _ = false + let vs = (filter (maybe true (not . isSymL) + . g.find . VName g.thisPack + . QName.base . view SymbolT.name) + . values . maybe empty (unsafePartialView SymbolT.env)) (g.findit tname) E.logmsg TRACE3 pos (text ("enter1: ClaDcl: vs=" ++ show (map (flip nice g) vs))) foreach (vs) link @@ -235,7 +247,8 @@ enter1InsDcl !fname (!d@InsDcl {pos = !pos}) = do g <- getST let tname = TName g.thisPack (insName d) - ST.enter (SymI {pos=d.pos, vis=d.vis, doc=d.doc, name=tname, + ST.enter $ SymbolT.I + (SymI {pos=d.pos, vis=d.vis, doc=d.doc, name=tname, sid=0, clas=fname "", typ=pSigma, env=empty}) enter (MName tname) d.defs @@ -246,7 +259,7 @@ enter1InsDcl !fname (!d@InsDcl {pos = !pos}) = do Just (SymbolT.T SymT{name=typnm}) -> do foreach d.defs (mklinkd typnm (MName tname)) case g.findit clas of - Just (SymC {name,env}) -> do + Just (SymbolT.C _) -> do return () -- let cmeths = [ sym.name.base | sym@SymV{anno=true} <- values env ] -- foreach (map (QName.base • Symbol.name) (values env)) (mklink typnm (MName name)) @@ -323,16 +336,18 @@ enter1DatDcl fname (d@DatDcl {pos}) = do register (p, n) = changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk (Position.first p)) (Right (mname n))}} foreach fnms (checkunique dcon.pos (mname dcon.name) fnms) - ST.enter (SymD {name = mname dcon.name, typ=pSigma, flds = fs, + ST.enter $ SymbolT.D + (SymD {name = mname dcon.name, typ=pSigma, flds = fs, cid=cid, sid=0, strsig = ssig, op = defaultInfix, pos=dcon.pos, vis=dcon.vis, doc=dcon.doc}) changeST Global.{ sub <- SubSt.{ idKind <- insert (KeyTk dcon.pos.first) (Right cqname)}} foreach fnps register - when (dcon.vis == Public) - (ST.enter (SymL {name = VName g.thisPack dcon.name, alias = cqname, - sid=0, pos=dcon.pos, vis=dcon.vis, {-doc=dcon.doc-}})) + when (dcon.vis == Public) $ + ST.enter $ SymbolT.L + (SymL {name = VName g.thisPack dcon.name, alias = cqname, + sid=0, pos=dcon.pos, vis=dcon.vis, {-doc=dcon.doc-}}) checkunique :: Position -> QName -> [String] -> String -> StG () checkunique pos con fs f = do when (1 < (length • filter (f==)) fs) do @@ -370,7 +385,8 @@ enter1TypDcl fname (d@TypDcl {pos}) = do changeST Global.{ sub <- SubSt.{ idKind <- insert (KeyTk pos.first) (Right dname)}} - ST.enter (SymA {sid=0, pos=d.pos, vis=d.vis, doc=d.doc, + ST.enter $ SymbolT.A + (SymA {sid=0, pos=d.pos, vis=d.vis, doc=d.doc, name = dname, typ = pSigma, kind, vars = map transTVar d.vars}) diff --git a/frege/compiler/passes/Fields.fr b/frege/compiler/passes/Fields.fr index 151397dd..b2bcc828 100644 --- a/frege/compiler/passes/Fields.fr +++ b/frege/compiler/passes/Fields.fr @@ -65,8 +65,8 @@ chgddef (d@DatDcl {pos}) = do where work :: Global -> Symbol -> ([FunDcl], [SName]) work g (SymbolT.T (dsym@SymT {env})) = - let cons = [ sym | sym@SymD {sid} <- values env ] - fields = (uniqBy (using fst) • sort) [ (f,p) | con <- cons, Field {pos = p, name = Just f} <- Symbol.flds con ] + let cons = [ sym | SymbolT.D sym <- values env ] + fields = (uniqBy (using fst) . sort) [ (f,p) | con <- cons, Field {pos = p, name = Just f} <- con.flds ] in ([ d | (f,p) <- fields, d <- gen g p dsym.name cons f], if length cons == 1 then [ With1 (p.change CONID dsym.name.base).first @@ -74,7 +74,7 @@ chgddef (d@DatDcl {pos}) = do s <- ["chg$", "upd$"]] else []) work _ _ = error "work: need a SymT" - gen :: Global -> Position -> QName -> [Symbol] -> String -> [FunDcl] + gen :: Global -> Position -> QName -> [SymD Global] -> String -> [FunDcl] gen g fpos tname cons f = let pos = fpos.{first <- Token.{offset <- succ}} model = FunDcl {vis = Public, positions = [fpos.first], @@ -92,22 +92,22 @@ chgddef (d@DatDcl {pos}) = do -- -------------- utility functions --------------- -- get the doc for field f getdoc = case [ d | con <- cons, - Field {name = Just g, doc = Just d} <- Symbol.flds con, + Field {name = Just g, doc = Just d} <- con.flds, f == g ] of [] -> Just ("access field @" ++ f ++ "@") xs -> Just (joined "\n" xs) -- numbers = iterate (1+) 1 - confs :: Symbol -> [Maybe String] - confs sym = map ConField.name (Symbol.flds sym) -- just the names + confs :: SymD Global -> [Maybe String] + confs sym = map ConField.name sym.flds -- just the names -- find sub-pattern name of field f in constructor sym - occurs :: Symbol -> String -> [ExprS] + occurs :: SymD Global -> String -> [ExprS] occurs sym f = (map fst • filter ((==Just f) • snd) • zip subvars) (confs sym) -- arity of a constructor - arity :: Symbol -> Int - arity sym = length (Symbol.flds sym) + arity :: SymD Global -> Int + arity sym = length sym.flds -- displayed name of a constructor - cname :: Symbol -> SName - cname sym = case Symbol.name sym of + cname :: SymD Global -> SName + cname sym = case sym.name of MName tn base -> With1 pos.first.{tokid=CONID, value=tn.base} pos.first.{tokid=CONID, value=base} _ -> error "constructor must be a member" @@ -139,12 +139,12 @@ chgddef (d@DatDcl {pos}) = do getAlts = [ CAlt {pat=conpat con "a", ex=v} | con <- cons, v <- occurs con f] updExpr = Case CNoWarn this updAlts - conUpd :: Symbol -> ExprS -> ExprS + conUpd :: SymD Global -> ExprS -> ExprS conUpd con v = mkApp (conval con) (rep v.name.id.value that (take (arity con) subvars)) updAlts = [ CAlt {pat=conpat con "a", ex = conUpd con v} | con <- cons, v <- occurs con f] chgExpr = Case CNoWarn this chgAlts - conChg :: Symbol -> ExprS -> ExprS + conChg :: SymD Global -> ExprS -> ExprS conChg con v = mkApp (conval con) (rep v.name.id.value (nApp that v) (take (arity con) subvars)) chgAlts = [ CAlt {pat=conpat con "a", ex = conChg con v} | con <- cons, v <- occurs con f] diff --git a/frege/compiler/passes/Final.fr b/frege/compiler/passes/Final.fr index 41a90481..c5d2761c 100644 --- a/frege/compiler/passes/Final.fr +++ b/frege/compiler/passes/Final.fr @@ -1,6 +1,8 @@ --- The final compiler pass module frege.compiler.passes.Final where +import frege.compiler.common.Lens (over) + import Data.TreeMap as TM(TreeMap, insert, each) import Compiler.types.Global import Compiler.enums.Flags @@ -42,11 +44,12 @@ cleanSymtab = do maptab g = fmap symbol g.thisTab where symbol sym = case sym of - SymV{name} | Just e <- g.gen.expSym.lookup name - = sym.{expr = Just (exprFromA sarray eAarray eAarray.[e])} - SymV{} = sym.{expr = Nothing} - _ | sym.{env?} = sym.{env <- fmap symbol} - | otherwise = sym + SymbolT.V (symv@SymV{name}) + | Just e <- g.gen.expSym.lookup name + -> SymbolT.V symv.{expr = Just (exprFromA sarray eAarray eAarray.[e])} + | otherwise + -> SymbolT.V symv.{expr = Nothing} + _ -> over SymbolT.env (fmap symbol) sym swap :: (a,b) -> (b,a) swap (a,b) = (b,a) -- !kAarray = (arrayFromIndexList . map swap . each) empty -- g.gen.kTree diff --git a/frege/compiler/passes/GenCode.fr b/frege/compiler/passes/GenCode.fr index 42e04ef4..9cf8f1ba 100644 --- a/frege/compiler/passes/GenCode.fr +++ b/frege/compiler/passes/GenCode.fr @@ -106,6 +106,8 @@ import Lib.PP(pretty) import Data.TreeMap(TreeMap, values) import Data.Graph (stronglyConnectedComponents tsort) +import frege.compiler.common.Lens (view) + import Compiler.Utilities as U() import Compiler.types.Global @@ -153,12 +155,12 @@ pass = do g ← getSTT -- classes - let classes = [ s | s@SymC {} <- values g.thisTab ] + let classes = [ s | s@(SymbolT.C _) <- values g.thisTab ] liftStG (concat <$> mapM classCode classes) >>= liftIO . ppDecls g -- instances - let instances = [ s | s@SymI {} <- values g.thisTab ] + let instances = [ s | s@(SymbolT.I _) <- values g.thisTab ] liftStG (concat <$> mapM instanceCode instances) >>= liftIO . ppDecls g @@ -169,7 +171,7 @@ pass = do -- do variables in dependency order, this is so that CAFs refer only to CAFs -- whose java initialization occurs earlier - let vars = [ s | s@SymV {} <- values g.thisTab ] + let vars = [ s | s@(SymbolT.V _) <- values g.thisTab ] liftStG ( mapSt U.fundep vars >>= mapSt U.findV . concat . tsort @@ -247,7 +249,7 @@ ppDecls g decls = do > } -} mainCode ∷ Global → Symbol → [String] -mainCode g sym = [ +mainCode g sym' = [ " public static void main(final java.lang.String[] argv) {", " try {", " frege.run.RunTM.argv = argv;", @@ -269,8 +271,9 @@ mainCode g sym = [ " }" ] where + sym = case sym' of { SymbolT.V x -> x; } shutdown = "frege.run.Concurrent.shutDownIfExists"; - name = (symJavaName g sym).base + name = (symJavaName g $ SymbolT.V sym).base jtype = tauJT g (fst (U.returnType sym.typ.rho)) isInt | Func{gargs=[a,b]} ← jtype = show b == "Integer" @@ -289,5 +292,5 @@ mainCode g sym = [ --- tell if there is a main function in this module -- haveMain :: Global -> Bool haveMain g = case Global.findit g (VName g.thisPack "main") of - Just sym | sym.name.pack == g.thisPack = Just sym + Just sym | (view SymbolT.name sym).pack == g.thisPack = Just sym other = Nothing \ No newline at end of file diff --git a/frege/compiler/passes/GlobalLam.fr b/frege/compiler/passes/GlobalLam.fr index 19c609e3..57c25bbd 100644 --- a/frege/compiler/passes/GlobalLam.fr +++ b/frege/compiler/passes/GlobalLam.fr @@ -2,6 +2,7 @@ module frege.compiler.passes.GlobalLam where -- generated by Splitter import frege.Prelude hiding(<+>) +import frege.compiler.common.Lens (view) import frege.compiler.enums.Flags import frege.compiler.types.Positions import frege.compiler.types.QNames @@ -37,14 +38,14 @@ singleLetSym sym = do E.fatal sym.pos ("unrollSym no SymV : " ++ sym.nice g) -} -closedLambdaSym (vsym@SymV {pos}) +closedLambdaSym (SymbolT.V vsym) | Just x <- vsym.expr = do nx <- x >>= U.mapExBody true closedLambda - changeSym vsym.{expr = Just (return nx)} + changeSym $ SymbolT.V vsym.{expr = Just (return nx)} | otherwise = stio () closedLambdaSym sym = do g <- getST - E.fatal sym.pos (text ("closedLambdaSym no SymV : " ++ sym.nice g)) + E.fatal (view SymbolT.pos sym) (text ("closedLambdaSym no SymV : " ++ sym.nice g)) @@ -128,7 +129,8 @@ closedLambda (letex@Let{env,ex}) = do -- now we can lift harmless inner la pure (Right result) where inner (env, ex) qn = do - sym <- U.findV qn + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> U.findV qn case sym.expr of Just def -> do def <- def @@ -141,7 +143,7 @@ closedLambda (letex@Let{env,ex}) = do -- now we can lift harmless inner la nex <- replName sym.sid name ex return (env, nex) sonst -> do - changeSym sym.{expr = Just (return ndef)} + changeSym $ SymbolT.V sym.{expr = Just (return ndef)} return (qn:env, ex) else return (qn:env, ex) sonst -> return (qn:env, ex) diff --git a/frege/compiler/passes/Imp.fr b/frege/compiler/passes/Imp.fr index cc965cb6..c419cd68 100644 --- a/frege/compiler/passes/Imp.fr +++ b/frege/compiler/passes/Imp.fr @@ -47,6 +47,8 @@ import Data.TreeMap as TM(TreeMap, keys, insert, insertWith, each, values, looku import Data.List as DL(sortBy, zipWith4) import Data.Bits(BitSet.BitSet) +import frege.compiler.common.Lens (unsafePartialView, view) + import Compiler.enums.Flags import Compiler.enums.TokenID(CONID, VARID, defaultInfix, ROP4) import Compiler.enums.Visibility @@ -243,20 +245,21 @@ importEnv pos env ns pack (imp@Imports {except=true, items}) = do g <- getST let xs = [ withNS ns.unNS (ImportItem.name e) | e <- items ] exss <- mapSt (resolve (VName g.thisPack) pos) xs + let isSymD (SymbolT.D _) = true + isSymD _ = false let exs = fold (++) [] exss - nitems = [ protoItem.{ name = Simple pos.first.{tokid=VARID, value=(Symbol.name sym).base}, + nitems = [ protoItem.{ name = Simple pos.first.{tokid=VARID, value=(view SymbolT.name sym).base}, members = nomem csym, - alias = (Symbol.name sym).base} | + alias = (view SymbolT.name sym).base} | sym <- sortBy (comparing constructor) (values env), -- place SymL before SymC - csym <- (g.findit sym.name), - not (Symbol.{cid?} csym) -- no constructors - || (Symbol.name sym).base != (Symbol.name csym).base, -- except renamed ones - Symbol.name csym `notElem` exs, - Symbol.vis sym == Public + csym <- g.findit (view SymbolT.name sym), + not (isSymD csym) -- no constructors + || (view SymbolT.name sym).base != (view SymbolT.name csym).base, -- except renamed ones + view SymbolT.name csym `notElem` exs, + view SymbolT.vis sym == Public ] - nomem (SymC {}) = Just [] - -- nomem (SymT {}) = Just [] - nomem _ = Nothing + nomem (SymbolT.C _) = Just [] + nomem _ = Nothing importEnv pos env ns pack imp.{except=false, items=nitems} --- A public import list is equivalent to one without public but public specified for all items. @@ -266,7 +269,8 @@ importEnv pos env ns pack (imp@Imports {publik=true, items}) importEnv pos env ns pack (Imports {items}) = foreach items (linkItem ns.unNS pack) --- a symbolic link is dereferenced and the link goes to the target -linkHere ns pack (item@Item {alias=itema}) (link@SymL {name, alias}) = do +linkHere :: String -> Pack -> ImportItem -> Symbol -> StG () +linkHere ns pack (item@Item {alias=itema}) (SymbolT.L (link@SymL {name, alias})) = do let pos = Pos item.name.id item.name.id g <- getST case g.findit alias of @@ -283,26 +287,26 @@ linkHere ns pack (item@Item {publik,name,members,alias=newn}) sym = do let pos = Pos name.id name.id let conid = (newn.charAt 0).isUpperCase conidOk - | TName _ _ <- sym.name = true - | SymD {} <- sym = true - | otherwise = false + | TName _ _ <- view SymbolT.name sym = true + | SymbolT.D _ <- sym = true + | otherwise = false vis = if publik then Public else Private g <- getST E.logmsg TRACE2 pos (text ("linkHere: " ++ ns ++ "." ++ newn ++ ", vis =" ++ show vis ++ " ==> " ++ nice sym g)) changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk pos.first) (Right sym.name)}} + idKind <- insert (KeyTk pos.first) (Right (view SymbolT.name sym))}} - let !errors = case sym.name of - TName _ b - | newn == sym.name.base || conid = linkqvp (TName g.thisPack newn) sym vis pos + let !errors = case view SymbolT.name sym of + name@(TName _ b) + | newn == name.base || conid = linkqvp (TName g.thisPack newn) sym vis pos | otherwise = do E.error pos (msgdoc ("Alias for " ++ nice sym g ++ " must be a type name, not `" ++ newn ++ "'")) stio () - _ - | newn == sym.name.base || conid == conidOk = linkqvp (VName g.thisPack newn) sym vis pos + name + | newn == name.base || conid == conidOk = linkqvp (VName g.thisPack newn) sym vis pos -- allow variables that link to constructors - | SymD{} <- sym, !conid = linkqvp (VName g.thisPack newn) sym vis pos + | SymbolT.D _ <- sym, !conid = linkqvp (VName g.thisPack newn) sym vis pos | otherwise = do E.error pos (msgdoc ("Alias for " ++ nice sym g ++ " must be a " ++ (if conidOk then "constructor" else "variable") @@ -318,7 +322,7 @@ linkHere ns pack (item@Item {publik,name,members,alias=newn}) sym = do noteWhy (Local{}) = stio () noteReExported p | p /= pack = changeST _.{sub <- _.{packWhy <- insertWith (++) p [NSX ns]}} | otherwise = changeST _.{sub <- _.{packWhy <- insert p [NSX ns]}} - noteWhy sym.name + noteWhy (view SymbolT.name sym) errors case sym of @@ -327,18 +331,18 @@ linkHere ns pack (item@Item {publik,name,members,alias=newn}) sym = do let cons = [ item.{name <- (pos.first.{tokid=CONID, value=mem.name.base} `qBy`), members = Nothing, alias = mem.name.base, publik = false} - | mem@SymD {} <- values env, mem.vis == Public ] + | SymbolT.D mem <- values env, mem.vis == Public ] foreach cons (linkItem ns pack) | Just ms <- members = do let nms = map ImportItem.{name <- (`qBy` item.name) • SName.id} ms foreach nms (linkItem ns pack) - SymC {env} + SymbolT.C SymC{env} | Nothing <- members = do -- link class methods - let meth = [ item.{name <- (pos.first.{tokid=VARID, value=sym.name.base} `qBy`), - members = Nothing, alias = sym.name.base} - | sym@SymV {vis} <- values env, + let meth = [ item.{name <- (pos.first.{tokid=VARID, value=name.base} `qBy`), + members = Nothing, alias = name.base} + | SymbolT.V SymV{vis, name} <- values env, vis == Public || vis == Abstract, - not (defined sym.name.base) ] -- import only yet undefined class members + not (defined name.base) ] -- import only yet undefined class members -- here = g.thisTab defined s = isJust (g.find (VName g.thisPack s)) foreach meth (linkItem ns pack) @@ -358,7 +362,7 @@ linkItem ns pack (item@Item {publik,name,members,alias}) = do [] -> stio () -- got error message from resolve or excluded [sym] -> linkHere ns pack item sym syms -- look for a type name - | (tsym:_) <- [ x | x <- syms, TName{} <- Just x.name] + | (tsym:_) <- [ x | x <- syms, TName{} <- Just (view SymbolT.name x)] = linkHere ns pack item tsym | otherwise = do -- by taking the first result, we resolve NS.x linkHere ns pack item (head syms) @@ -501,7 +505,7 @@ importClassData pos why pack = do let strMB "" = Nothing strMB s = Just s - let rbSymA n = SymA {sid=0, pos=mkpos sym.offset sym.name.base, vis, + let rbSymA n = SymbolT.A SymA{sid=0, pos=mkpos sym.offset sym.name.base, vis, doc = strMB sym.doc, name = rebuildQN sym.name, typ = nSigma sym.typ, @@ -510,7 +514,7 @@ importClassData pos why pack = do where sym = elemAt fp.symas n vis = if sym.publik then Public else Protected rbSymV :: CT.SymVArr -> Int -> Symbol - rbSymV arr n = SymV {sid=0, pos=mkpos sym.offset sym.name.base, vis=v, doc=strMB sym.doc, + rbSymV arr n = SymbolT.V SymV{sid=0, pos=mkpos sym.offset sym.name.base, vis=v, doc=strMB sym.doc, name = rebuildQN sym.name, typ = nSigma sym.sig, pur = sym.pur, nativ = if sym.nativ == "" then Nothing else Just sym.nativ, expr = rbExpr sym.expr, @@ -524,7 +528,7 @@ importClassData pos why pack = do where sym = elemAt arr n v = if sym.abst then Abstract else if sym.publik then Public else Protected rbSymD :: CT.SymDArr -> Int -> Symbol - rbSymD arr n = SymD {sid=0, pos=mkpos sym.offset sym.name.base, vis, doc=strMB sym.doc, + rbSymD arr n = SymbolT.D SymD{sid=0, pos=mkpos sym.offset sym.name.base, vis, doc=strMB sym.doc, name = rebuildQN sym.name, cid = sym.cid, typ = nSigma sym.typ, flds = map mkfield fields, @@ -544,12 +548,12 @@ importClassData pos why pack = do vis = if sym.priv then Private else if sym.publik then Public else Protected rbSymL :: CT.SymLArr -> Int -> Symbol - rbSymL arr n = SymL {sid=0, pos=mkpos sym.offset sym.name.base, vis, -- doc=strMB sym.doc, + rbSymL arr n = SymbolT.L SymL{sid=0, pos=mkpos sym.offset sym.name.base, vis, -- doc=strMB sym.doc, name = rebuildQN sym.name, alias = rebuildQN sym.alias} where sym = elemAt arr n vis = if sym.publik then Public else Protected rbSymC :: CT.SymC -> Symbol - rbSymC sym = SymC {sid=0, pos=mkpos sym.offset sym.name.base, vis, doc=strMB sym.doc, + rbSymC sym = SymbolT.C SymC{sid=0, pos=mkpos sym.offset sym.name.base, vis, doc=strMB sym.doc, name = rebuildQN sym.name, tau = nTau sym.tau, supers = sups, @@ -566,7 +570,7 @@ importClassData pos why pack = do foreach (enumFromTo 0 (sym.funs.length-1)) (enter • rbSymV sym.funs) foreach (enumFromTo 0 (sym.lnks.length-1)) (enter • rbSymL sym.lnks) rbSymI :: CT.SymI -> Symbol - rbSymI sym = SymI {sid=0, pos=mkpos sym.offset sym.name.base, + rbSymI sym = SymbolT.I SymI{sid=0, pos=mkpos sym.offset sym.name.base, vis=Public, doc=strMB sym.doc, name = rebuildQN sym.name, clas = rebuildQN sym.clas, @@ -594,8 +598,8 @@ importClassData pos why pack = do foreach (enumFromTo 0 (sym.cons.length-1)) (enter • rbSymD sym.cons) foreach (enumFromTo 0 (sym.funs.length-1)) (enter • rbSymV sym.funs) foreach (enumFromTo 0 (sym.lnks.length-1)) (enter • rbSymL sym.lnks) - case rsym.nativ of - Just nativ -> U.nativeType nativ rsym.name + case unsafePartialView SymbolT.nativ rsym of + Just nativ -> U.nativeType nativ (view SymbolT.name rsym) nothing -> return () @@ -636,10 +640,12 @@ preludeBasics = do product = true, enum = true, pur = false, newt = false, kind = KType, gargs = [], sid=0, pos=Position.null, vis=Public, doc=Just "Unit type"}) - enter (SymD {name = unitC, typ=unitTy, flds = [], cid = 0, + enter $ SymbolT.D + (SymD {name = unitC, typ=unitTy, flds = [], cid = 0, sid=0, pos=Position.null, vis=Public, doc=Just "Unit value", op = defaultInfix, strsig = U}) - enter (SymL {name = unitCA, alias = unitC, + enter $ SymbolT.L + (SymL {name = unitCA, alias = unitC, sid=0, pos=Position.null, vis=Public}) -- [], a:as let listT = TName pPreludeBase "[]" @@ -660,17 +666,21 @@ preludeBasics = do product = false, enum = false, pur = false, newt = false, kind = Kind.unary, gargs = [], sid=0, pos=Position.null, vis=Public, doc=Just "list type"}) - enter (SymD {name = listNil, typ = listTy, flds = [], cid=0, + enter $ SymbolT.D + (SymD {name = listNil, typ = listTy, flds = [], cid=0, sid=0, pos=Position.null, vis=Public, doc=Just "empty list", op = defaultInfix, strsig = U}) - enter (SymD {name = listCons, typ = consTy, cid=1, + enter $ SymbolT.D + (SymD {name = listCons, typ = consTy, cid=1, flds = [ aField false (ForAll [] (RhoTau [] va)), aField false (ForAll [] listRho)], sid=0, pos=Position.null, vis=Public, doc=Just "list construction", op = ROP4, strsig = U}) - enter (SymL {name = VName pPreludeBase "[]", alias = listNil, + enter $ SymbolT.L + (SymL {name = VName pPreludeBase "[]", alias = listNil, sid=0, pos=Position.null, vis=Public}) - enter (SymL {name = VName pPreludeBase ":", alias = listCons, + enter $ SymbolT.L + (SymL {name = VName pPreludeBase ":", alias = listCons, sid=0, pos=Position.null, vis=Public}) foreach (enumFromTo 2 26) (tupletype false) @@ -708,10 +718,12 @@ preludeBasics = do product = true, enum = false, kind = Kind.kind n, sid=0, pos=Position.null, vis=Public, doc=Just (show n ++ "-tuple"), pur = false, newt = false, gargs = []}) - enter (SymD {name = tupleC, typ = ForAll vks conRho, flds = flds, cid=0, + enter $ SymbolT.D + (SymD {name = tupleC, typ = ForAll vks conRho, flds = flds, cid=0, sid=0, pos=Position.null, vis=Public, doc=Just (show n ++ "-tuple constructor"), op = defaultInfix, strsig = U}) - enter (SymL {name = VName pPreludeBase name, alias = tupleC, + enter $ SymbolT.L + (SymL {name = VName pPreludeBase name, alias = tupleC, sid=0, pos=Position.null, vis=Public}) mvar :: Tau diff --git a/frege/compiler/passes/Instances.fr b/frege/compiler/passes/Instances.fr index 2cf488a0..3144288d 100644 --- a/frege/compiler/passes/Instances.fr +++ b/frege/compiler/passes/Instances.fr @@ -5,6 +5,8 @@ module frege.compiler.passes.Instances where import Data.List as DL(uniqBy, sort, sortBy) import frege.lib.PP(text, msgdoc) +import frege.compiler.common.Lens (unsafePartialView, view) + -- import Compiler.enums.Flags as Compilerflags(TRACE3, TRACE4) import Compiler.enums.TokenID import Compiler.enums.Visibility @@ -94,17 +96,21 @@ derivable = ["Hashable", "Eq", "Ord", "Enum", "Bounded", "Show", "Exceptional"] --- arity of a constructor arity ∷ Symbol → Int -arity sym = length (Symbol.flds sym) +arity sym = length (unsafeGetFlds sym) + where + unsafeGetFlds (SymbolT.D SymD{flds}) = flds deriveClass :: Position → QName → Symbol → [Symbol] → RhoT SName -> Global → String → [DefinitionS] -deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive +deriveClass pos clas forty ctrs' instrho g toderive = deriveClass toderive where + ctrs = flip map ctrs' $ \x -> case x of + SymbolT.D c -> c con = head ctrs isEnum ∷ Bool - isEnum = all (0==) (map arity ctrs) + isEnum = all (0==) (map (arity . SymbolT.D) ctrs) -- displayed name of a constructor - cname ∷ Symbol → SName - cname sym = case Symbol.name sym of + cname :: SymD Global -> SName + cname sym = case sym.name of MName tn base -> With1 pos.first.{tokid=CONID, value=tn.base} pos.first.{tokid=CONID, value=base} _ -> error "constructor must be a member" @@ -113,11 +119,11 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive subpats c = subvars c -- [ var (c ++ show a) | a <- enumFromTo 1 1000 ] subvars c = [ var (c ++ show a) | a <- enumFromTo 1 1000 ] -- construct pattern Con s1 s2 s3 ... sn - conpat :: Symbol -> String -> ExprS + conpat :: SymD Global -> String -> ExprS conpat con s = Term app -- PCon {qname=cname con, pos=pos.change QCONID con.name.base, pats} where app = fold App Con{name=cname con} pats - pats = take (arity con) (subpats s) + pats = take ((arity . SymbolT.D) con) (subpats s) -- construct simple (pattern) variables var :: String -> ExprS @@ -197,7 +203,7 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive halts = map hashalt ctrs hashalt con = calt p hashex where - a = arity con + a = (arity . SymbolT.D) con p = conpat con "a" vs = take a (subvars "a") c = nApp (gvar "PreludeBase" "constructor") varg1 @@ -222,7 +228,7 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive -- (C,C) -> true, (C1 a1 a2, C1 b1 b2) -> a1 == b1 && a2==b2 mkequalalt con = calt (ptup peq1 peq2) eqex where - a = arity con + a = (arity . SymbolT.D) con peq1 = conpat con "a" peq2 = conpat con "b" sub1 = take a (subvars "a") @@ -236,7 +242,7 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive deriveClass "Ord" | [prod] <- ctrs = [DefinitionS.Fun $ publicfun "<=>" [conpat prod "a", conpat prod "b"] - (ordex (arity prod) 0)] + (ordex ((arity . SymbolT.D) prod) 0)] | otherwise = [DefinitionS.Fun $ publicfun "<=>" [parg1, parg2] outercase] where --* case a1 <=> b1 of { Eq -> case a2 <=> b2 of { ... @@ -254,7 +260,7 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive --* (C ai, C bi) -> ordex ai bi mkeqcase con = calt (ptup peq1 peq2) oex where - a = arity con + a = (arity . SymbolT.D) con peq1 = conpat con "a" -- C a1 a2 .. an peq2 = conpat con "b" -- C b1 b2 .. bn oex = ordex a 0 @@ -268,7 +274,7 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive eqexs = (map mkeqcase ctrs) ++ [default_] default_ = calt (var "_") vEq deriveClass "Show" - | forty.name.base ~ ´^\(,+\)´ = let -- tuple + | (view SymbolT.name forty).base ~ ´^\(,+\)´ = let -- tuple sex = Case CNormal (var "r") [(mktupshowalt con)] show = publicfun "show" [var "r"] sex -- showsub = publicfun "showsub" [] (var "show") @@ -282,11 +288,11 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive where mkshowalts constr = map mkshowalt constr mkshowsubalts constr = map mkshowsubalt constr - mkshowalt :: Symbol -> CAltS + mkshowalt :: SymD Global -> CAltS mkshowalt con = calt (conpat con "a") sx where scon = string (con.name.base) - sub = take (arity con) (subvars "a") + sub = take ((arity . SymbolT.D) con) (subvars "a") sx = joinit scon sub blanked s = s `mkapp` string " " showit v = gvar "PreludeText" "showsub" `nApp` v @@ -297,11 +303,11 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive let salt = mkshowalt con subx = (string "(" `mkapp` salt.ex) `mkapp` string ")" - in if arity con == 0 then salt + in if (arity . SymbolT.D) con == 0 then salt else salt.{ex=subx} mktupshowalt con = calt (conpat con "a") sx where scon = string "(" - sub = take (arity con) (subvars "a") + sub = take ((arity . SymbolT.D) con) (subvars "a") sx = joinit scon sub showsv s v d = (s `mkapp` showit v) `mkapp` string d joinit s [] = s `mkapp` string ")" @@ -323,7 +329,7 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive -- eqex = (opEq `nApp` -- ((var "<=>" `nApp` var "a") `nApp` var "b")) `nApp` -- pEq - ctup = sortBy (comparing Symbol.cid) ctrs + ctup = sortBy (comparing SymD.cid) ctrs ctdn = reverse ctup max = Con {name=cname (head ctdn)} min = Con {name=cname (head ctup)} @@ -333,10 +339,10 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive sex = Case CNormal (var "r") (mkalts "succ " ctup) pex = Case CNormal (var "r") (mkalts "pred " ctdn) last = calt (var "_") (nApp vError msg) -- _ -> error ... - msg = (string (forty.name.nice g) + msg = (string ((view SymbolT.name forty).nice g) `mkapp` string ".from ") `mkapp` showit (var "r") -- "X" ++ ".from " ++ show r - fromalt ctr = calt (int (Symbol.cid ctr)) (Con {name=cname ctr}) + fromalt ctr = calt (int (SymD.cid ctr)) (Con {name=cname ctr}) mkalts s [x] = [calt (conpat x "_") (nApp vError (string (s ++ show (cname x))))] mkalts s (x:y:zs) = calt (conpat x "_") (Con {name=cname y}) : mkalts s (y:zs) mkalts s [] = [] @@ -349,7 +355,7 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive deriveClass "Bounded" = map DefinitionS.Fun [minval, maxval] where - ctup = sortBy (comparing Symbol.cid) ctrs + ctup = sortBy (comparing SymD.cid) ctrs ctdn = reverse ctup min = Con {name=cname (head ctup)} max = Con {name=cname (head ctdn)} @@ -360,14 +366,14 @@ deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive DefinitionS.Nat $ NatDcl{pos, vis=Public, name="javaClass", txs = [(ForAll [] (RhoTau [] tapp), [])], - meth = fromMaybe (rawName jt) forty.nativ ++ ".class", + meth = fromMaybe (rawName jt) (unsafePartialView SymbolT.nativ forty) ++ ".class", isPure = true, gargs = Nothing, doc = Nothing}] where tapp = TApp pClass this this | RhoTau{tau} <- instrho = tau | otherwise = error ("Cannot derive for non type: " ++ nicer forty g) - jt = sigmaJT g forty.typ + jt = sigmaJT g (unsafePartialView SymbolT.typ forty) deriveClass "JavaType" = deriveClass "Exceptional" deriveClass "ArrayElement" = deriveClass "Exceptional" deriveClass s = error ("can't deriveClass " ++ s) @@ -383,7 +389,7 @@ deriveDcls pos clas forty ctrs instrho = do ccc `elem` ["Enum", "Bounded"] -> if all (0==) (map arity ctrs) then stio (dC ccc) else do - let bad = [ c.name.nice g | c <- ctrs, arity c != 0 ] + let bad = [ (view SymbolT.name c).nice g | c <- ctrs, arity c != 0 ] E.error pos (msgdoc ("Can't derive " ++ clas.nice g ++ " for " ++ forty.nice g ++ " because " ++ (if length bad == 1 then head bad ++ " is not a nullary constructor" @@ -394,7 +400,7 @@ deriveDcls pos clas forty ctrs instrho = do TName ppp "ArrayElement" | inPrelude ppp g = return (dC "ArrayElement") TName ppp "Exceptional" - | inPrelude ppp g = if isJust forty.nativ + | inPrelude ppp g = if isJust (unsafePartialView SymbolT.nativ forty) then return (dC "Exceptional") else do E.error pos (msgdoc ("Can't derive Exceptional for " ++ forty.nicer g diff --git a/frege/compiler/passes/LetUnroll.fr b/frege/compiler/passes/LetUnroll.fr index 44cef1a1..dbf26283 100644 --- a/frege/compiler/passes/LetUnroll.fr +++ b/frege/compiler/passes/LetUnroll.fr @@ -5,6 +5,7 @@ import frege.Prelude hiding(<+>) import frege.data.TreeMap as TM(TreeMap, TreeSet, lookup, insert, keys, values, each, fromKeys, including, contains, union) import frege.data.List as DL(uniq, sort, sortBy, groupBy, partitioned, elemBy) import frege.data.Graph(stronglyConnectedComponents tsort) +import frege.compiler.common.Lens (view) import frege.compiler.enums.Flags import frege.compiler.enums.Visibility import frege.compiler.types.Positions @@ -29,14 +30,17 @@ import frege.compiler.common.PatternCompiler pass = do g <- getST + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + let allourvars' g = map unsafeToSymV (allourvars g) + -- unroll let expressions - let collectedvars = allourvars g + let collectedvars = allourvars' g foreach collectedvars unrollSym -- simplify let expressions by lifting local function bindings to the top -- or inlining variables g <- getST - let collectedvars = allourvars g + let collectedvars = allourvars' g foreach collectedvars unLetSym -- make multi-equation definitions ready for type check @@ -50,21 +54,21 @@ pass = do unrollSym (vsym@SymV {pos}) | Just x <- vsym.expr = do nx <- x >>= unrollExpr - changeSym vsym.{expr = Just (return nx)} + changeSym $ SymbolT.V vsym.{expr = Just (return nx)} | otherwise = stio () -- do nothing unrollSym sym = do g <- getST - E.fatal sym.pos (text ("unrollSym no SymV : " ++ sym.nice g)) + E.fatal sym.pos (text ("unrollSym no SymV : " ++ (SymbolT.V sym).nice g)) unLetSym (vsym@SymV {pos}) | Just x <- vsym.expr = do nx <- x >>= unLetExpr - changeSym vsym.{expr = Just (return nx)} + changeSym $ SymbolT.V vsym.{expr = Just (return nx)} | otherwise = stio () -- do nothing unLetSym sym = do g <- getST - E.fatal sym.pos (text ("unLetSym no SymV : " ++ sym.nice g)) + E.fatal sym.pos (text ("unLetSym no SymV : " ++ (SymbolT.V sym).nice g)) unrollExpr = U.mapEx true unrollLet @@ -79,13 +83,14 @@ unrollLet (x@Let {env,ex}) = do -- first do the subexpressions let mapsub (sy@SymV {expr=Just x}) = do x <- x >>= unrollExpr - changeSym sy.{expr=Just (return x)} + changeSym $ SymbolT.V sy.{expr=Just (return x)} mapsub sy = error "mapsub: no var" ex <- unrollExpr ex - syms <- mapSt U.findV env + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + syms <- mapSt (fmap unsafeToSymV . U.findV) env foreach syms mapsub let -- kvs = each env - xdep k = do sym <- U.findV k; ldep (k, sym) + xdep k = do sym <- unsafeToSymV <$> U.findV k; ldep (k, sym) ldep (k, SymV {expr=Nothing}) = stio (k, []) ldep (k, SymV {expr=Just ex}) = do deps <- ex >>= letlocals @@ -136,12 +141,13 @@ unusedLet (x@Let {env,ex}) = do down <- references (map QName.uid env) ex if down == 0 then do - syms <- mapSt U.findV env + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + syms <- mapSt (fmap unsafeToSymV . U.findV) env g <- getST - foreach syms (\(sym::Symbol) -> + foreach syms (\sym -> unless (sym.name.base ~ ´^_´) do - E.hint (getrange sym) (msgdoc ( - nicer sym g ++ " is not used anywhere.")) + E.hint (getrange $ SymbolT.V sym) (msgdoc ( + nicer (SymbolT.V sym) g ++ " is not used anywhere.")) ) stio (Left ex) else stio (Left x) @@ -151,67 +157,59 @@ unusedLet x = stio (Left x) --- lift mutual recursive let functions to the top level unLet (x@Let {env,ex}) | length env > 1 = do - vals <- mapSt U.findV env + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + vals <- mapSt (fmap unsafeToSymV . U.findV) env g <- getST - if (any Symbol.anno vals) + if (any _.anno vals) then unLetMutual g vals x else return (Left x) where - unLetMutual :: Global -> [Symbol] -> Expr -> StG (Either Expr Expr) + unLetMutual :: Global -> [SymV Global] -> Expr -> StG (Either Expr Expr) unLetMutual g vals (x@Let {env,ex}) = do freevbls <- toPass case freevbls of [] -> do gsyms <- mapSt globalize vals - foreach gsyms enter + foreach gsyms (enter . SymbolT.V) let vgs = zip vals gsyms syms <- mapSt (mkGlobal vgs) vgs newlet <- foldSt replsym ex vgs E.logmsg TRACE7 pos (text ("changed " ++ nice newlet g)) - foreach syms changeSym - foreach (map Symbol.name syms) unLetName + foreach syms (changeSym . SymbolT.V) + foreach (map _.name syms) unLetName stio (Left newlet) - xs -> do - -- let part1 = msgdoc ("implementation restriction: mutual recursive local functions" - -- ++ " that use variables bound in enclosing lexical scopes" - -- ++ " are currently not supported.") - -- part2 = text "functions: " <+> sep "," (map (text • flip nicer g • Symbol.name) vals) - -- part3 = text "variables: " <+> sep "," (map (text • flip nicer g • Symbol.name) freevbls) - -- part4 = text "There are two possible workarounds:" - -- part5 = text "- If possible, make" <+> lit (length vals - 1) <+> text "functions local to the remaining one." - -- part6 = text "- Pass the variables as arguments." - -- E.error (getpos x) (part1 nest 4 (part2 part3 part4 part5 part6)) - stio (Left x) + xs -> stio (Left x) where pos = getpos x + unsafeToSymV s = case s of { SymbolT.V x -> x; } + exprs :: [Expr] - exprs = map (unJust • flip Symbol.gExpr g) vals + exprs = map (unJust . flip SymV.gExpr g) vals - freeSym :: Expr -> StG [Symbol] -- free variables in expression + freeSym :: Expr -> StG [SymV Global] -- free variables in expression freeSym x = do used <- U.localSyms x inner <- innerSids x let uids = filter (not • (inner `contains`)) (keys used) - mapSt U.findV [ Local uid "_" | uid <- uids ] - + mapSt (fmap unsafeToSymV . U.findV) [ Local uid "_" | uid <- uids ] - toPass :: StG [Symbol] -- symbols we must pass to each global val + toPass :: StG [SymV Global] -- symbols we must pass to each global val toPass = do exsyms <- mapSt freeSym exprs - stio ((uniq • sort) [ s | ss <- exsyms, s <- ss, s `notElem` vals ]) + stio $ (map unsafeToSymV . uniq . sort) [ SymbolT.V s | ss <- exsyms, s <- ss, SymbolT.V s `notElem` map SymbolT.V vals ] - globalize :: Symbol -> StG Symbol + globalize :: SymV Global -> StG (SymV Global) globalize sym = do g <- getST let name = U.unusedName (VName (Global.thisPack g) (sym.name.base)) g stio sym.{name, sid=0, expr = Nothing, vis = Private} - replsym :: Expr -> (Symbol, Symbol) -> StG Expr + replsym :: Expr -> (SymV Global, SymV Global) -> StG Expr replsym x (sym,gsym) = replName sym.sid gsym.name x - mkGlobal :: [(Symbol, Symbol)] -> (Symbol,Symbol) -> StG Symbol + mkGlobal :: [(SymV Global, SymV Global)] -> (SymV Global, SymV Global) -> StG (SymV Global) mkGlobal vgs (sym,gsym) = do let ex = unJust (sym.gExpr g) ex <- foldSt replsym ex vgs @@ -225,7 +223,8 @@ unLet (x@Let {env,ex}) stio gsym.{expr = Just (return ex), typ} unLetName nm = do - symv <- U.findV nm + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + symv <- unsafeToSymV <$> U.findV nm unLetSym symv unLetMutual g vals x = error "unLetMutual" @@ -233,7 +232,8 @@ unLet (xlet@Let {env=letenv,ex=letex,typ=lettyp}) | [x] <- letenv = do -- let x = ... in ex g <- getST - sym <- U.findV x + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> U.findV x case sym.gExpr g of Just (Lam {pat,ex,typ}) = do -- let x = \_ -> ... in ex @@ -252,14 +252,14 @@ unLet (xlet@Let {env=letenv,ex=letex,typ=lettyp}) let lamx = Lam {pat,ex,typ} let vks = U.freeTVars [] sym.typ.rho let typ = ForAll vks sym.typ.rho - enter sym.{sid = 0, name, expr = Just (return lamx), vis = Private, typ} + enter $ SymbolT.V sym.{sid = 0, name, expr = Just (return lamx), vis = Private, typ} changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk sym.pos.first) (Right name)}} E.logmsg TRACE7 sym.pos (text ("let " ++ nice x g ++ " = " ++ nice lamx g ++ " in ... replaced with " ++ nice letex2 g)) E.logmsg TRACE7 sym.pos (text ("new function is " ++ name.nice g)) unLet letex2 -- other opportunities possible here else do - changeSym sym.{expr = Just (return Lam{pat,ex,typ})} + changeSym $ SymbolT.V sym.{expr = Just (return Lam{pat,ex,typ})} letex <- U.mapEx true unLet letex stio (Right (Let {env=letenv,ex=letex,typ=lettyp})) -- a local non function stays local only if it uses other local symbols @@ -269,7 +269,7 @@ unLet (xlet@Let {env=letenv,ex=letex,typ=lettyp}) ulet <- U.mapEx true unLet letex cx <- U.mapEx true unLet cx let e = isSimple g cx - changeSym sym.{expr = Just (return cx)} + changeSym $ SymbolT.V sym.{expr = Just (return cx)} self <- references [sym.sid] cx down <- references [sym.sid] ulet -- E.logmsg TRACE7 sym.pos (text ("UNLET: " ++ nice x g @@ -301,7 +301,7 @@ unLet (xlet@Let {env=letenv,ex=letex,typ=lettyp}) letex2 <- replName sym.sid name ulet -- in the inner of the lambda or the let ex let vks = U.freeTVars [] sym.typ.rho let typ = ForAll vks sym.typ.rho - enter sym.{sid = 0, name, expr = Just (return ex), vis = Private, typ} + enter $ SymbolT.V sym.{sid = 0, name, expr = Just (return ex), vis = Private, typ} changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk sym.pos.first) (Right name)}} E.logmsg TRACE7 sym.pos (text ("let " ++ nice x g ++ " = " ++ nice cx g ++ " in ... replaced with " ++ nice letex2 g)) diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index 08279ebd..823af589 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -6,6 +6,7 @@ import frege.data.TreeMap as TM(TreeMap, TreeSet, lookup, insert, keys, value import frege.data.List as DL(uniq, sort, partitioned, elemBy) import frege.data.Bits(BitSet, BitSet.member, BitSet.union bitunion, BitSet.intersection, BitSet.difference) import frege.data.Graph(stronglyConnectedComponents tsort) +import frege.compiler.common.Lens (set, unsafePartialView, view) import frege.compiler.enums.Flags import frege.compiler.enums.TokenID(VARID) import frege.compiler.enums.RFlag @@ -54,7 +55,7 @@ pass = do -- bring default class methods in good shape g <- getST - let classmethods = [ sym | SymC{env} <- values g.thisTab, sym@SymV{expr = Just _} <- values env ] + let classmethods = [ sym | SymbolT.C SymC{env} <- values g.thisTab, SymbolT.V (sym@SymV{expr = Just _}) <- values env ] foreach classmethods easyClassMethodSym stio ("functions", length names) @@ -85,13 +86,13 @@ pass = do > anon a b = let c = b+1 in a c > method a' b' = anon a' b' -} -easyClassMethodSym :: Symbol -> StG () +easyClassMethodSym :: SymV Global -> StG () easyClassMethodSym (sym@SymV{expr = Just dx, typ}) = do x <- dx easy <- goodClassMethod x unless ( easy ) do g <- getST - U.symWarning E.warn sym (text (nice sym g + U.symWarning E.warn (SymbolT.V sym) (text (nice (SymbolT.V sym) g ++ (if easy then "" else " is not easy enough ") ++ (if RSafeTC `member` sym.rkind then "" else " recurses deeply ") ++ (if RTailRec `member` sym.rkind then " is tail recursive " else ""))) @@ -102,9 +103,9 @@ easyClassMethodSym (sym@SymV{expr = Just dx, typ}) = do let anon = sym.{sid=0, name, vis = Protected, expr = Just (return nx)} vbl = Vbl{name, pos=anon.pos.change VARID name.base, typ=Just (ForAll [] sym.typ.rho)} rk = (sym.rkind.unionE RSafeTC).differenceE RTailRec - enter anon + enter $ SymbolT.V anon x <- etaExpand vbl - changeSym sym.{expr = Just (return x), rkind = rk} + changeSym $ SymbolT.V sym.{expr = Just (return x), rkind = rk} where -- goodClassMethod :: Expr -> StG Bool goodClassMethod x = do @@ -115,9 +116,8 @@ easyClassMethodSym (sym@SymV{expr = Just dx, typ}) = do App{} -> liftM2 (&&) (goodClassMethod x.fun) (goodClassMethod x.arg) Vbl{name=Local{}} -> return true Vbl{name} -> do - vsym <- U.findV name - -- when (vsym.vis == Private) do - -- E.hint (getpos x) (text("uses private " ++ nice name g)) + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + vsym <- unsafeToSymV <$> U.findV name return (vsym.vis != Private) Con{name} -> return true -- constructors always exported Case{} -> do @@ -164,10 +164,11 @@ easyClassMethodSym sym = return () * Forward references can appear in global symbols which reference any global * value from this package. -} +returnKind :: [Int] -> SymV Global -> StG () returnKind syms (sym@SymV {nativ = Just _}) = do g <- getST -- jt <- U.isJavaType ((fst • U.returnType) sym.typ.rho) - changeSym sym.{rkind = RState.fromList [RSafeTC, RValue]} + changeSym $ SymbolT.V sym.{rkind = RState.fromList [RSafeTC, RValue]} returnKind syms (sym@SymV {expr = Just dx, depth = 0}) = do x <- dx @@ -175,7 +176,7 @@ returnKind syms (sym@SymV {expr = Just dx, depth = 0}) = do self <- references [sym.sid] x -- is it self-referential? rec <- references syms x -- is it recursive g <- getST - (_, deps) <- U.fundep sym + (_, deps) <- U.fundep $ SymbolT.V sym let local = sym.name.isLocal -- is this a local item? sx = simpleCAF g local x let fwrefs @@ -206,7 +207,7 @@ returnKind syms (sym@SymV {expr = Just dx, depth = 0}) = do -- and force it right away in the eval() fun | stricter, local, self > 0 = false -- local self refs must be lazy | otherwise = stricter - changeSym sym.{rkind, strsig = stri} + changeSym $ SymbolT.V sym.{rkind, strsig = stri} returnKind syms (sym@SymV {expr = Just dx}) = do x <- dx @@ -226,23 +227,24 @@ returnKind syms (sym@SymV {expr = Just dx}) = do -- class functions must be RSafeTC case sym.name of MName inst base | Just symic <- g.findit inst = case symic of - SymC{} -> do + SymbolT.C _ -> do let nkind = classMemberState - changeSym sym.{rkind=nkind} - SymI{} -> do - cm <- classMethodOfInstMethod sym.pos inst base + changeSym $ SymbolT.V sym.{rkind=nkind} + SymbolT.I _ -> do + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + cm <- unsafeToSymV <$> classMethodOfInstMethod sym.pos inst base if cm.rkind.null then do returnKind [] cm returnKind syms sym else do -- let nkind = (xkind.differenceE RAlways).union cm.rkind - changeSym sym.{rkind = xkind} - other -> changeSym sym.{rkind = xkind} - other -> changeSym sym.{rkind = xkind} + changeSym $ SymbolT.V sym.{rkind = xkind} + other -> changeSym $ SymbolT.V sym.{rkind = xkind} + other -> changeSym $ SymbolT.V sym.{rkind = xkind} --- assume abstract class functions are tail call safe and return a value returnKind syms (sym@SymV {expr = Nothing, name = MName _ _}) - = changeSym sym.{rkind=classMemberState} + = changeSym $ SymbolT.V sym.{rkind=classMemberState} returnKind _ _ = stio () -- abstract methods @@ -272,12 +274,14 @@ defaultRKind = RState.fromList [RSafeTC, RValue] * it's lazy. * - Unsaturated applications are boxed (function types) -} +returnExprKind :: [Int] -> SymV Global -> ExprT -> StG RState returnExprKind syms sym (x@Lit {pos}) = stio defaultRKind returnExprKind syms sym (x@Con {pos}) = stio defaultRKind returnExprKind syms sym (x@Ann {ex}) = returnExprKind syms sym ex returnExprKind syms sym (x@Vbl {name}) = do - symv <- U.findV name + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + symv <- unsafeToSymV <$> U.findV name g <- getST case symv.gExpr g of Nothing -> case symv.name of @@ -298,12 +302,13 @@ returnExprKind syms sym (ex@App a b typ) = do -- app = App a b typ case f of Vbl {name} -> do - symf <- U.findV name + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + symf <- unsafeToSymV <$> U.findV name g <- getST - let ari = if isJust symf.expr then symf.depth else U.arity symf + let ari = if isJust symf.expr then symf.depth else U.arity $ SymbolT.V symf rwa = defaultRKind.intersection symf.rkind rw | MName tname _ <- symf.name, - Just SymC{} <- g.findit tname + Just (SymbolT.C _) <- g.findit tname = rwa.unionE RValue -- call class methods lazy | otherwise = rwa if isJust symf.nativ then stio (rw) @@ -315,7 +320,7 @@ returnExprKind syms sym (ex@App a b typ) = do _ -> stio (rw) -- global fun Just _ -> do g <- getST - if symf.sid == Symbol.sid sym -- self recursive + if symf.sid == sym.sid -- self recursive then stio (defaultRKind.unionE RTailRec) else if (symf.sid `elem` syms) then if isOn g.options.flags PROPERTC @@ -388,13 +393,14 @@ minRkind a b = (safetc.union tailbit).union wrbits where * The @names@ list gives the names that are mutually dependent on this one. -} returnNames sids nms = do - syms <- mapSt U.findV nms - let !deps = sids ++ map Symbol.sid syms + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + syms <- mapSt (fmap unsafeToSymV . U.findV) nms + let !deps = sids ++ map _.sid syms foreach syms setsafetc foreach syms (returnKind deps) where - setsafetc :: Symbol -> StG () - setsafetc sym = changeSym sym.{rkind = BitSet.singleton RSafeTC} + setsafetc :: SymV Global -> StG () + setsafetc sym = changeSym $ SymbolT.V sym.{rkind = BitSet.singleton RSafeTC} {-- @@ -444,26 +450,27 @@ lambdaStrictness x = stio [] -- not a lambda strictName sids nm = do g <- getST - v <- U.findV nm + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + v <- unsafeToSymV <$> U.findV nm when (v.state != StrictChecked) do - E.logmsg TRACES v.pos (text ("strictness analysis for " ++ v.nice g)) - let ari = U.arity v -- ... based on type + E.logmsg TRACES v.pos (text ("strictness analysis for " ++ (SymbolT.V v).nice g)) + let ari = U.arity $ SymbolT.V v -- ... based on type notLazy sym = RValue `member` sym.rkind case v of SymV {state = StrictChecked} = stio [] -- do nothing - SymV {name = MName{tynm}} | Just SymC{} ← g.findit tynm → do + SymV {name = MName{tynm}} | Just (SymbolT.C _) <- g.findit tynm -> do let strsig = S (take ari allLazy) E.logmsg TRACES v.pos (text ("strictness for abstract " ++ v.name.nice g ++ " is " ++ show strsig)) - changeSym v.{strsig, state = StrictChecked} + changeSym $ SymbolT.V v.{strsig, state = StrictChecked} stio [] SymV {nativ = Just _} -> do let strsig = S (take ari allStrict) E.logmsg TRACES v.pos (text ("strictness for " ++ v.name.nice g ++ " is " ++ show strsig)) - changeSym v.{strsig, state = StrictChecked} + changeSym $ SymbolT.V v.{strsig, state = StrictChecked} stio [] SymV {} | Just (x@Lam{ex}) <- v.gExpr g -> do @@ -472,8 +479,8 @@ strictName sids nm = do E.logmsg TRACES v.pos (text ("strictness for " ++ v.name.nice g ++ " is " ++ show (S s) ++ " ignoring " - ++ joined ", " (map (flip nice g • Symbol.name) syms))) - changeSym v.{expr = Just (return x), strsig = S s, state = StrictChecked} + ++ joined ", " (map (flip nice g . view SymbolT.name) syms))) + changeSym $ SymbolT.V v.{expr = Just (return x), strsig = S s, state = StrictChecked} stio syms SymV {expr = Just x} | ari >= 0 = do y <- x >>= eta ari @@ -483,19 +490,19 @@ strictName sids nm = do rs = if null s then v.strsig else S s E.logmsg TRACES v.pos (text ("strictness for " ++ v.name.nice g ++ " is " ++ show rs)) - changeSym v.{expr = Just (return x), strsig = rs, state = StrictChecked} + changeSym $ SymbolT.V v.{expr = Just (return x), strsig = rs, state = StrictChecked} stio syms where eta 0 x = stio x eta n x = do let pos = getpos x nums <- sequence (take n (repeat uniqid)) - syms <- mapSt U.mkLocal [ PVar{pos=pos,uid,var="$"} | uid <- nums ] - let vars = map Symbol.name syms + syms <- mapSt (fmap unsafeToSymV . U.mkLocal) [ PVar{pos=pos,uid,var="$"} | uid <- nums ] + let vars = map _.name syms mkapp ex n = nApp ex (Vbl {pos, name=n, typ = Nothing}) -- mklam :: Expr -> Int -> Expr mklam ex sym = Lam {pat,ex,typ=Nothing} - where pat = PVar {pos, uid=Symbol.sid sym, var="$"} + where pat = PVar {pos, uid=sym.sid, var="$"} -- env = insert Nil pat.var (U.patLocal pos pat.var).{sid=n} -- \a\b -> x a b body = fold mkapp x vars @@ -513,9 +520,9 @@ strictName sids nm = do let strsig = if ari == 0 then v.strsig else S (take ari allLazy) E.logmsg TRACES v.pos (text ("strictness for " ++ v.name.nice g ++ " is " ++ show strsig)) - changeSym v.{strsig, state = StrictChecked} + changeSym $ SymbolT.V v.{strsig, state = StrictChecked} stio [] - other -> E.fatal other.pos (text ("strictness: strange symbol " ++ other.nice g)) + other -> E.fatal other.pos (text ("strictness: strange symbol " ++ (SymbolT.V other).nice g)) {-- @@ -549,8 +556,8 @@ strictReturn notLazy sids x = strictness sids x where let mine = if x.{env?} then map QName.uid x.env else if x.{pat?} then map Pattern.uid (patVars x.pat) else [] - my = filter ((`elem` mine) • Symbol.sid) - them = filter ((`notElem` mine) • Symbol.sid) + my = filter ((`elem` mine) . view SymbolT.sid) + them = filter ((`notElem` mine) . view SymbolT.sid) case x of Vbl {name=Local{}} -> do v <- U.findV x.name @@ -575,7 +582,7 @@ strictReturn notLazy sids x = strictness sids x where (filter ((`notElem` sids) • QName.uid) env) (ex, syms) <- strictness sids ex let strictSyms = my syms - sSsids = map Symbol.sid strictSyms + sSsids = map (view SymbolT.sid) strictSyms upper = [ sres | (loc, sres) <- zip env results, QName.uid loc `elem` sSsids ] result = fold uni (them syms) upper @@ -620,10 +627,10 @@ strictReturn notLazy sids x = strictness sids x where E.fatal (getpos x) (text ("no strictness rule, turn on -xs -xr " ++ show (getpos x))) stio (x, []) where - names g = show • map (flip QName.nice g • Symbol.name) - inter as = filter (\b -> elemBy (using Symbol.sid) b as) + names g = show . map (flip QName.nice g . view SymbolT.name) + inter as = filter (\b -> elemBy (using $ view SymbolT.sid) b as) uni :: [Symbol] -> [Symbol] -> [Symbol] - uni as bs = as ++ [ b | b <- bs, not (elemBy (using Symbol.sid) b as)] + uni as bs = as ++ [ b | b <- bs, not (elemBy (using $ view SymbolT.sid) b as)] maxss (S s1) (S s2) = S (zipWith maxss s1 s2) maxss U s = s maxss s _ = s @@ -640,8 +647,8 @@ strictReturn notLazy sids x = strictness sids x where -- mark a symbol as strict mark sym = do g <- getST - E.logmsg TRACES (Symbol.pos sym) (text (nice sym.name g ++ " marked as strict")) - when (sym.strsig == U) do changeSym sym.{strsig = S[]} + E.logmsg TRACES (view SymbolT.pos sym) (text (nice (view SymbolT.name sym) g ++ " marked as strict")) + when (unsafePartialView SymbolT.strsig sym == U) do changeSym $ set SymbolT.strsig (S[]) sym -- strictness for case alternative, same as in lambda strictAlt (alt@CAlt {pat,ex}) = do (lam, syms) <- strictness sids (Lam {pat,ex,typ=Nothing}) @@ -679,25 +686,25 @@ strictReturn notLazy sids x = strictness sids x where Con {name} -> U.findD name Vbl {name} -> U.findV name _ -> E.fatal (getpos f) (text ("Can't handle " ++ nice f g ++ " applications")) - let fsym | Local {} <- v.name = [v] + let fsym | Local {} <- view SymbolT.name v = [v] | otherwise = [] mkAll = do fapp <- mapSt (strictness sids) (map fst app) let napp = zip (map fst fapp) (map snd app) stio (napp, fsym) case v of - SymV {state = Typechecked, expr = Nothing} = mkAll - SymV {state = Typechecked, expr = Just _} - | Just (Lam{}) <- v.gExpr g = if v.sid `elem` sids + SymbolT.V (SymV{state = Typechecked, expr = Nothing}) = mkAll + SymbolT.V (symv@SymV{state = Typechecked, expr = Just _}) + | Just (Lam{}) <- symv.gExpr g = if symv.sid `elem` sids then do -- assume all are strict asx <- mapSt (strictness sids) (map fst as) stio ((f,mbt):zip (map fst asx) (map snd as), fold uni fsym (map snd asx)) else do - strictName sids v.name + strictName sids symv.name appstr app -- repeat - SymV {state = Typechecked, expr = Just dx} - | v.sid `notElem` sids = do + Symbol.V (symv@SymV{state = Typechecked, expr = Just dx}) + | symv.sid `notElem` sids = do -- inline pointless x <- dx let fx = flatx x @@ -705,21 +712,21 @@ strictReturn notLazy sids x = strictness sids x where let as = drop (length fx) fxas stio ((f,mbt):as, fsym ++ syms) | otherwise = mkAll - SymD {strsig = U} -> mkAll - SymD {strsig = S ss} -> do + SymbolT.D SymD{strsig = U} -> mkAll + SymbolT.D SymD{strsig = S ss} -> do let xss = take (length as) (ss ++ repeat U) -- make sure enough exsyms <- mapSt subapp (zip (map fst as) xss) stio ((f,mbt):zip (map fst exsyms) (map snd as), fold uni fsym (map snd exsyms)) - SymV {state = StrictChecked, strsig = U} -> mkAll - SymV {state = StrictChecked, strsig = S ss} -> do + SymbolT.V SymV{state = StrictChecked, strsig = U} -> mkAll + SymbolT.V (symv@SymV{state = StrictChecked, strsig = S ss}) -> do let xss = take (length as) (ss ++ repeat U) -- make sure enough - E.logmsg TRACES (getpos f) (text ("appstr: xss=" ++ show xss ++ " for " ++ v.name.nice g)) + E.logmsg TRACES (getpos f) (text ("appstr: xss=" ++ show xss ++ " for " ++ symv.name.nice g)) exsyms <- mapSt subapp (zip (map fst as) xss) stio ((f,mbt):zip (map fst exsyms) (map snd as), fold uni fsym (map snd exsyms)) - SymV {sid} -> do - E.fatal (v.pos) (text ("appstr: unexpected symbol " ++ nice v g - ++ ", state=" ++ show v.state - ++ ", expr=" ++ show (isJust v.expr))) + SymbolT.V symv -> do + E.fatal symv.pos (text ("appstr: unexpected symbol " ++ nice v g + ++ ", state=" ++ show symv.state + ++ ", expr=" ++ show (isJust symv.expr))) _ -> error "appstr: no appropriate sym" appstr _ = error "appstr: []" diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index 39d71afe..dd774d6e 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -44,6 +44,8 @@ import frege.Prelude hiding(<+>, break) import Data.TreeMap as TM(insert, lookup, values, keys, TreeMap, each, contains) import Data.List as DL(find, unique, sortBy, groupBy) +import frege.compiler.common.Lens (preview, set, unsafePartialView, view) + import Compiler.enums.Flags as Compilerflags(TRACE5, isOn, flagClr, flagSet, NODOCWARNINGS) import Compiler.enums.TokenID import Compiler.enums.Visibility @@ -115,9 +117,9 @@ fixity (d@FixDcl{pos, opid, ops}) = foreach ops changeop g ← getST let qo = VName g.thisPack op vals = values g.thisTab - typemembers = [ MName name op | t@(SymbolT.T SymT{name}) <- vals, g.our name ] - classmembers = [ MName name op | t@SymC{name} <- vals, g.our name ] - instmembers = [ MName name op | t@SymI{name} <- vals, g.our name ] + typemembers = [ MName name op | SymbolT.T SymT{name} <- vals, g.our name ] + classmembers = [ MName name op | SymbolT.C SymC{name} <- vals, g.our name ] + instmembers = [ MName name op | SymbolT.I SymI{name} <- vals, g.our name ] members = typemembers ++ classmembers ++ instmembers syms = mapMaybe g.findit (qo:members) foreach syms change @@ -126,13 +128,13 @@ fixity (d@FixDcl{pos, opid, ops}) = foreach ops changeop change sym = do g <- getST - if sym.{op?} - then do - unless (g.our sym.name || sym.op == defaultInfix || sym.op == opid) do + case preview SymbolT.op sym of + Just op -> do + unless (g.our (view SymbolT.name sym) || op == defaultInfix || op == opid) do E.hint pos (text ("Should you change associativity/precedence for " - ++ nicer sym.name g)) - changeSym sym.{op=opid} - else do + ++ nicer (view SymbolT.name sym) g)) + changeSym $ set SymbolT.op opid sym + Nothing -> E.error pos (text (nicer sym g ++ " cannot have a precedence")) @@ -142,11 +144,12 @@ inlineCandidates = do rslvd <- mapM (toQ g.thisPack) g.sub.toExport g <- getST when (g.errors == 0) do - syms <- mapM U.findV rslvd + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + syms <- mapM (fmap unsafeToSymV . U.findV) rslvd -- for the time being, inlining higher rank functions is not supported - foreach syms (\sym -> changeSym sym.{exported=notHigherConstraint sym}) + foreach syms (\sym -> changeSym $ SymbolT.V sym.{exported=notHigherConstraint sym}) let zs = zip syms g.sub.toExport - foreach [ (s,p) | (s,p) <- zs, not (g.ourSym s) || isNothing (Symbol.expr s) ] notOurCode + foreach [ (s,p) | (s,p) <- zs, not (g.ourSym $ SymbolT.V s) || isNothing s.expr ] notOurCode return () where -- silently remove higher rank functions with contexts from export @@ -160,8 +163,8 @@ inlineCandidates = do notOurCode (sym, p) = do g <- getST E.warn (Pos (SName.id p) (SName.id p)) - (text ("Cannot export code of " ++ nicer sym g - ++ (if g.ourSym sym + (text ("Cannot export code of " ++ nicer (SymbolT.V sym) g + ++ (if g.ourSym (SymbolT.V sym) then " because it has none." -- no code else " because defined elsewhere.") -- not our )) @@ -223,9 +226,9 @@ transFunDcl env fname (d@FunDcl {positions}) = do where pos = if null positions then getpos d.lhs else positionOf (head positions) classMember (MName tynm _) g = case g.findit tynm of - Just SymC{} = true - Just SymI{} = true - other = false + Just (SymbolT.C _) = true + Just (SymbolT.I _) = true + other = false classMember other g = false common aname d = do g <- getST @@ -234,10 +237,10 @@ transFunDcl env fname (d@FunDcl {positions}) = do where rest g = case g.findit aname of Just sym - | SymV {pos} <- sym = do + | SymbolT.V symv <- sym = do let funex = foldr (\p\e → Lam p e false) d.expr d.pats -- lamNil p e = Lam p e Nothing - let nowarn = case sym.doc of + let nowarn = case symv.doc of Nothing → false Just s → s ~ '^\s*nowarn:' when (nowarn) do @@ -248,29 +251,29 @@ transFunDcl env fname (d@FunDcl {positions}) = do case varcon x of -- make non local, unannotated definitions like @a = b@ into aliases Just name - | !sym.anno, - !sym.name.isLocal, - !(classMember aname g), + | not symv.anno, + not symv.name.isLocal, + not (classMember aname g), Just osym <- g.findit name, -- make sure there is no precedence conflict - sym.op == osym.op || sym.op == defaultInfix || osym.op == defaultInfix, + symv.op == unsafePartialView SymbolT.op osym || symv.op == defaultInfix || unsafePartialView SymbolT.op osym == defaultInfix, -- no loops, please! - name != sym.name = do - let alias = SymL{sid=sym.sid, - pos=sym.pos, - vis=sym.vis, - name=sym.name, + name != symv.name = do + let alias = SymL{sid=symv.sid, + pos=symv.pos, + vis=symv.vis, + name=symv.name, alias=name} -- - when (osym.op != sym.op && sym.op != defaultInfix) do - when (osym.op != defaultInfix) do - E.warn pos (msgdoc ("This changes associativity/precedence for " - ++ nicer osym.name g + when (unsafePartialView SymbolT.op osym != symv.op && symv.op != defaultInfix) do + when (unsafePartialView SymbolT.op osym != defaultInfix) do + E.warn symv.pos (msgdoc ("This changes associativity/precedence for " + ++ nicer (view SymbolT.name osym) g ++ " to the one given for " - ++ nicer sym.name g)) - changeSym osym.{op=sym.op} - changeSym alias - othr -> changeSym sym.{expr = Just (return x)} + ++ nicer symv.name g)) + changeSym $ set SymbolT.op symv.op osym + changeSym $ SymbolT.L alias + othr -> changeSym $ SymbolT.V symv.{expr = Just (return x)} | otherwise = E.fatal pos (text ("expected function, found " ++ sym.nice g)) nothing -> do E.fatal pos (text ("Cannot happen, function " ++ aname.nice g ++ " missing")) @@ -287,11 +290,11 @@ transAnnDcl env fname (d@AnnDcl {pos}) = do case g.findit aname of Nothing -> do E.fatal pos (text ("Cannot happen, function " ++ aname.nice g ++ " missing")) Just sym - | SymV {pos} <- sym = do + | SymbolT.V symv <- sym = do t <- transSigma d.typ - changeSym sym.{typ = t, anno=true} - E.logmsg TRACE5 pos (text ("function " ++ aname.nice g ++ " = " ++ t.nice g)) - | SymL{pos=dpos, name, alias} <- sym, g.our name = + changeSym $ SymbolT.V symv.{typ = t, anno=true} + E.logmsg TRACE5 symv.pos (text ("function " ++ aname.nice g ++ " = " ++ t.nice g)) + | SymbolT.L SymL{pos=dpos, name, alias} <- sym, g.our name = E.error pos (msgdoc ("function " ++ name.nice g ++ " has been defined as alias for " ++ alias.nicer g ++ ". Place this annotation before line " ++ show dpos.line @@ -305,28 +308,28 @@ transNatDcl env fname (d@NatDcl {pos}) = do case g.findit aname of Nothing -> do E.fatal pos (text ("Cannot happen, function " ++ aname.nice g ++ " missing")) Just sym - | SymV {pos} <- sym = case d.txs of + | SymbolT.V symv <- sym = case d.txs of [(sig, thrs)] = do t <- transSigma sig thrs <- mapM transTau thrs >>= mapM U.forceTau - gargs ← mkGargs false sym d t - changeSym sym.{typ = t, throwing = thrs, gargs} + gargs <- mkGargs false symv d t + changeSym $ SymbolT.V symv.{typ = t, throwing = thrs, gargs} overloaded = do - over <- mapM (uncurry (overload d sym)) overloaded - changeSym sym.{typ = ovlsigma, over} + over <- mapM (uncurry (overload d symv)) overloaded + changeSym $ SymbolT.V symv.{typ = ovlsigma, over} | otherwise = E.fatal pos (text ("expected function, found " ++ sym.nice g)) where - overload :: NatDcl -> Symbol -> SigmaS -> [TauS] -> StG QName + overload :: NatDcl -> SymV Global -> SigmaS -> [TauS] -> StG QName overload def sym sig exs = do g <- getST let name = U.unusedASCIIName sym.name g t <- transSigma sig thrs <- mapM transTau exs >>= mapM U.forceTau gargs ← mkGargs true sym def t - enter sym.{sid=0, name, typ = t, throwing = thrs, vis = Protected, gargs} + enter $ SymbolT.V sym.{sid=0, name, typ = t, throwing = thrs, vis = Protected, gargs} return name -- extract and translate generic type arguments - mkGargs ∷ Bool → Symbol → NatDcl → Sigma → StG [Tau] + mkGargs :: Bool -> SymV Global -> NatDcl -> Sigma -> StG [Tau] mkGargs ovld sym d sig = do g ← getST dgargs ← case d.gargs of @@ -432,11 +435,11 @@ transInsDcl env fname (d@InsDcl {pos}) = do let iname = TName g.thisPack (Enter.insName d) case g.findit iname of Just sym - | SymI {pos} <- sym = do + | SymbolT.I (symi@SymI{pos}) <- sym = do clas <- defaultXName pos (TName pPreludeBase "Eq") d.clas typ <- U.transSigma d.typ E.logmsg TRACE5 pos (text ("instance " ++ QName.nice clas g ++ " (" ++ Sigma.nice typ g ++ ")")) - changeSym sym.{clas,typ} + changeSym $ SymbolT.I symi.{clas,typ} foreach d.defs (transdef [] (MName iname)) nothing -> do E.fatal pos (text ("Cannot happen, instance " ++ iname.nice g ++ " missing")) @@ -455,7 +458,7 @@ private refreshType name pos vars sym = do dtau = dtcon.mkapp vars :: Tau !dsig = ForAll vars (RhoTau [] dtau) !kind = foldr KApp KType dsig.kinds :: Kind - newsym = sym.{typ=dsig, kind=kind} + newsym = set SymbolT.typ dsig $ set SymbolT.kind kind $ sym changeSym newsym pure newsym @@ -466,14 +469,14 @@ transDatDcl env fname (d@DatDcl {pos}) = do case g.findit tname of Just sym | SymbolT.T _ <- sym = do sym ← refreshTypeDatDcl d sym - foreach d.ctrs (transCon sym.typ (MName tname)) + foreach d.ctrs (transCon (unsafePartialView SymbolT.typ sym) (MName tname)) foreach d.defs (transdef [] (MName tname)) polymorphicFields tname U.findT tname >>= newtCheck other -> do E.fatal pos (text ("Cannot happen, data " ++ tname.nice g ++ " missing")) where newtCheck (SymbolT.T (symt@SymT{newt=true})) -- this is declared as newtype - | [con] ← [ c | c@SymD{} <- values symt.env ], -- so it has 1 constructor + | [con] ← [ c | SymbolT.D c <- values symt.env ], -- so it has 1 constructor [fld] ← [ f | f@Field {typ} <- con.flds ], -- with 1 field ForAll _ RhoTau{tau} ← fld.typ, -- which has some type tau TApp{} ← tau, -- that is an application @@ -485,21 +488,22 @@ transDatDcl env fname (d@DatDcl {pos}) = do <+/> text " cannot be a newtype and will be treated as data." ) changeSym $ SymbolT.T symt.{newt=false} -- make it data - changeSym con.{flds <- map _.{strict=true}} -- with strict field + changeSym $ SymbolT.D con.{flds <- map _.{strict=true}} -- with strict field pure () newtCheck other = pure () polymorphicFields tname = do - symt <- U.findT tname - let cons = [ c | c@SymD{} <- values symt.env ] + let unsafeToSymT s = case s of { SymbolT.T x -> x; } + symt <- unsafeToSymT <$> U.findT tname + let cons = [ c | SymbolT.D c <- values symt.env ] fields = [ f | con <- cons, -- from constructors - f@Field {name = Just n} <- Symbol.flds con, -- take named fields + f@Field {name = Just n} <- con.flds, -- take named fields not (null f.typ.bound) -- with polymorphic type ] ufields = map (("upd$" ++) • unJust • ConField.name) fields cfields = map (("chg$" ++) • unJust • ConField.name) fields - umethods = [ m | m@SymV{} <- values symt.env, -- methods that update a poly field + umethods = [ m | SymbolT.V m <- values symt.env, -- methods that update a poly field m.name.base `elem` ufields ] - cmethods = [ m | m@SymV{} <- values symt.env, -- methods that change a poly field + cmethods = [ m | SymbolT.V m <- values symt.env, -- methods that change a poly field m.name.base `elem` cfields ] foreach umethods (updPolyAnn symt fields) foreach cmethods (chgPolyAnn symt fields) @@ -510,14 +514,14 @@ transDatDcl env fname (d@DatDcl {pos}) = do -- NOTE Issue 203: the type of the record could only be changed if -- f was the only field that mentions outer bound type a -- Hence, poly-update will not be possible here. - updPolyAnn :: Symbol -> [ConField QName] -> Symbol -> StG () + updPolyAnn :: SymT Global -> [ConField QName] -> SymV Global -> StG () updPolyAnn dtyp flds meth = do g <- getST case find ((meth.name.base ==)•("upd$"++)•unJust•ConField.name) flds of Just cf -> do - E.logmsg TRACE5 (Symbol.pos meth) (text "polymorphic update " - <+> text (nice meth g) + E.logmsg TRACE5 meth.pos (text "polymorphic update " + <+> text (nice (SymbolT.V meth) g) <+> text " :: " <+> text (nice cf.typ g)) let mtyp = ForAll (dtyp.typ.bound) rho1 where @@ -526,8 +530,8 @@ transDatDcl env fname (d@DatDcl {pos}) = do ret = dtyp.typ.rho cft = cf.typ kim ← fst <$> kiSigma [] [] mtyp - changeSym meth.{typ = kim, anno = true} - E.logmsg TRACE5 meth.pos (text (nice meth g ++ " :: " ++ nicer mtyp g)) + changeSym $ SymbolT.V meth.{typ = kim, anno = true} + E.logmsg TRACE5 meth.pos (text (nice (SymbolT.V meth) g ++ " :: " ++ nicer mtyp g)) return () Nothing -> E.fatal dtyp.pos (text (nice meth.name g ++ ": field not found.")) -- determine type of chg$f method when field f is polymorphic, like in @@ -549,10 +553,10 @@ transDatDcl env fname (d@DatDcl {pos}) = do -- chg$listop :: Poly a -> (forall b.Functor b => (b a -> b a) -> b a -> b a) -> Poly a -- Note that the original function is instantiated at the constraint that gets passed -- to the changing function. - chgPolyAnn :: Symbol -> [ConField QName] -> Symbol -> StG () + chgPolyAnn :: SymT Global -> [ConField QName] -> SymV Global -> StG () chgPolyAnn dtyp flds meth = do g <- getST - E.logmsg TRACE5 (Symbol.pos meth) (text ("polymorphic change " ++ nice meth g)) + E.logmsg TRACE5 meth.pos (text ("polymorphic change " ++ nice (SymbolT.V meth) g)) case find ((meth.name.base ==)•("chg$"++)•unJust•ConField.name) flds of Just cf -> do -- we have: @@ -585,8 +589,8 @@ transDatDcl env fname (d@DatDcl {pos}) = do sigma = charg, rho = record}} kir ← fst <$> kiSigma [] [] result - changeSym meth.{typ = kir, anno = true} - E.logmsg TRACE5 meth.pos (text (nice meth g ++ " :: " ++ nicer kir g)) + changeSym $ SymbolT.V meth.{typ = kir, anno = true} + E.logmsg TRACE5 meth.pos (text (nice (SymbolT.V meth) g ++ " :: " ++ nicer kir g)) pure () Nothing -> E.fatal dtyp.pos (text (nice meth.name g ++ ": field not found.")) @@ -594,7 +598,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do g <- getST let cname = mname d.name case g.findit cname of - Just (con@SymD {pos}) = do + Just (SymbolT.D con) = do let transSigma1 (ForAll [] (RhoTau [] t)) = transTau t transSigma1 s = do -- field types can be sigmas ForAll bound frho <- U.validSigma1 (map _.var bndrs) s @@ -605,15 +609,14 @@ transDatDcl env fname (d@DatDcl {pos}) = do sigmas <- mapSt (transSigma1 • ConField.typ) d.flds let nfs sigs = zipWith ConField.{typ=} con.flds sigs typ = ForAll bndrs (foldr (RhoFun []) rho sigmas) - E.logmsg TRACE5 con.pos (text (con.nice g ++ " :: " ++ typ.nice g)) + E.logmsg TRACE5 con.pos (text ((SymbolT.D con).nice g ++ " :: " ++ typ.nice g)) sig <- U.validSigma typ >>= kiSigma [] [] >>= pure . fst let additional = filter (`notElem` map _.var bndrs) (map _.var sig.bound) unless (null additional) do - E.error pos (text ("type variable(s) " + E.error con.pos (text ("type variable(s) " ++ joined ", " additional ++ " may not appear in fields of " ++ d.name)) - -- when (con.strsig.isStrict) (foreach nfs (strictFieldsCheck cname)) - changeSym con.{typ=sig}.{flds=nfs . snd . U.returnType $ sig.rho} + changeSym $ SymbolT.D con.{typ=sig}.{flds=nfs . snd . U.returnType $ sig.rho} _ -> E.fatal pos (text ("constructor `" ++ cname.nice g ++ "` vanished.")) transJavDcl :: [QName] -> (String -> QName) -> JavDcl -> StG () @@ -624,7 +627,8 @@ transJavDcl env fname (d@JavDcl {pos}) = do Just sym | SymbolT.T SymT{nativ = Just nativ} <- sym = do -- Redo types - sym ← refreshTypeJavDcl d sym + let unsafeToSymT s = case s of { SymbolT.T x -> x; } + sym <- unsafeToSymT <$> refreshTypeJavDcl d sym -- extract and translate generic type arguments let doit (Just gs) = mapM transTau gs >>= mapM forceTau doit Nothing = pure sym.typ.tvars @@ -652,7 +656,7 @@ transJavDcl env fname (d@JavDcl {pos}) = do let typ = sym.typ.{bound ← map ktype} !kind = foldr KApp KType (map _.kind typ.bound) let purity = d.isPure || (nativ `elem` pureTypes) - changeSym sym.{pur = purity, gargs, typ, kind} + changeSym $ SymbolT.T sym.{pur = purity, gargs, typ, kind} foreach d.defs (transdef [] (MName tname)) U.nativeType nativ tname when (nativ ~ ´\[\]$´) do @@ -669,7 +673,7 @@ transClaDcl env fname (d@ClaDcl {pos}) = do ++ tname.nice g ++ " missing.")) -- stio Nothing Just sym - | SymC {pos} <- sym = do transclass d sym -- ; stio (Just d) + | SymbolT.C _ <- sym = do transclass d sym -- ; stio (Just d) | otherwise = do E.fatal pos (text ("expected class, found " ++ sym.nice g)) @@ -726,10 +730,11 @@ transPatUnique fname pat = do Vbl{name} | Simple t <- name = do u <- uniqid + let unsafeToSymV s = case s of { SymbolT.V x -> x; } let pos = positionOf t var = t.value - sym = U.patLocal pos u var - enter sym + sym = unsafeToSymV $ U.patLocal pos u var + enter $ SymbolT.V sym when (var != "_") do changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk t) (Right sym.name)}} @@ -800,8 +805,9 @@ transPatUnique fname pat = do pat <- transPat fname pat case pat of PVar{pos, uid, var} -> do - sym <- U.findV Local{uid, base=var} - changeSym sym.{state=StrictChecked, + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + sym <- unsafeToSymV <$> U.findV Local{uid, base=var} + changeSym $ SymbolT.V sym.{state=StrictChecked, strsig = if s == "?" then U else S[]} return PUser{pat, lazy=s=="?"} _ -> return PUser{pat, lazy=s=="?"} @@ -827,7 +833,7 @@ transPatUnique fname pat = do | Just p <- ft.lookup x = return p fpat other = transPat fname (Vbl Simple{id = name.id.{tokid=VARID, value="_"}}) case g.findit qname of - Just (SymD {flds}) -> do + Just (SymbolT.D SymD{flds}) -> do let fs = [ f | Field {name = Just f} <- flds ] badfs = filter (`notElem` fs) pfs pats <- mapSt fpat (map ConField.name flds) @@ -848,7 +854,7 @@ transPatUnique fname pat = do checkCon pos qcon ps = do g <- getST case g.findit qcon of - Just (SymD {flds}) + Just (SymbolT.D SymD{flds}) | length flds == length ps = stio () | otherwise = E.error pos (msgdoc ("constructor " ++ qcon.nice g ++ " demands " ++ show (length flds) @@ -942,12 +948,13 @@ transExpr env fname ex = do nenv <- foldM enterlocal [] (annosLast defs) foreach defs (transLetMemberS (nenv++env) fname) ex <- transExpr (nenv++env) fname ex - syms <- mapSt U.findV nenv - foreach (syms) checkDefined + let unsafeToSymV s = case s of { SymbolT.V x -> x; } + syms <- mapSt (fmap unsafeToSymV . U.findV) nenv + foreach syms checkDefined stio (D.Let {env=nenv, ex, typ=Nothing}) where checkDefined (SymV {expr = Just _}) = stio () - checkDefined sym = E.error sym.pos (msgdoc (nice sym g ++ " is annotated but not defined.")) + checkDefined sym = E.error sym.pos (msgdoc (nice (SymbolT.V sym) g ++ " is annotated but not defined.")) enterlocal :: [QName] -> LetMemberS -> StG [QName] enterlocal env def = case findLocal env (defname def) of Local 0 _ = do -- not yet entered @@ -1002,7 +1009,7 @@ transExpr env fname ex = do let vUndef = D.Vbl (pos.change VARID "undefined") (VName pPreludeBase "undefined") Nothing g <- getST case g.findit name of - Just (symd@SymD {}) -> do + Just (SymbolT.D symd) -> do let xnms = map fst fields flds = [ f | Field {name = Just f} <- symd.flds ] badf = filter (`notElem` flds) xnms @@ -1017,14 +1024,14 @@ transExpr env fname ex = do f2s = if length miss == 1 then "field " else "fields " unless (null badf) do g <- getST - E.error pos (msgdoc (nice symd g ++ " has no " ++ f1s ++ joined ", " badf)) + E.error pos (msgdoc (nice (SymbolT.D symd) g ++ " has no " ++ f1s ++ joined ", " badf)) unless (null miss) do g <- getST E.error pos (msgdoc (f2s ++ joined ", " miss ++ " missing in construction of " ++ symd.name.nice g)) stio res Just sym -> do - when (g.errors == 0 && sym.name.base != "undefined") do + when (g.errors == 0 && (view SymbolT.name sym).base != "undefined") do E.error pos (msgdoc ("looked for constructor " ++ name.nice g ++ ", found " ++ sym.nice g)) stio vUndef @@ -1046,7 +1053,7 @@ transExpr env fname ex = do checkCon pos qcon = do g <- getST case g.findit qcon of - Just (SymD {}) -> return () + Just (SymbolT.D _) -> return () nothing -> when (g.errors == 0) do E.error pos (msgdoc (pos.last.value ++ " is not a data constructor")) @@ -1102,10 +1109,10 @@ ordInfix fname (orig@Infx{name, left, right}) bindright = return Infx{name, left, right} -- a $ x+1 == a $ (x+1) case (g.findit op1, g.findit op2) of (Just sym1, Just sym2) = - if prec sym1.op > prec sym2.op then bindleft - else if prec sym1.op < prec sym2.op then bindright + if prec (unsafePartialView SymbolT.op sym1) > prec (unsafePartialView SymbolT.op sym2) then bindleft + else if prec (unsafePartialView SymbolT.op sym1) < prec (unsafePartialView SymbolT.op sym2) then bindright else -- equal precedence - case (assoc sym1.op, assoc sym2.op) of + case (assoc (unsafePartialView SymbolT.op sym1), assoc (unsafePartialView SymbolT.op sym2)) of ("left", "left") -> bindleft ("right", "right") -> bindright (left, right) -> do @@ -1167,10 +1174,11 @@ assoc t transclass :: ClaDcl -> Symbol -> StG () -transclass def sym = do +transclass def sym' = do + let sym = case sym' of { SymbolT.C x -> x; } supers <- liftM (map unJust • filter isJust) - (mapSt (resolveXName def.pos sym) def.supers) - changeSym sym.{supers = unique supers} + (mapSt (resolveXName def.pos $ SymbolT.C sym) def.supers) + changeSym $ SymbolT.C sym.{supers = unique supers} g <- getST foreach def.members (transdef [] (MName sym.name) . _.toDefinitionS) diff --git a/frege/compiler/passes/TypeAlias.fr b/frege/compiler/passes/TypeAlias.fr index 9b9ef217..16a62dd3 100644 --- a/frege/compiler/passes/TypeAlias.fr +++ b/frege/compiler/passes/TypeAlias.fr @@ -9,6 +9,8 @@ package frege.compiler.passes.TypeAlias where import frege.Prelude hiding (<+>) +import frege.compiler.common.Lens (set) + import Data.Graph (stronglyConnectedComponents tsort) import Lib.PP (msgdoc, text, <+>) @@ -49,10 +51,10 @@ pass = do Nothing -> acc Just tn | tn `elem` acc = acc - | Just (SymA {name}) <- g.findit tn = if name `elem` acc then acc else name:acc + | Just (SymbolT.A SymA{name}) <- g.findit tn = if name `elem` acc then acc else name:acc | otherwise = acc -- do not complain about unknown type constructors getpos tn - | Just (SymA {pos}) <- g.findit tn = pos + | Just (SymbolT.A SymA{pos}) <- g.findit tn = pos | otherwise = Position.null checkmutual [] = stio () checkmutual [a] = stio () @@ -86,12 +88,12 @@ transalias (d@TypDcl {pos}) = do g <- getST let tname = TName g.thisPack d.name case g.findit tname of - Just sym | SymA {pos} <- sym = case d.typ.bound of + Just sym | SymbolT.A SymA{pos} <- sym = case d.typ.bound of [] -> do -- type aliases may be incomplete typS <- U.validSigma1 (map Tau.var d.vars) d.typ typ <- U.transSigma (ForAll [] typS.rho) - changeSym sym.{typ = typ.{bound=[]}} + changeSym $ set SymbolT.typ typ.{bound=[]} sym bound -> do -- type X a b c = forall x y. ...... -- The bound variables x y must be distinct from the type args a b c @@ -104,7 +106,7 @@ transalias (d@TypDcl {pos}) = do if null badfree then do typ1 <- U.transSigma d.typ.{bound=[]} bounds ← U.transBounds bound - changeSym sym.{typ = typ1.{bound=bounds}} + changeSym $ set SymbolT.typ typ1.{bound=bounds} sym pure () else E.error pos (text "Type variable(s) " diff --git a/frege/compiler/tc/Methods.fr b/frege/compiler/tc/Methods.fr index 67114e7a..58ae9284 100644 --- a/frege/compiler/tc/Methods.fr +++ b/frege/compiler/tc/Methods.fr @@ -39,6 +39,8 @@ package frege.compiler.tc.Methods where import frege.Prelude hiding (<+>) +import frege.compiler.common.Lens (unsafePartialView, view) + import frege.compiler.Utilities as U() import Lib.PP (msgdoc, text, <+>, <+/>, nest) import Data.TreeMap as TM(keys, TreeMap) @@ -127,7 +129,7 @@ niKind _ = NIStatic - A pure native function may not return mutable data. -} -sanity (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, over}) +sanity (SymbolT.V (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, over})) | not (null over) = return () -- | otherwise = do unconstrained typ.rho @@ -183,7 +185,7 @@ sanity (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, over}) g <- getST let ctxs = case name of MName{tynm, base} - | Just SymC{} <- g.findit tynm + | Just (SymbolT.C _) <- g.findit tynm = filter ((!= tynm) . Context.cname) (Rho.context r) _ = r.context case ctxs of @@ -258,7 +260,7 @@ sanity (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, over}) goodMutable g phantom p r tau case phantom of -- warn if we have a mutable result of a non-function - Nothing | null args = U.symWarning E.warn symv (msgdoc("note that the java expression " + Nothing | null args = U.symWarning E.warn (SymbolT.V symv) (msgdoc("note that the java expression " ++ item ++ " is supposed to be constant." ++ " Consider using IO or ST if the native implementation" ++ " could modify it.")) @@ -397,7 +399,7 @@ sanity (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, over}) text "A pure native function may not consume or produce mutable data.") return Nothing | Just sym <- instTauSym r g = do - case sym.nativ of + case unsafePartialView SymbolT.nativ sym of Nothing -> do E.error (getpos r) ( text "The type " @@ -407,7 +409,7 @@ sanity (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, over}) <+> text " is not a native type.") return Nothing -- it is at least a native one - _ | sym.pur = do + _ | unsafePartialView SymbolT.pur sym = do E.error (getpos r) ( text "The type " <+> text (nicer tau g) @@ -465,7 +467,7 @@ sanity (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, over}) sanity sym = do g <- getST - E.fatal sym.pos (msgdoc ("cannot check native function type sanity for " ++ nicer sym g)) + E.fatal (view SymbolT.pos sym) (msgdoc ("cannot check native function type sanity for " ++ nicer sym g)) --- structural equality of 'Tau' types, variables are not unified, but compared by name matches :: Tau -> Tau -> Bool diff --git a/frege/compiler/tc/Util.fr b/frege/compiler/tc/Util.fr index d104ce81..6acabde5 100644 --- a/frege/compiler/tc/Util.fr +++ b/frege/compiler/tc/Util.fr @@ -289,10 +289,9 @@ getTauTvsT g t (TSig s) = fold including t (sigmaTvs g s) envTvs g sid = [ m | q <- g.typEnv, sym <- g.findit q, - sym <- (g.follow sym), -- follow aliases - sym.{expr?}, - sym.sid != sid, - m <- sigmaTvs g sym.typ ] + SymbolT.V symv <- (g.follow sym), -- follow aliases + symv.sid != sid, + m <- sigmaTvs g symv.typ ] --- read a type var monadically readTv :: MetaTv -> StG (Maybe Tau) @@ -442,10 +441,11 @@ unified ex tau1 tau2 = do g ← getST E.logmsg TRACET (getpos ex) (text ("unifyj: " ++ nice t1 g ++ " and " ++ nice t2 g)) sym1 <- U.findT t1 - case sym1.nativ of + let unsafeNativ (SymbolT.T s) = s.nativ + case unsafeNativ sym1 of Just c1 -> do sym2 <- U.findT t2 - case sym2.nativ of + case unsafeNativ sym2 of Just c2 -- Don't unify A and B when either one is based on a primitive type -- not even (and foremost) if it's the same one! @@ -502,7 +502,6 @@ unifyVar ex tv lrtau = do nicest g ex) stio false else case tv.kind of - -- KGen t -> unifyKinded t tau other -> do writeTv tv tau g <- getST @@ -511,12 +510,6 @@ unifyVar ex tv lrtau = do ++ tv.nice g ++ " :: " ++ show tv.kind)) stio true - -- We have tv≤Foo and Bar - -- Unification is ok when Bar is a subtype of Foo - -- We need to expand the MetaTv one step - unifyKinded t tau = do - st ← substMeta tv.uid (Meta tv) t - unified ex st tau --- substitute MetaTV with given UID in a Tau substMeta ∷ Int → Tau → Tau → StG Tau @@ -704,7 +697,7 @@ contexts ex typ = do Let {env,ex} -> do let ectx = exContext g ex syms <- mapSt U.findV env - subexs <- sequence [ ex | SymV {expr = Just ex} <- syms ] + subexs <- sequence [ ex | SymbolT.V SymV{expr = Just ex} <- syms ] let rctxss = map (exContext g) subexs let rctxs = [ ctx | ctxs <- rctxss, ctx <- ctxs ] -- take only contexts that have at least 1 flexi tv @@ -854,7 +847,8 @@ instanceOf pos qn tau = do case tcon of TCon {name} -> do E.logmsg TRACET pos (text ("tcon is " ++ showtn name)) - clas <- findC qn + let unsafeToSymC (SymbolT.C s) = s + clas <- unsafeToSymC <$> findC qn E.logmsg TRACET pos (text ("class " ++ showtn clas.name ++ " has instances for " ++ joined ", " (map (showtn • fst) clas.insts))) case filter ((name ==) • fst) clas.insts of @@ -862,7 +856,8 @@ instanceOf pos qn tau = do E.error pos (msgdoc (nicer tau g ++ " is not an instance of " ++ nice qn g)) stio [] (_,iname):_ -> do - inst <- findI iname + let unsafeToSymI (SymbolT.I s) = s + inst <- unsafeToSymI <$> findI iname E.logmsg TRACET pos (text ("found instance " ++ nicer inst.typ g)) E.explain pos (text ("there is an instance for " ++ nicer inst.typ g)) rho <- instantiate inst.typ diff --git a/frege/compiler/types/Global.fr b/frege/compiler/types/Global.fr index 00de434d..1f3214c8 100644 --- a/frege/compiler/types/Global.fr +++ b/frege/compiler/types/Global.fr @@ -8,6 +8,7 @@ import frege.data.TreeMap as TM(TreeMap, each) import frege.java.Net(URLClassLoader) import frege.control.monad.State (State, StateT) +import frege.compiler.common.Lens (preview, view) import frege.compiler.enums.Flags as Compilerflags(Flag, Flags, isOn, isOff) import frege.compiler.enums.TokenID(TokenID) import frege.compiler.types.Positions @@ -197,7 +198,7 @@ data Global = !Global { --- tell if a 'Symbol' is from the module we're just compiling ourSym :: Global -> Symbol -> Bool - ourSym g sy = our g (Symbol.name sy) + ourSym g sy = our g (view Symbol.name sy) --- find the 'Symbol' for a 'QName', which may be a 'SymL' (symbolic link) find :: Global -> QName -> Maybe Symbol @@ -212,14 +213,14 @@ data Global = !Global { --- find a member of a type, type class or instance findm ∷ Global → QName → String → Maybe Symbol findm g t s = case findit g t of - Just sy | sy.{env?} = sy.env.lookupS s - Just (SymA {typ}) = case instTSym typ g of + Just sy | Just env <- preview SymbolT.env sy = env.lookupS s + Just (SymbolT.A SymA{typ}) = case instTSym typ g of Just sym - | Just r <- findm g sym.name s = Just r + | Just r <- findm g (view SymbolT.name sym) s = Just r | ForAll _ (RhoTau{tau=tau1}) <- typ, -- look if its [TCon{name}, _, tau2] <- tau1.flat, -- type T = Mutable s X name == TName pPreludeIO "Mutable", -- and look into X - Just other <- instTauSym tau2 g = findm g other.name s + Just other <- instTauSym tau2 g = findm g (view SymbolT.name other) s | otherwise = Nothing Nothing -> Nothing _ -> Nothing @@ -230,7 +231,7 @@ data Global = !Global { Nothing -> Nothing --- follow a symbolic link follow ∷ Global → Symbol → Maybe Symbol - follow g (ali@SymL {alias}) = findit g alias + follow g (SymbolT.L SymL{alias}) = findit g alias follow g sym = Just sym --- tell if the 'MetaTv' is bound diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 688ed560..2fbaf5d7 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -3,6 +3,7 @@ module frege.compiler.types.Symbols where import frege.data.TreeMap as TM(TreeMap, each, values) import frege.control.monad.State +import frege.compiler.common.Lens (preview, view) import frege.compiler.enums.RFlag(RState, RFlag) import frege.compiler.types.Positions import frege.compiler.types.Strictness @@ -54,7 +55,7 @@ data SymC global = !SymC --- instance data SymI global = !SymI { sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name ::QName, - clas::QName, typ::Sigma, + clas::QName, typ::Sigma, env::TreeMap String (SymbolT global) } @@ -63,8 +64,8 @@ data SymV global = !SymV { sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name ::QName, typ::Sigma, --- For imported expressions, we will make them on demand - expr::Maybe (ExprD global), - nativ::Maybe String, + expr::Maybe (ExprD global), + nativ::Maybe String, pur::Bool, anno::Bool, exported::Bool, state::SymState, strsig :: Strictness, depth :: Int, rkind :: RState, throwing :: [Tau] --- list of exceptions thrown @@ -79,6 +80,7 @@ data SymV global = !SymV has sym bit = bit RState.`member` sym.rkind --- Check if this is 'RMethod' isMethod sym = has sym RMethod + gExpr SymV{expr} g = fmap (\x -> evalState x g) expr --- type alias data SymA global = !SymA @@ -98,32 +100,131 @@ data SymbolT global = | protected V (SymV global) --- variable or function | protected A (SymA global) --- type alias where - hashCode = SymbolT.sid - gExpr SymV{expr=Just x} g = Just (evalState x g) - gExpr _ _ = Nothing - -- functions for querying the field 'Symbol.rkind' - --- Check certain bit in 'Symbol.rkind' - has ∷ SymbolT a → RFlag → Bool - has sym bit = bit RState.`member` sym.rkind - --- Check if this is 'RMethod' - isMethod sym = has sym RMethod + hashCode :: SymbolT global -> Int + hashCode = view SymbolT.sid + + -- doc :: Traversal' (SymbolT g) (Maybe String) + doc :: Applicative f => (Maybe String -> f (Maybe String)) -> SymbolT g -> f (SymbolT g) + doc f (T s) = (\doc -> T s.{doc}) <$> f s.doc + doc _ (sym@(L _)) = pure sym + doc f (D s) = (\doc -> D s.{doc}) <$> f s.doc + doc f (C s) = (\doc -> C s.{doc}) <$> f s.doc + doc f (I s) = (\doc -> I s.{doc}) <$> f s.doc + doc f (V s) = (\doc -> V s.{doc}) <$> f s.doc + doc f (A s) = (\doc -> A s.{doc}) <$> f s.doc + -- env :: Traversal' (SymbolT g) (TreeMap String (SymbolT g)) + env :: Applicative f => (TreeMap String (SymbolT g) -> f (TreeMap String (SymbolT g))) -> SymbolT g -> f (SymbolT g) + env f (T s) = (\env -> T s.{env}) <$> f s.env + env _ (sym@(L _)) = pure sym + env _ (sym@(D _)) = pure sym + env f (C s) = (\env -> C s.{env}) <$> f s.env + env f (I s) = (\env -> I s.{env}) <$> f s.env + env _ (sym@(V _)) = pure sym + env _ (sym@(A _)) = pure sym + -- kind :: Traversal' (SymbolT g) Kind + kind :: Applicative f => (Kind -> f Kind) -> SymbolT g -> f (SymbolT g) + kind f (T s) = (\kind -> T s.{kind}) <$> f s.kind + kind _ (sym@(L _)) = pure sym + kind _ (sym@(D _)) = pure sym + kind _ (sym@(C _)) = pure sym + kind _ (sym@(I _)) = pure sym + kind _ (sym@(V _)) = pure sym + kind f (A s) = (\kind -> A s.{kind}) <$> f s.kind + -- name :: Lens' (SymbolT g) QName + name :: Functor f => (QName -> f QName) -> SymbolT g -> f (SymbolT g) + name f (T s) = (\name -> T s.{name}) <$> f s.name + name f (L s) = (\name -> L s.{name}) <$> f s.name + name f (D s) = (\name -> D s.{name}) <$> f s.name + name f (C s) = (\name -> C s.{name}) <$> f s.name + name f (I s) = (\name -> I s.{name}) <$> f s.name + name f (V s) = (\name -> V s.{name}) <$> f s.name + name f (A s) = (\name -> A s.{name}) <$> f s.name + -- nativ :: Traversal' (SymbolT g) (Maybe String) + nativ :: Applicative f => (Maybe String -> f (Maybe String)) -> SymbolT g -> f (SymbolT g) + nativ f (T s) = (\nativ -> T s.{nativ}) <$> f s.nativ + nativ _ (sym@(L _)) = pure sym + nativ _ (sym@(D _)) = pure sym + nativ _ (sym@(C _)) = pure sym + nativ _ (sym@(I _)) = pure sym + nativ f (V s) = (\nativ -> V s.{nativ}) <$> f s.nativ + nativ _ (sym@(A _)) = pure sym + -- op :: Traversal' (SymbolT g) TokenID + op :: Applicative f => (TokenID -> f TokenID) -> SymbolT g -> f (SymbolT g) + op _ (sym@(T _)) = pure sym + op _ (sym@(L _)) = pure sym + op f (D s) = (\op -> D s.{op}) <$> f s.op + op _ (sym@(C _)) = pure sym + op _ (sym@(I _)) = pure sym + op f (V s) = (\op -> V s.{op}) <$> f s.op + op _ (sym@(A _)) = pure sym + -- pos :: Lens' (SymbolT g) Position + pos :: Functor f => (Position -> f Position) -> SymbolT g -> f (SymbolT g) + pos f (T s) = (\pos -> T s.{pos}) <$> f s.pos + pos f (L s) = (\pos -> L s.{pos}) <$> f s.pos + pos f (D s) = (\pos -> D s.{pos}) <$> f s.pos + pos f (C s) = (\pos -> C s.{pos}) <$> f s.pos + pos f (I s) = (\pos -> I s.{pos}) <$> f s.pos + pos f (V s) = (\pos -> V s.{pos}) <$> f s.pos + pos f (A s) = (\pos -> A s.{pos}) <$> f s.pos + -- pur :: Traversal' (SymbolT g) Bool + pur :: Applicative f => (Bool -> f Bool) -> SymbolT g -> f (SymbolT g) + pur f (T s) = (\pur -> T s.{pur}) <$> f s.pur + pur _ (sym@(L _)) = pure sym + pur _ (sym@(D _)) = pure sym + pur _ (sym@(C _)) = pure sym + pur _ (sym@(I _)) = pure sym + pur f (V s) = (\pur -> V s.{pur}) <$> f s.pur + pur _ (sym@(A _)) = pure sym + -- sid :: Lens' (SymbolT g) Int + sid :: Functor f => (Int -> f Int) -> SymbolT g -> f (SymbolT g) + sid f (T s) = (\sid -> T s.{sid}) <$> f s.sid + sid f (L s) = (\sid -> L s.{sid}) <$> f s.sid + sid f (D s) = (\sid -> D s.{sid}) <$> f s.sid + sid f (C s) = (\sid -> C s.{sid}) <$> f s.sid + sid f (I s) = (\sid -> I s.{sid}) <$> f s.sid + sid f (V s) = (\sid -> V s.{sid}) <$> f s.sid + sid f (A s) = (\sid -> A s.{sid}) <$> f s.sid + -- strsig :: Traversal' (SymbolT g) Strictness + strsig :: Applicative f => (Strictness -> f Strictness) -> SymbolT g -> f (SymbolT g) + strsig _ (sym@(T _)) = pure sym + strsig _ (sym@(L _)) = pure sym + strsig f (D s) = (\strsig -> D s.{strsig}) <$> f s.strsig + strsig _ (sym@(C _)) = pure sym + strsig _ (sym@(I _)) = pure sym + strsig f (V s) = (\strsig -> V s.{strsig}) <$> f s.strsig + strsig _ (sym@(A _)) = pure sym + -- typ :: Traversal' (SymbolT g) Sigma + typ :: Applicative f => (Sigma -> f Sigma) -> SymbolT g -> f (SymbolT g) + typ f (T s) = (\typ -> T s.{typ}) <$> f s.typ + typ _ (sym@(L _)) = pure sym + typ f (D s) = (\typ -> D s.{typ}) <$> f s.typ + typ _ (sym@(C _)) = pure sym + typ f (I s) = (\typ -> I s.{typ}) <$> f s.typ + typ f (V s) = (\typ -> V s.{typ}) <$> f s.typ + typ f (A s) = (\typ -> A s.{typ}) <$> f s.typ + -- vis :: Lens' (SymbolT g) Visibility + vis :: Functor f => (Visibility -> f Visibility) -> SymbolT g -> f (SymbolT g) + vis f (T s) = (\vis -> T s.{vis}) <$> f s.vis + vis f (L s) = (\vis -> L s.{vis}) <$> f s.vis + vis f (D s) = (\vis -> D s.{vis}) <$> f s.vis + vis f (C s) = (\vis -> C s.{vis}) <$> f s.vis + vis f (I s) = (\vis -> I s.{vis}) <$> f s.vis + vis f (V s) = (\vis -> V s.{vis}) <$> f s.vis + vis f (A s) = (\vis -> A s.{vis}) <$> f s.vis --- Symbols ordered by the 'Symbol.sid' field, which is a unique number. --- This allows us to have sets of symbols. instance Ord (SymbolT g) where - sym1 <=> sym2 = (SymbolT.sid sym1). <=> (SymbolT.sid sym2) - sym1 == sym2 = (SymbolT.sid sym1). == (SymbolT.sid sym2) - sym1 != sym2 = (SymbolT.sid sym1). != (SymbolT.sid sym2) + sym1 <=> sym2 = (view SymbolT.sid sym1). <=> (view SymbolT.sid sym2) + sym1 == sym2 = (view SymbolT.sid sym1). == (view SymbolT.sid sym2) + sym1 != sym2 = (view SymbolT.sid sym1). != (view SymbolT.sid sym2) instance Positioned (SymbolT g) where is x = "" - getpos = SymbolT.pos - getrange sym - | sym.{env?} = fold Position.merge sym.pos (map getrange (values sym.env)) - -- SymV{expr = Just x} <- sym = sym.pos.merge x.getrange - | otherwise = getpos sym - -- untyped = id - - + getpos = view SymbolT.pos + getrange sym = + case preview SymbolT.env sym of + Just env -> fold Position.merge (view SymbolT.pos sym) (map getrange (values env)) + Nothing -> getpos sym diff --git a/frege/ide/Utilities.fr b/frege/ide/Utilities.fr index 4417be45..514d2d20 100644 --- a/frege/ide/Utilities.fr +++ b/frege/ide/Utilities.fr @@ -10,6 +10,8 @@ import frege.compiler.passes.Imp as I(getFP) import frege.compiler.tc.Util as TC import frege.compiler.Typecheck as TY hiding(pass, post) +import frege.compiler.common.Lens (preview, unsafePartialView, view) + import Compiler.enums.TokenID(TokenID, defaultInfix) import Compiler.enums.Visibility(Private, Public) import Compiler.enums.Flags @@ -145,6 +147,7 @@ instance Show Proposal where proposeContent :: Global -> Y RTree -> Int -> JArray Token -> Int -> [Proposal] proposeContent !global root !offset !tokens !index = propose where + unsafeToSymV (SymbolT.V x) = x snekot = backwards tokens index -- reverse order, last token before cursor on top thisline = takeWhile onThisLine snekot onThisLine tok = Token.line tok == token.line && tok.col > 0 @@ -229,8 +232,8 @@ proposeContent !global root !offset !tokens !index = propose after.line > token.line, traceLn("before ¦" ++ show after) || true, Token{tokid=VARID, value} ← after, - (sym:_) ← [ s | - s@SymV{expr=Just _} ← U.allourvars global ++ values global.locals, + (sym:_) ← [ SymbolT.V s | + SymbolT.V (s@SymV{expr=Just _}) <- U.allourvars global ++ values global.locals, s.name.base == value, -- not s.anno, s.pos.first.offset == offset], traceLn("rule anno ¦" ++ value) || true @@ -331,10 +334,10 @@ proposeContent !global root !offset !tokens !index = propose traceLn ("resolved " ++ nicer qname global) || true, Just sym <- global.findit qname, traceLn ("found " ++ sym.nice global) || true, - sym.anno, traceLn (sym.nice global ++ " is annotated") || true, - isNothing sym.nativ, traceLn (sym.nice global ++ " is not nativ") || true, - isNothing sym.expr, traceLn (sym.nice global ++ " has no expression") || true, - (_, sigmas) <- U.returnType sym.typ.rho, + (unsafeToSymV sym).anno, traceLn (sym.nice global ++ " is annotated") || true, + isNothing (unsafeToSymV sym).nativ, traceLn (sym.nice global ++ " is not nativ") || true, + isNothing (unsafeToSymV sym).expr, traceLn (sym.nice global ++ " has no expression") || true, + (_, sigmas) <- U.returnType (unsafeToSymV sym).typ.rho, = let conidProposals | direct, token.tokid == CONID = @@ -357,7 +360,7 @@ proposeContent !global root !offset !tokens !index = propose traceLn ("resolved " ++ value) || true, Just sym <- global.findit qname, traceLn ("found " ++ sym.nice global) || true, - RhoTau{tau} <- sym.typ.rho, + RhoTau{tau} <- (unsafePartialView SymbolT.typ sym).rho, tau <- TC.reduced tau global, traceLn ("type is " ++ nicer tau global) || true, Just (symbol@SymbolT.T _) <- instTauSym tau global @@ -369,7 +372,7 @@ proposeContent !global root !offset !tokens !index = propose traceLn ("resolved " ++ value) || true, Just sym <- global.findit qname, traceLn ("found " ++ sym.nice global) || true, - (tau,_) <- U.returnType sym.typ.rho, + (tau,_) <- U.returnType (unsafePartialView SymbolT.typ sym).rho, tau <- TC.reduced tau global, traceLn ("return type is " ++ nicer tau global) || true, Just (symbol@SymbolT.T _) <- instTauSym tau global @@ -442,8 +445,8 @@ proposeContent !global root !offset !tokens !index = propose forWhat = case tsym of Nothing -> "for some type" Just t -> if conid - then "for type " ++ t.name.base - else "for value of type " ++ t.name.base + then "for type " ++ (view SymbolT.name t).base + else "for value of type " ++ (view SymbolT.name t).base disp = 5 + (if conid then 0 else token.length + 1) proposal = Proposal{ proposal = "case " ++ forWhat, @@ -467,37 +470,37 @@ proposeContent !global root !offset !tokens !index = propose conts ∷ Bool → Maybe Symbol → [String] conts parens tsym = case tsym of Just sym -> case cons of - (_:_) -> (map (conText parens) . sortBy (comparing Symbol.cid)) cons - [] -- traceLn(show (Symbol.name sym) ++ " vs. " ++ show (TName pPreludeBase "Bool")) || true - = if Symbol.name sym == TName pPreludeBase "Bool" + (_:_) -> (map (conText parens . SymbolT.D) . sortBy (comparing _.cid)) cons + [] -> if view SymbolT.name sym == TName pPreludeBase "Bool" then ["true", "false"] else ["_"] - where cons = [ con | con@SymD{} <- values (Symbol.env sym)] + where cons = [ con | SymbolT.D con <- values (unsafePartialView SymbolT.env sym)] Nothing -> ["_"] -- null cons = ["_"] -- otherwise = map conText cons conText parens sym = enclosed (snd (symProp (base sym) sym)) where + unsafeToSymD (SymbolT.D x) = x base sym - | sym.vis != Public, - MName{tynm, base} <- sym.name = tynm.base ++ "." ++ base - | otherwise = sym.name.base + | view SymbolT.vis sym != Public, + MName{tynm, base} <- view SymbolT.name sym = tynm.base ++ "." ++ base + | otherwise = (view SymbolT.name sym).base -- put complicated constructor in (), if required enclosed it | parens, - (Symbol.name sym).base != ":", -- not list cons - (Symbol.name sym).base !~ ´^\(´, -- not tuple - any (isNothing . ConField.name) (Symbol.flds sym) = "(" ++ it ++ ")" + (view SymbolT.name sym).base != ":", -- not list cons + (view SymbolT.name sym).base !~ ´^\(´, -- not tuple + any (isNothing . ConField.name) ((unsafeToSymD sym).flds) = "(" ++ it ++ ")" | otherwise = it -- Find a proposal for id.member -- memProposal :: Symbol -> Proposal -> [Proposal] memProposal sym prop - | RhoTau _ tau <- sym.typ.rho, -- look in env of type tau + | RhoTau _ tau <- (unsafePartialView SymbolT.typ sym).rho, -- look in env of type tau (true, result) <- tauProposal tau prop = result - | RhoFun{rho} <- sym.typ.rho, -- look in return type of fn + | RhoFun{rho} <- (unsafePartialView SymbolT.typ sym).rho, -- look in return type of fn RhoTau _ tau <- rho, (true, result) <- tauProposal tau prop = result | otherwise = filteredEnvProposal prop (classMember:standardFilter) (thisTab global) @@ -512,7 +515,7 @@ proposeContent !global root !offset !tokens !index = propose Just s | ss <- s:U.supersOfNativ s global, -- the supertypes of s (including s) -- traceLn("supertypes are " ++ show ss) || true, - envs <- [ Symbol.env sym | s <- ss, + envs <- [ unsafePartialView SymbolT.env sym | s <- ss, q <- U.typesOfNativ s global, sym <- global.findit q ] = (true, concatMap (flip envProposal prop) envs) @@ -529,15 +532,15 @@ proposeContent !global root !offset !tokens !index = propose localProposal :: Proposal -> [Proposal] localProposal model = [ model.{proposal = label global sym, - newText = sym.name.base} | - sym <- DL.uniqueBy (using (QName.base . Symbol.name)) [ sym | + newText = (view SymbolT.name sym).base} | + sym <- DL.uniqueBy (using (QName.base . view SymbolT.name)) [ sym | sym <- values global.locals, offBefore = maybe 0 symoffset before, offAfter = maybe 999999999 symoffset after, symoffset sym > offBefore, symoffset sym < offAfter, - sym.name.base != "_", - sym.name.base.startsWith model.prefix ] + (view SymbolT.name sym).base != "_", + (view SymbolT.name sym).base.startsWith model.prefix ] ] where before = if null befores @@ -546,7 +549,7 @@ proposeContent !global root !offset !tokens !index = propose after = if null afters then Nothing else Just (DL.minimumBy (comparing symoffset) afters) - symoffset = Token.offset . Position.first . Symbol.pos + symoffset = Token.offset . Position.first . view SymbolT.pos (befores, afters) = DL.partitioned (( 0 - then sym.name.base.startsWith model.prefix + then (view SymbolT.name sym).base.startsWith model.prefix else true, - let (proposal, newText) = symProp sym.name.base sym + let (proposal, newText) = symProp (view SymbolT.name sym).base sym ] -- standardFilter standardFilter = [notPrivate, notTuple, notInstance, notOverloaded] - notPrivate sym = Symbol.vis sym != Private - || global.our sym.name - || Symbol.{alias?} sym - notTuple = not . (flip String.startsWith "(") . QName.base . Symbol.name + isSymL (SymbolT.L _) = true + isSymL _ = false + notPrivate sym = view SymbolT.vis sym != Private + || global.our (view SymbolT.name sym) + || isSymL sym + notTuple = not . (flip String.startsWith "(") . QName.base . view SymbolT.name notInstance = (Just "instance" !=) . fmap (flip Nice.category global) . global.follow notOverloaded sym - | SymV{over} <- sym = null over + | SymbolT.V SymV{over} <- sym = null over | otherwise = true classMember sym | Just member <- global.follow sym, - MName{tynm, base} <- Symbol.name member, - Just SymC{} <- global.findit tynm = true + MName{tynm, base} <- view SymbolT.name member, + Just (SymbolT.C _) <- global.findit tynm = true | otherwise = false -- make proposals for symbols in given symtab, considering prefix if any envProposal :: Symtab -> Proposal -> [Proposal] envProposal symtab model = filteredEnvProposal model standardFilter symtab -- nice up a symbol - symProp base (sym@SymL{}) = case global.follow sym of + symProp base (sym@(SymbolT.L _)) = case global.follow sym of Just target -> symProp base target Nothing -> (base, base) - symProp base (sym@SymD{name,flds}) + symProp base (SymbolT.D (sym@SymD{name,flds})) | null flds = (verbose, base) | base == ":" = (verbose, "(_:_)") | m~´^\(,+\)$´ <- base, Just commata <- m.group 0 = (verbose, tuple commata) @@ -642,22 +647,22 @@ proposeContent !global root !offset !tokens !index = propose verbose = base ++ " (" ++ nicer sym.name.tynm global ++ "." ++ base ++ ")" constr = base ++ joined "" (map (const " _") flds) fields = base ++ "{" ++ joined ", " (mapMaybe ConField.name flds) ++ "}" - symProp base SymV{name=MName{base = it@m~´^(...)\$(.+)$´}} + symProp base (SymbolT.V SymV{name=MName{base = it@m~´^(...)\$(.+)$´}}) | Just field <- m.group 2 = case m.group 1 of Just "chg" -> (field ++ " (change/modify field)", "{" ++ field ++ "<-}") Just "upd" -> (field ++ " (update field)", "{" ++ field ++ "=}") Just "has" -> (field ++ " (check if field exists)", "{" ++ field ++ "?}") other -> (it, it) symProp base sym - | SymV{nativ = Just _} <- sym, + | SymbolT.V SymV{name, nativ = Just _} <- sym, m~´^(.+)[αβγδεζηθιßκλμνξοπρςστυφχψω]+$´ <- base, -- overloaded?? Just stem <- m.group 1, - Just overld <- global.findit sym.name.{base=stem}, - sym.name `elem` overld.over = symProp stem overld + Just overld <- global.findit name.{base=stem}, + name `elem` (unsafeToSymV overld).over = symProp stem overld | otherwise = (imported, base) where - imported | global.our sym.name = base - | otherwise = base ++ " (" ++ nice sym.name global ++ ")" + imported | global.our (view SymbolT.name sym) = base + | otherwise = base ++ " (" ++ nice (view SymbolT.name sym) global ++ ")" {-- Create a list of triples with position, namespace and package @@ -675,16 +680,15 @@ imports g = [ (pos, NSName.unNS ns, Pack.raw pack) | symbols :: Symtab -> [Symbol] symbols tab = (sortBy positionAndName • filter wanted • values) tab where - positionAndName a b = case Symbol.pos a <=> Symbol.pos b of - Eq -> comparing (QName.base • Symbol.name) a b + positionAndName a b = case view SymbolT.pos a <=> view SymbolT.pos b of + Eq -> comparing (QName.base . view SymbolT.name) a b ne -> ne wanted :: Symbol -> Bool wanted sym - | sym.{alias?} = false - | Local{} <- sym.name = true - -- sym.vis == Private = false - | sym.name.base ~ ´^(chg|upd|has|let|anon|lc)\$´ = false - | otherwise = true + | SymbolT.L _ <- sym = false + | Local{} <- view SymbolT.name sym = true + | (view SymbolT.name sym).base ~ ´^(chg|upd|has|let|anon|lc)\$´ = false + | otherwise = true exprSymbols = U.foldEx false collectsyms [] where @@ -703,21 +707,21 @@ dcolon = DU.symDcolon Make a label for a symbol -} label ∷ Global → SymbolT a → String -label g SymI{clas,typ} = nicer (instanceHead clas typ.rho) g +label g (SymbolT.I SymI{clas,typ}) = nicer (instanceHead clas typ.rho) g -- ++ " " ++ clas.nicer g ++ " " ++ verbose g typ -label g SymV{name,typ} = name.base ++ dcolon g ++ verbose g typ -label g SymD{name,typ} = name.base ++ dcolon g ++ verbose g typ -label g SymC{name,tau} = name.base ++ dcolon g ++ show tau.kind +label g (SymbolT.V SymV{name,typ}) = name.base ++ dcolon g ++ verbose g typ +label g (SymbolT.D SymD{name,typ}) = name.base ++ dcolon g ++ verbose g typ +label g (SymbolT.C SymC{name,tau}) = name.base ++ dcolon g ++ show tau.kind label g (SymbolT.T SymT{name, nativ = Just n, pur}) | pur = name.base ++ dcolon g ++ "immutable native " ++ n | otherwise = name.base ++ dcolon g ++ "mutable native " ++ n -label g SymA{name,typ} = name.base ++ " = " ++ typ.rho.nicer gspecial +label g (SymbolT.A SymA{name,typ}) = name.base ++ " = " ++ typ.rho.nicer gspecial where gspecial = g.{options <- _.{flags <- Flags.flagSet SPECIAL}} label g sym - | sym.{kind?} = sym.name.base ++ dcolon g ++ show sym.kind - | otherwise = sym.name.base - + | Just kind <- preview SymbolT.kind sym = (view SymbolT.name sym).base ++ dcolon g ++ show kind + | otherwise = (view SymbolT.name sym).base + {-- Increment the pass number in the state -} @@ -790,8 +794,8 @@ symbolDocumentation sym = do changeSTT Global.{gen <- GenSt.{printer=p}} g <- getSTT let syms = case sym of - SymL{alias} | Just target <- g.findit alias = - if sym.name.base == target.name.base + SymbolT.L SymL{alias} | Just target <- g.findit alias = + if (view SymbolT.name sym).base == (view SymbolT.name target).base then [target] else [sym, target] other = [sym] @@ -844,10 +848,11 @@ infixDoc g = joined "
\n" (map htmlsafe lines) where tab = thisTab g - syms = [ (desc sym.op, sym0.name.base) | + syms = [ (desc op, (view SymbolT.name sym0).base) | sym0 ← values tab, sym ← g.follow sym0, -- resolve symlinks - sym.{op?}, sym.op != defaultInfix ] + op <- preview SymbolT.op sym, + op != defaultInfix ] groups = map toTuple • groupBy (using fst) • sortBy (descending fst) $ syms where diff --git a/frege/tools/Doc.fr b/frege/tools/Doc.fr index 914c4d78..ea890c71 100644 --- a/frege/tools/Doc.fr +++ b/frege/tools/Doc.fr @@ -63,6 +63,8 @@ import Data.TreeMap as TM(TreeMap, keys, values, each, insert) import Data.List as DL(sortBy, groupBy, intersperse) import Data.Bits +import frege.compiler.common.Lens (preview, unsafePartialView, view) + import Compiler.enums.Flags as Compilerflags(VERBOSE) import Compiler.enums.Visibility(Public) @@ -316,15 +318,17 @@ mkLinks ns pack = do link :: Symbol -> StG () link (sym::Symbol) = do g <- getST - case g.thisTab.lookupS sym.name.key of + let isSymI (SymbolT.I _) = true + isSymI _ = false + case g.thisTab.lookupS (view SymbolT.name sym).key of Just _ -> return () - Nothing -> let rsym = fromMaybe sym (g.findit sym.name) in + Nothing -> let rsym = fromMaybe sym (g.findit (view SymbolT.name sym)) in I.linkHere (ns.unNS) pack - protoItem.{name=Simple sym.pos.first.{value=sym.name.base}, - members = if rsym.{env?} && not rsym.{clas?} + protoItem.{name=Simple (view SymbolT.pos sym).first.{value=(view SymbolT.name sym).base}, + members = if isJust (preview SymbolT.env rsym) && not (isSymI rsym) then Just [] else Nothing, - alias=sym.name.base} + alias=(view SymbolT.name sym).base} sym continueImport = do @@ -374,7 +378,7 @@ continueNamespaces fp = do tableOC = [h3 (text "Table of Content"), toc] toc = ul (Just "data") (tocpars [ (asyms++csyms++dsyms - ++(sortBy (comparing Symbol.pos) (funs++links)), "data", "Definitions"), + ++(sortBy (comparing $ view SymbolT.pos) (funs++links)), "data", "Definitions"), -- (asyms, "data", "Type Aliases"), -- (csyms, "data", "Type Classes"), -- (dsyms, "data", "Data Types"), @@ -420,35 +424,38 @@ continueNamespaces fp = do DL (Just "func") (map docTypes ordfuns)] definitions = [h2 (XLbl "data" (text "Definitions")), DL (Just "data") (map (docSym g) sourcesyms)] - sourcesyms = sortBy (comparing Symbol.pos) (asyms ++ csyms ++ dsyms ++ funs ++ links) - asyms = sortBy (comparing Symbol.name) [sym | sym@SymA {pos} <- values g.thisTab] - csyms = sortBy (comparing Symbol.name) [sym | sym@SymC {pos} <- values g.thisTab] - isyms = sortBy (comparing Symbol.name) [sym | sym@SymI {pos} <- values g.thisTab] - dsyms = sortBy (comparing Symbol.name) [sym | sym@SymT {pos} <- values g.thisTab] - funs = sortBy (comparing Symbol.name) [sym | sym@SymV {pos} <- values g.thisTab] - links = sortBy (comparing Symbol.name) [sym | sym@SymL {alias} <- values g.thisTab, + sourcesyms = sortBy (comparing $ view SymbolT.pos) (asyms ++ csyms ++ dsyms ++ funs ++ links) + asyms = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.A _) <- values g.thisTab] + csyms = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.C _) <- values g.thisTab] + isyms = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.I _) <- values g.thisTab] + dsyms = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.T _) <- values g.thisTab] + funs = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.V _) <- values g.thisTab] + links = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.L SymL{alias}) <- values g.thisTab, g.our alias, other <- g.findit alias, - not other.{flds?}, -- no constructor aliases - noclassmember g other.name] + not (isSymD other), -- no constructor aliases + noclassmember g $ view SymbolT.name other] where + isSymD (SymbolT.D _) = true + isSymD _ = false noclassmember g (MName tname _) = case g.findit tname of - Just SymC{} -> false - other -> true + Just (SymbolT.C _) -> false + other -> true noclassmember f _ = true allfuns = funs ++ [ s | syms <- [csyms, isyms, dsyms], sym :: Symbol <- syms, - sym.{env?}, - s <- values sym.env, Symbol.{typ?} s ] - ordfuns = groupBy (using Symbol.typ) (sortBy (comparing Symbol.typ) allfuns) - expfuns = sortBy (comparing Symbol.name) [sym | sym@SymL {pos,vis,alias} <- values g.thisTab, + env <- preview SymbolT.env sym, + s <- values env, + isJust (preview SymbolT.typ s) ] + ordfuns = groupBy (using $ unsafePartialView SymbolT.typ) (sortBy (comparing $ unsafePartialView SymbolT.typ) allfuns) + expfuns = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.L SymL{pos,vis,alias}) <- values g.thisTab, vis == Public, not (g.our alias) ] docTypes :: [Symbol] -> (Text, [Paragraph]) docTypes [] = undefined docTypes ss = (code typ, [par $ content ss]) where - typ = dRho g (head ss).typ.rho (repeat false) - content = fold (:-) (text "") • intersperse (text ", ") • map (flip fref g • Symbol.name) + typ = dRho g (unsafePartialView SymbolT.typ (head ss)).rho (repeat false) + content = fold (:-) (text "") . intersperse (text ", ") . map (flip fref g . view SymbolT.name) -- h3 (text "Imports"), ul Nothing (map docImp (Tree.keyvalues ?S.packs Eq))] -- we are producing strict HTML401 diff --git a/frege/tools/Quick.fr b/frege/tools/Quick.fr index c2908249..dd898047 100644 --- a/frege/tools/Quick.fr +++ b/frege/tools/Quick.fr @@ -211,7 +211,7 @@ getProps pack = do when (g.errors > 0) printAndClearErrors return [] Just env -> return [ sym.name.base | - sym@SymV{} <- values env, + SymbolT.V sym <- values env, ForAll _ RhoTau{context=[], tau} <- Just sym.typ, TApp TCon{name=gen} TCon{name=prop} <- Just tau, gen == genName, diff --git a/frege/tools/Splitter.fr b/frege/tools/Splitter.fr index df9227e2..2bc24ee2 100644 --- a/frege/tools/Splitter.fr +++ b/frege/tools/Splitter.fr @@ -9,6 +9,8 @@ import Data.TreeMap as L(values, keys, each, TreeMap) import Data.Bits import Data.Graph (stronglyConnectedComponents tsort) +import frege.compiler.common.Lens (set, view) + import Compiler.enums.Flags as Compilerflags(IDETOKENS, NOUNLET) import Compiler.enums.TokenID @@ -118,10 +120,10 @@ ideoff = do ours :: Global -> [Symbol] ours g = (filter (g.ourSym) . filter noAliases) (values g.thisTab) where - noAliases SymL{name=n@VName{},alias=a@VName{}} = g.our a && g.our n - noAliases SymL{} = false - noAliases _ = true -ascending g = sortBy (Prelude.comparing Symbol.pos) (ours g) + noAliases (SymbolT.L SymL{name=n@VName{},alias=a@VName{}}) = g.our a && g.our n + noAliases (SymbolT.L _) = false + noAliases _ = true +ascending g = sortBy (Prelude.comparing (view SymbolT.pos)) (ours g) split :: [String] -> StIO (String, Int) split args = do @@ -135,7 +137,7 @@ split args = do -- doio $ mapM_ (printRange g) (ascending g) let deps g = map (symDep g) (ascending g) udeps = map (\(a,as) -> (a, filter (a!=) as)) -- eliminate self recursion - (zip (map Symbol.name (ascending g)) (map keys (deps g))) + (zip (map (view SymbolT.name) (ascending g)) (map keys (deps g))) deptree = L.fromList udeps tdeps = tsort udeps asc = ascending g @@ -259,7 +261,7 @@ printMods g modul mbHelper mItems hItems syms = do dat <- openReader g.options.source >>= getContentsOf -- print the initial portion of the original file let first = head syms - startoff = first.pos.first.offset + startoff = (view SymbolT.pos first).first.offset initialportion = substr dat 0 startoff orig <- newMod g (g.unpack g.thisPack) orig.println initialportion @@ -292,36 +294,25 @@ printMods g modul mbHelper mItems hItems syms = do where out :: String -> MutableIO PrintWriter -> MutableIO PrintWriter -> MutableIO PrintWriter -> Symbol -> IO () out dat ow mw hw sym = do - stderr.println (nicer sym.name g - ++ ", range=" ++ sym.pos.first.value ++ " .. " - ++ show sym.pos.last) - let src = substr dat sym.pos.first.offset end - end = if sym.pos.end < sym.pos.first.offset || sym.pos.end > dat.length + let symName = view SymbolT.name sym + symPos = view SymbolT.pos sym + stderr.println (nicer symName g + ++ ", range=" ++ symPos.first.value ++ " .. " + ++ show symPos.last) + let src = substr dat symPos.first.offset end + end = if symPos.end < symPos.first.offset || symPos.end > dat.length then dat.length - else sym.pos.end - -- braces e = if e < dat.length && - -- (dat.charAt e == '}' - -- || Char.isWhitespace (dat.charAt e)) - -- then braces (e+1) - -- else if e+1 < dat.length - -- && dat.charAt e == '-' - -- && dat.charAt (e+1) == '-' - -- then endofline (e+2) - -- else e - -- endofline e - -- | e >= dat.length = e - -- | dat.charAt e == '\r' || dat.charAt e == '\n' = e - -- | otherwise = endofline (e+1) - - writer = if sym.name `elem` mItems - then if sym.name `elem` hItems + else symPos.end + + writer = if symName `elem` mItems + then if symName `elem` hItems then hw else mw else ow writer.println src writer.println writer.println - + --- make filename from package name @x.y.z.Packet@ => @dest/x/y/z/Packet.suffix@ targetPath :: Global -> String -> String -> String @@ -437,10 +428,11 @@ printDep g tree qns = do println (" :: " ++ show (map (flip nicer g) xs)) printRange g symbol = do - println (show symbol.pos.first.offset - ++ "-" ++ show (symbol.pos.end) - ++ Symbol.nicer symbol g - ++ " " ++ symbol.pos.first.value ++ " .. " ++ symbol.pos.last.value) + let pos = view SymbolT.pos symbol + println (show pos.first.offset + ++ "-" ++ show (pos.end) + ++ symbol.nicer g + ++ " " ++ pos.first.value ++ " .. " ++ pos.last.value) {-- The full range goes from the lower range to the upper range, inclusive. @@ -471,7 +463,7 @@ fullRange symbol next = do -- doio $ stderr.println ("Last token: " ++ show last) return last upperRange symbol (Just next) - | symbol.pos.end >= next.pos.start = do + | (view SymbolT.pos symbol).end >= (view SymbolT.pos next).start = do g <- getSTT liftIO do stderr.println "I am sorry, but I can't continue." @@ -480,7 +472,7 @@ fullRange symbol next = do ++ nicer next g ++ " do overlap, ") stderr.println "probably because of annotations detached from their definitions." System.exit 4 - return symbol.pos.first + return (view SymbolT.pos symbol).first | otherwise = do g <- getSTT lower <- lowerRange next @@ -493,10 +485,6 @@ fullRange symbol next = do skipComments :: Int -> JArray Token -> Int skipComments 0 arr = 0 skipComments n arr - -- | traceLn ("skipComments: " - -- ++ maybe "" (_.base . Symbol.name) next - -- ++ ", n=" ++ show n - -- ++ " found " ++ show [prev,this]) = undefined | -- prev.tokid == DOCUMENTATION || prev.tokid == COMMENT, prev.line < this.line, prev.col > this.col = n -- most likely not our token @@ -511,11 +499,11 @@ fullRange symbol next = do lowerRange symbol = do g <- getSTT let toks = g.sub.toks - this = symbol.pos.first `indexIn` toks + this = (view SymbolT.pos symbol).first `indexIn` toks case this of Just index -> return (elemAt toks n) where n = skipComments index toks Nothing -> error ("Couldn't find start token " - ++ show symbol.pos.first ++ " of " ++ symbol.nicer g) + ++ show (view SymbolT.pos symbol).first ++ " of " ++ symbol.nicer g) dclintro :: [TokenID] @@ -542,32 +530,32 @@ makeRanges ascending = do let nextTokens = map Just (tail ascending) ++ [Nothing] ranges = zipWith fullRange ascending nextTokens ranges <- sequence ranges - mapM_ (liftStG . changeSym) (zipWith Symbol.{pos=} ascending ranges) + mapM_ (liftStG . changeSym) (zipWith (flip $ set SymbolT.pos) ascending ranges) -- symDep g _ sym | traceLn ("doing symDep for " ++ nicer sym g) = undefined -symDep g SymA{typ} = sigmaDep g typ -symDep g SymT{env} = fold L.union empty [ symDep g sym | +symDep g (SymbolT.A SymA{typ}) = sigmaDep g typ +symDep g (SymbolT.T SymT{env}) = fold L.union empty [ symDep g sym | sym <- values env, not (instLink sym)] where - instLink SymL{alias} - | Just SymV{name} <- g.findit alias, - MName{tynm} <- name, - Just SymI{} <- g.findit tynm = true + instLink (SymbolT.L SymL{alias}) + | Just (SymbolT.V SymV{name}) <- g.findit alias, + MName{tynm} <- name, + Just (SymbolT.I _) <- g.findit tynm = true instLink other = false -symDep g SymD{typ} = sigmaDep g typ -symDep g (symv@SymV{typ}) = sigmaDep g typ L.`union` maybe empty (exprDep g) (symv.gExpr g) -symDep g SymL{name, alias} +symDep g (SymbolT.D SymD{typ}) = sigmaDep g typ +symDep g (SymbolT.V (symv@SymV{typ})) = sigmaDep g typ L.`union` maybe empty (exprDep g) (symv.gExpr g) +symDep g (SymbolT.L SymL{name, alias}) | g.our name, not (g.our alias) = nameDep g empty name -- imported item | otherwise = nameDep g empty alias | false = case g.findit alias of Just sym -> nameDep g (symDep g sym) alias Nothing -> empty -symDep g SymI{clas, typ, env} = fold L.union tree (map (symDep g) (values env)) +symDep g (SymbolT.I SymI{clas, typ, env}) = fold L.union tree (map (symDep g) (values env)) where tree = nameDep g sigt clas sigt = sigmaDep g typ -symDep g SymC{supers, env} = fold L.union tree (map (symDep g) (values env)) +symDep g (SymbolT.C SymC{supers, env}) = fold L.union tree (map (symDep g) (values env)) where tree = fold (nameDep g) empty supers symDep g sym = error ("don't know dependencies of " ++ nicer sym g) diff --git a/frege/tools/doc/Utilities.fr b/frege/tools/doc/Utilities.fr index 25e56d94..5f8ff58e 100644 --- a/frege/tools/doc/Utilities.fr +++ b/frege/tools/doc/Utilities.fr @@ -47,6 +47,7 @@ import Data.TreeMap as TM(TreeMap, keys, values, each, insert) import Data.List as DL(sortBy, groupBy, intersperse) import Java.Net(URI) +import frege.compiler.common.Lens (preview, view) import Compiler.enums.Flags as Compilerflags(SPECIAL, isOn, USEUNICODE) import Compiler.enums.Visibility(Public) @@ -195,7 +196,7 @@ join = joined joint s f xs = seq (intersperse (text s) (map f xs)) joins n f xs = seq (intersperse (spaces n :- text " ") (map f xs)) -docSym g (syma@SymA {name, vars, typ=ForAll _ rho, doc}) = (code title, docit g doc) where +docSym g (SymbolT.A (syma@SymA{name, vars, typ=ForAll _ rho, doc})) = (code title, docit g doc) where title = (bold • text $ "type ") :- Label name (text name.base) :- text " " @@ -203,13 +204,13 @@ docSym g (syma@SymA {name, vars, typ=ForAll _ rho, doc}) = (code title, docit g :- text " = " :- dRho g.{options <- Options.{flags <- Compilerflags.flagSet SPECIAL}} rho [] -docSym g (SymC {name,tau,doc,supers,insts,env}) = (code title, content) where +docSym g (SymbolT.C SymC{name,tau,doc,supers,insts,env}) = (code title, content) where title = (bold • text $ "class ") :- dCtx g (map (\c -> Ctx {pos=Position.null, cname=c, tau}) supers) :- text " " :- Label name (text name.base) :- text " " :- dTau g tau - members = sortBy (comparing Symbol.name) (values env) + members = sortBy (comparing $ view SymbolT.name) (values env) ki (tname, iname) = Ref iname (text (nice tname g)) content = [ p | d <- [docit g doc, if null insts then [] @@ -219,14 +220,14 @@ docSym g (SymC {name,tau,doc,supers,insts,env}) = (code title, content) where DL (Just "func") (map (docSym g) members)]], p <- d ] -docSym g (SymI {pos, name, doc, clas, typ=ForAll _ rho, env}) = (code title, content) where +docSym g (SymbolT.I SymI{pos, name, doc, clas, typ=ForAll _ rho, env}) = (code title, content) where title = (bold • text $ "instance ") :- dCtx g rho.context :- Label name (text " ") :- dTau g (TApp TCon{pos, name=clas} (TH.tauRho rho).tau) -- tref clas g :- text " " -- dRho g rho [] - members = sortBy (comparing Symbol.name) (values env) + members = sortBy (comparing $ view SymbolT.name) (values env) content = [ p | d <- [docit g doc, if null members then [] else [h3 (text "Member Functions"), @@ -244,9 +245,9 @@ docSym g (SymbolT.T SymT{name, doc, typ=ForAll _ rho, env, nativ, pur}) = (code nativetype (Just s) = text " = " :- mode pur :- (bold • text $ "native ") :- text s mode true = (bold . text) $ "immutable " mode false = (bold . text) $ "mutable " - members = sortBy (comparing Symbol.name) [ v | v@SymV {pos, name} <- values env, - QName.base name !~ ´\$´] - constrs = sortBy (comparing Symbol.name) [ v | v@SymD {pos} <- values env] + members = sortBy (comparing $ view SymbolT.name) [ v | v@(SymbolT.V SymV{name}) <- values env, + QName.base name !~ ´\$´] + constrs = sortBy (comparing $ view SymbolT.name) [ v | v@(SymbolT.D _) <- values env] content = [ p | d <- [docit g doc, if null constrs then [] else [h3 (text "Constructors"), @@ -256,7 +257,7 @@ docSym g (SymbolT.T SymT{name, doc, typ=ForAll _ rho, env, nativ, pur}) = (code DL (Just "func") (map (docSym g) members)]], p <- d ] -docSym g (SymD {name, doc, typ, vis, op, flds}) = (code title, docit g doc) where +docSym g (SymbolT.D SymD{name, doc, typ, vis, op, flds}) = (code title, docit g doc) where title = lbl -- label name :- text " " :- typeorfields @@ -269,8 +270,8 @@ docSym g (SymD {name, doc, typ, vis, op, flds}) = (code title, docit g doc) wher fsmap (Field {name=mbs, typ=ForAll _ rho}) = text (fromMaybe "" mbs) :- text (symDcolon g) :- dRho g rho [] drho (ForAll _ r) = dRho2 g r [] -docSym g (sym@SymV {name, typ, doc, nativ, pur, strsig, op, over=(_:_)}) - | sigs <- overSig g sym = (code (title sigs), docit g doc) where +docSym g (SymbolT.V (sym@SymV{name, typ, doc, nativ, pur, strsig, op, over=(_:_)})) + | sigs <- overSig g (SymbolT.V sym) = (code (title sigs), docit g doc) where tpur = if pur then (bold • text $ "pure ") else text "" tnat (Just s) = break :- tpur :- (bold • text $ "native ") :- text s tnat Nothing = text "" @@ -285,7 +286,7 @@ docSym g (sym@SymV {name, typ, doc, nativ, pur, strsig, op, over=(_:_)}) -- tsig Nothing = badref "no type???" title sigs = label name :- text (symDcolon g) :- types sigs :- tnat nativ :- docop op -- :- tthrows throwing -docSym g (sym@SymV {name, typ, doc, nativ, pur, strsig, op, throwing}) = (code title, docit g doc) where +docSym g (SymbolT.V (sym@SymV{name, typ, doc, nativ, pur, strsig, op, throwing})) = (code title, docit g doc) where tpur = if pur then (bold • text $ "pure ") else text "" tnat (Just s) = break :- tpur :- (bold • text $ "native ") :- text s tnat Nothing = text "" @@ -296,14 +297,14 @@ docSym g (sym@SymV {name, typ, doc, nativ, pur, strsig, op, throwing}) = (code t strBools (S list) = map Strictness.isStrict list -- tsig Nothing = badref "no type???" ovl = case nativ of - Just _ | (o:_) <- overloadOf g sym - = spaces 2 :- (bold • text $ "overloads ") :- Ref o.name (text o.name.base) + Just _ | (o:_) <- overloadOf g (SymbolT.V sym) + = spaces 2 :- (bold • text $ "overloads ") :- Ref (view SymbolT.name o) (text (view SymbolT.name o).base) _ = text "" title = label name :- text (symDcolon g) :- tsig typ :- tnat nativ :- tthrows throwing :- ovl :- docop op -docSym g (SymL {name,alias}) = case g.findit alias of +docSym g (SymbolT.L SymL{name,alias}) = case g.findit alias of Nothing -> (badref (name.nice g ++ "links to " ++ alias.nice g ++ " but not found"), []) - Just (vsym@SymV{}) | g.our alias = docSym g vsym.{name, + Just (SymbolT.V vsym) | g.our alias = docSym g $ SymbolT.V vsym.{name, doc = Just ("Alias for '" ++ nicer alias g ++ "'")} Just sym -> docSym g sym @@ -318,18 +319,22 @@ docop tok --- Give the function that is overloaded with this one. overloadOf :: Global -> Symbol -> [Symbol] -overloadOf g sym = [ o | symtab <- g.packages.lookup sym.name.getpack, - symbol <- values symtab, - o@SymV{over=(_:_)} <- symvs symbol, - sym.name `elem` o.over] +overloadOf g sym = [ SymbolT.V o + | symtab <- g.packages.lookup (view SymbolT.name sym).getpack + , symbol <- values symtab + , o@SymV{over=(_:_)} <- symvs symbol + , view SymbolT.name sym `elem` o.over + ] where - symvs sym | sym.{env?} = [ sv | sv@SymV{} <- values sym.env ] - | SymV{} <- sym = [sym] - | otherwise = [] + symvs sym + | Just env <- preview SymbolT.env sym = [ sv | SymbolT.V sv <- values env ] + | SymbolT.V sv <- sym = [sv] + | otherwise = [] --- Give a list of sigmas and throws clauses of the overloads for this one -overSig g sym = [(Symbol.typ o, Symbol.throwing o) | q <- Symbol.over sym, o <- Global.findit g q] - +overSig g sym = [(o.typ, o.throwing) | q <- (unsafeToSymV sym).over, o <- unsafeToSymV <$> Global.findit g q] + where + unsafeToSymV (SymbolT.V x) = x --- create a label for a variable or a constructor -- label (MName (TName _ b1) b2) = Label (mangled b1 ++ "." ++ mangled b2) (text b2) From e9fd748aedf7bea09bc65326dff744ab553b4eed Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 11:32:58 +0900 Subject: [PATCH 06/95] Add instance Nice for SymT, SymL, etc. --- frege/compiler/Classes.fr | 58 ++++++++++++------------- frege/compiler/GenMeta.fr | 4 +- frege/compiler/Typecheck.fr | 14 +++--- frege/compiler/Utilities.fr | 4 +- frege/compiler/classes/Nice.fr | 23 ++++++++++ frege/compiler/gen/java/DataCode.fr | 18 ++++---- frege/compiler/gen/java/InstanceCode.fr | 8 ++-- frege/compiler/gen/java/Match.fr | 2 +- frege/compiler/gen/java/VarCode.fr | 16 +++---- frege/compiler/passes/Easy.fr | 8 ++-- frege/compiler/passes/LetUnroll.fr | 6 +-- frege/compiler/passes/Strict.fr | 6 +-- frege/compiler/passes/Transdef.fr | 16 +++---- 13 files changed, 103 insertions(+), 80 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index 319064b0..2e37c36f 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -123,7 +123,7 @@ passC = do let allsups = superclasses (SymbolT.C symc) g newsups = [ s | s <- ordered, s `elem` allsups ] changeSym $ SymbolT.C symc.{supers=newsups} - E.logmsg TRACE6 symc.pos (text (nice (SymbolT.C symc) g ++ " superclasses " + E.logmsg TRACE6 symc.pos (text (nice symc g ++ " superclasses " ++ show (map (flip nice g) newsups))) -- foreach classdeps trace1 foreach mutual err1 @@ -168,7 +168,7 @@ passC = do g <- getST E.error (symc.pos.merge symc.tau.getpos) ( text "kind error: it looks like" - <+> text (nicer (SymbolT.C symc) g) + <+> text (nicer symc g) <+> text "should have kind" <+> text (show ka) <+> nest 4 ( @@ -193,7 +193,7 @@ passC = do text ("kind error: kind of type variable `" ++ var ++ "` :: " ++ show k) nest 4 ( - text ("in type signature of " ++ (SymbolT.V sym).nicer g) + text ("in type signature of " ++ sym.nicer g) text ("does not match kind of class variable `" ++ var ++ "` :: " ++ show kind) text "as inferred from other class methods or superclasses.")) @@ -249,14 +249,14 @@ passC = do Just (ssym@(SymbolT.C _)) <- g.findit osym.name.tynm = do sig <- mkanno (SymbolT.C symc) (SymbolT.L msym) (SymbolT.V osym) ssym T.subsCheck (SymbolT.V ali) ali.typ sig - | otherwise = E.error pos (msgdoc (nicer (SymbolT.L msym) g + | otherwise = E.error pos (msgdoc (nicer msym g ++ " may only point to a value whose type is known through annotation or import.")) _ -> E.fatal pos (text (msym.name.nice g ++ " occurs in more than one super class of " ++ symc.name.nice g)) methodcheck symc other = do g <- getST - E.error (view SymbolT.pos other) (text (other.nice g ++ " not allowed in " ++ (SymbolT.C symc).nice g)) + E.error (view SymbolT.pos other) (text (other.nice g ++ " not allowed in " ++ symc.nice g)) {- mkanno class method supermethod superclass * replace forall c . Super c => c -> t * with forall t.This t => t -> n @@ -309,16 +309,16 @@ passC = do Just s -> E.fatal (view SymbolT.pos s) (text ("checklink: " ++ s.nice g ++ " should be a link")) Nothing -> E.fatal (view SymbolT.pos v) (text ("checklink: " ++ glob.nice g ++ "findit is " ++ v.nice g ++ " but find is Nothing")) - Just v -> E.error symm.pos (msgdoc ("definition of " ++ (SymbolT.V symm).nice g + Just v -> E.error symm.pos (msgdoc ("definition of " ++ symm.nice g ++ " clashes with " ++ v.nice g ++ ", please use another name")) Nothing -> -- should this be possible? - E.fatal symm.pos (text ("checklink: " ++ (SymbolT.V symm).nice g ++ " not yet known globally")) + E.fatal symm.pos (text ("checklink: " ++ symm.nice g ++ " not yet known globally")) -- We could, of course, add it now, but this would be too defensive, -- as we should be justified in assuming that 'enter' did it's job. checklink sym = do g <- getST - E.fatal sym.pos (text ("checklink: " ++ (SymbolT.V sym).nice g)) + E.fatal sym.pos (text ("checklink: " ++ sym.nice g)) checkanno (SymbolT.C (symc@SymC {tau=TVar {var}})) (SymbolT.V (msym@SymV {typ=ForAll bound rho})) = do let check1 = var `elem` map _.var bound check2 = var `notElem` [ var | Ctx {tau=TVar {var}} <- rho.context ] @@ -407,7 +407,7 @@ instForClass alien c iname = do isym <- unsafeToSymI <$> U.findI iname case instTSym isym.typ g of Just (SymbolT.T (tsym@SymT{pos})) -> do - E.logmsg TRACE6 isym.pos (text ((SymbolT.I isym).nice g ++ " " ++ (SymbolT.T tsym).nice g)) + E.logmsg TRACE6 isym.pos (text (isym.nice g ++ " " ++ tsym.nice g)) when (not alien || g.our isym.name) do foreach (reverse csym.supers) (checkSuperInstance isym.name tsym.name csym.name) @@ -503,18 +503,18 @@ instForThisClass iname tname cname = do iold <- unsafeToSymI <$> U.findI oldinst when (iold.clas == isym.clas) do U.symWarning E.warn (SymbolT.I isym) (msgdoc (tsym.nice g ++ " is already an instance of " - ++ (SymbolT.C csym).nice g ++ " (" ++ oldinst.nice g + ++ csym.nice g ++ " (" ++ oldinst.nice g ++ " introduced on line " ++ show iold.pos ++ ")")) stio () | otherwise = do E.logmsg TRACE6 isym.pos (text ("refresh " ++ tname.nice g - ++ " instance of " ++ (SymbolT.C csym).nice g)) + ++ " instance of " ++ csym.nice g)) foreach (map (view SymbolT.name) (values csym.env)) (funForCIT cname iname tname) stio () Nothing -> do E.logmsg TRACE6 isym.pos (text ("make " ++ tname.nice g - ++ " an instance of " ++ (SymbolT.C csym).nice g)) + ++ " an instance of " ++ csym.nice g)) foreach (map (view SymbolT.name) (values csym.env)) (funForCIT cname iname tname) let unsafeToSymC c = case c of { SymbolT.C x -> x; } csym <- unsafeToSymC <$> U.findC cname @@ -556,7 +556,7 @@ funForCIT cname iname tname (mname@MName _ base) = do -- implemented vsym = isJust (Symbol.expr vsym) || isJust (Symbol.nativ vsym) inherit xname = do mem <- unsafeToSymV <$> U.findV xname - E.logmsg TRACE6 isym.pos (text ("inheriting " ++ (SymbolT.V mem).nice g)) + E.logmsg TRACE6 isym.pos (text ("inheriting " ++ mem.nice g)) if implemented $ SymbolT.V mem then do -- use default implementation mex <- U.maybeST mem.expr id @@ -590,18 +590,18 @@ funForCIT cname iname tname (mname@MName _ base) = do U.symWarning E.hint (SymbolT.V ivsym) (msgdoc ("There exists another implementation of `" ++ mname.base ++ "` for unrelated " ++ ysym.nicer g ++ ", this will make it impossible to access " - ++ (SymbolT.V ivsym).nicer g + ++ ivsym.nicer g ++ " directly.")) - | otherwise = E.error tvsym.pos (msgdoc ((SymbolT.L tvsym).nice g - ++ " should be alias of " ++ (SymbolT.V ivsym).nice g)) - Just tvsym -> E.error (view SymbolT.pos tvsym) (msgdoc ("definition of " ++ (SymbolT.V ivsym).nice g + | otherwise = E.error tvsym.pos (msgdoc (tvsym.nice g + ++ " should be alias of " ++ ivsym.nice g)) + Just tvsym -> E.error (view SymbolT.pos tvsym) (msgdoc ("definition of " ++ ivsym.nice g ++ " not allowed because " ++ tvsym.nice g ++ " already exists.")) Nothing -> do - E.logmsg TRACE6 ivsym.pos (text (mname.nice g ++ " not yet implemented in " ++ (SymbolT.T tsym).nice g)) + E.logmsg TRACE6 ivsym.pos (text (mname.nice g ++ " not yet implemented in " ++ tsym.nice g)) linkq (MName tname base) $ SymbolT.V ivsym changeSym $ SymbolT.V ivsym.{op=msym.op} -- copy op - | otherwise = E.error isym.pos (msgdoc ("implementation missing for " ++ (SymbolT.V ivsym).nice g)) + | otherwise = E.error isym.pos (msgdoc ("implementation missing for " ++ ivsym.nice g)) Just (Symbol.L SymL{pos=ipos, name=member, alias}) -- imported instance with links to type methods? | not (g.our iname), alias.{tynm?}, alias.tynm == tname = stio () | otherwise = case g.findit alias of @@ -622,7 +622,7 @@ funForCIT cname iname tname (mname@MName _ base) = do ++ " not allowed because " ++ err.nicer g ++ " already exists.")) Nothing -> do - E.logmsg TRACE6 ipos (text (mname.nice g ++ " not yet implemented in " ++ (SymbolT.T tsym).nice g)) + E.logmsg TRACE6 ipos (text (mname.nice g ++ " not yet implemented in " ++ tsym.nice g)) linkq (MName tname base) osym changeSym $ set SymbolT.op msym.op osym Just osym -> E.error ipos (text (nicer osym g ++ " is not implemented.")) @@ -639,12 +639,12 @@ funForCIT cname iname tname (mname@MName _ base) = do linkq (MName iname base) $ SymbolT.V tvsym changeSym $ SymbolT.V tvsym.{op=msym.op} | implemented (SymbolT.V tvsym) = do - E.logmsg TRACE6 tvsym.pos (text (mname.nice g ++ " not yet implemented in " ++ (SymbolT.I isym).nice g)) + E.logmsg TRACE6 tvsym.pos (text (mname.nice g ++ " not yet implemented in " ++ isym.nice g)) let ivsym = tvsym.{name=MName iname base, sid = 0, op = msym.op} enter $ SymbolT.V ivsym changeSym $ SymbolT.T tsym.{ env <- delete mname.key } linkq (MName tname base) $ SymbolT.V ivsym - | otherwise = E.error tvsym.pos (msgdoc ("implementation missing for " ++ (SymbolT.V tvsym).nice g)) + | otherwise = E.error tvsym.pos (msgdoc ("implementation missing for " ++ tvsym.nice g)) Just (SymbolT.L (ali@SymL{alias})) | alias == mname || alias == MName isym.clas base = do -- link to class fun has been introduced earlier in 'enter' @@ -659,7 +659,7 @@ funForCIT cname iname tname (mname@MName _ base) = do Just impl <- g.follow (SymbolT.L ali) = do if implemented impl then do - E.logmsg TRACE6 (view SymbolT.pos impl) (text (mname.nice g ++ " not yet implemented in " ++ (SymbolT.I isym).nice g)) + E.logmsg TRACE6 (view SymbolT.pos impl) (text (mname.nice g ++ " not yet implemented in " ++ isym.nice g)) E.logmsg TRACE6 isym.pos (text ("copy implementation from " ++ impl.nice g)) let ivsym = set SymbolT.name (MName iname base) $ set SymbolT.sid 0 $ set SymbolT.op msym.op $ impl enter ivsym @@ -673,7 +673,7 @@ funForCIT cname iname tname (mname@MName _ base) = do Just (SymbolT.V (vsym@SymV{nativ = Just _})) <- g.findit alias = do -- allow recycling of native functions U.symWarning E.hint (SymbolT.I isym) (msgdoc ("implementation for " ++ mname.nice g - ++ " taken from unrelated " ++ (SymbolT.I ysym).nice g)) + ++ " taken from unrelated " ++ ysym.nice g)) enter $ SymbolT.V vsym.{name=MName isym.name base, sid = 0, op = msym.op} | MName yname _ <- alias, Just (SymbolT.I ysym) <- g.findit yname, @@ -691,7 +691,7 @@ funForCIT cname iname tname (mname@MName _ base) = do unless sibling do E.error isym.pos (msgdoc (mname.nice g ++ " already implemented via unrelated " - ++ (SymbolT.I ysym).nice g)) + ++ ysym.nice g)) | MName ocname _ <- alias, Just (ocsym@(SymbolT.C SymC{name})) <- g.findit ocname, name `notElem` csym.supers = do @@ -706,7 +706,7 @@ funForCIT cname iname tname (mname@MName _ base) = do "linkq " ++ nice (MName iname base) g ++ " -> " ++ nice target g)) linkq (MName iname base) target funForCIT cname iname tname mname -- try again - Nothing -> E.fatal ali.pos (msgdoc ("Link to nowhere: " ++ nicer (SymbolT.L ali) g)) + Nothing -> E.fatal ali.pos (msgdoc ("Link to nowhere: " ++ nicer ali g)) Just osym -> E.fatal (view SymbolT.pos osym) (text ("funForCIT: expected type member, found " ++ osym.nice g)) funForCIT cname iname tname mname = error "funForCIT: not a member" @@ -744,7 +744,7 @@ tcInstMethod (sc':scs) isym msym Just xsym | Just typ <- preview SymbolT.typ xsym -> typ other -> error ("tcInstMethod: link to nothing: " ++ nice msym g) E.logmsg TRACE6 (view SymbolT.pos msym) (text (msym.nice g - ++ " class: " ++ (SymbolT.C sc).nice g + ++ " class: " ++ sc.nice g ++ " class method type: " ++ s.nicer g ++ " own type: " ++ mtnice)) -- forall i. S i => I i ==> S 42 => I 42 @@ -788,12 +788,12 @@ tcInstMethod (sc':scs) isym msym _ -> pure () other -> E.fatal (view SymbolT.pos isym) (msgdoc ("RhoTau expected, got " ++ rhotau.nicer g)) Just (SymbolT.V (symv@SymV {typ=sig})) | isPSigma sig -> do - E.fatal symv.pos (text ((SymbolT.V symv).nice g ++ " of " ++ (SymbolT.C sc).nice g ++ " is not annotated")) + E.fatal symv.pos (text (symv.nice g ++ " of " ++ sc.nice g ++ " is not annotated")) -- Some class has a default method that links somewhere else -- The method was introduced in a super class Just (SymbolT.L _) -> tcInstMethod scs isym msym Just other -> do - E.fatal (view SymbolT.pos other) (text (other.nice g ++ " in " ++ (SymbolT.C sc).nice g)) + E.fatal (view SymbolT.pos other) (text (other.nice g ++ " in " ++ sc.nice g)) where hasTyp = isJust . preview SymbolT.typ isSymL (SymbolT.L _) = true diff --git a/frege/compiler/GenMeta.fr b/frege/compiler/GenMeta.fr index c5292c63..6aa70f3f 100644 --- a/frege/compiler/GenMeta.fr +++ b/frege/compiler/GenMeta.fr @@ -527,7 +527,7 @@ annoSymV symv' = do let symv = case symv' of { SymbolT.V x -> x; } gargs ← mapM tauIndex symv.gargs case isPSigma symv.typ of - true -> E.fatal symv.pos (text ((SymbolT.V symv).nice g ++ " has no type.")) + true -> E.fatal symv.pos (text (symv.nice g ++ " has no type.")) false -> do sig <- sigIndex symv.typ -- inline candidates must be safe tail calls and no loops @@ -559,7 +559,7 @@ annoSymV symv' = do when (sorry) do (if classop then E.error else E.hint) symv.pos - (text ("The code of " ++ nice (SymbolT.V symv) g + (text ("The code of " ++ nice symv g ++ " cannot be exported because it " ++ reason ++ ". ")) ttaus <- mapM (tauIndex) symv.throwing let a = meta g "SymV" [ diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index 7eae49fd..5b26a8e9 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -307,7 +307,7 @@ checkgroup7 nms = do let unsafeToSymV s = case s of { SymbolT.V x -> x; } sym <- unsafeToSymV <$> findV nm let sig = sym.typ - E.explain sym.pos (text ((SymbolT.V sym).nice g ++ " :: " ++ sig.nicer g)) + E.explain sym.pos (text (sym.nice g ++ " :: " ++ sig.nicer g)) typeSanity nm = do sym <- findV nm let unsafeToSymV s = case s of { SymbolT.V x -> x; } @@ -472,7 +472,7 @@ substInst (vbl@Vbl {pos, name = MName tn bs, typ = Just (ForAll [] rho)}) let unsafeToSymC s = case s of { SymbolT.C x -> x; } symc <- unsafeToSymC <$> findC tn -- must be a class because it appears in a contexts cname case filter ((view SymbolT.name symt ==) • fst) symc.insts of -- find instance - [] -> E.fatal pos (text ((SymbolT.C symc).nice g ++ " has no instance for " ++ symt.nice g)) + [] -> E.fatal pos (text (symc.nice g ++ " has no instance for " ++ symt.nice g)) [(_,iname)] {- | MName iname bs != qname -} -> do let unsafeToSymV s = case s of { SymbolT.V x -> x; } @@ -509,7 +509,7 @@ substInst (vbl@Vbl {pos, name = MName tn bs, typ = Just (ForAll [] rho)}) -- | otherwise = do -- E.logmsg TRACEO pos (text ("mustn't substitute " ++ qname.nice g ++ " in its own body.")) -- stio (Left vbl) - _ -> E.fatal pos (text ((SymbolT.C symc).nice g ++ " has multiple instances for " ++ symt.nice g)) + _ -> E.fatal pos (text (symc.nice g ++ " has multiple instances for " ++ symt.nice g)) _ -> do E.logmsg TRACEO pos (text ("no suitable instance: " ++ vbl.nice g ++ " :: " ++ rho.nicer g)) stio (Left vbl) -- TVar or Meta @@ -572,7 +572,7 @@ checkName nm = do changeSym $ SymbolT.V sym.{state=Typechecked, vis=Abstract, typ = sig} stio t | otherwise = do - E.error pos (msgdoc ("implementation missing for " ++ (SymbolT.V sym).nice g)) + E.error pos (msgdoc ("implementation missing for " ++ sym.nice g)) (sig, _) <- K.kiSigma [] [] t changeSym $ SymbolT.V sym.{state=Typechecked, typ=sig} stio t @@ -616,7 +616,7 @@ checkName nm = do let newsig = ForAll [] rho changeSym $ SymbolT.V sym.{typ = newsig, expr=Just (return ex), state = Typechecked} stio newsig - wrongsy -> E.fatal wrongsy.pos (text ("checkSym: wrong symbol: " ++ (SymbolT.V wrongsy).nice g + wrongsy -> E.fatal wrongsy.pos (text ("checkSym: wrong symbol: " ++ wrongsy.nice g ++ ", state=" ++ show wrongsy.state ++ ", expr isJust: " ++ show (isJust wrongsy.expr) ++ ", typ : " ++ wrongsy.typ.nice g)) @@ -668,8 +668,8 @@ quantifyWith f nms = do let sigma = substRigidSigma (Sigma.vars sigm) sigm changeSym $ SymbolT.V sym.{typ = sigma, expr = Just (return zex), anno = true} g <- getST - E.logmsg TRACET sym.pos (text ("qfy: " ++ (SymbolT.V sym).nice g ++ " :: " ++ sigma.nice g)) - E.explain sym.pos (text ((SymbolT.V sym).nice g ++ " :: " ++ sigma.nicer g)) + E.logmsg TRACET sym.pos (text ("qfy: " ++ sym.nice g ++ " :: " ++ sigma.nice g)) + E.explain sym.pos (text (sym.nice g ++ " :: " ++ sigma.nicer g)) other = Prelude.error "findV behaves badly" diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index 46caad7a..391897a1 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -541,7 +541,7 @@ transTApp (con:as) = do appTauSigmas posnt ras | ForAll _ (RhoTau _ tau) <- typ, length as < length alias.vars = do - E.error pos (msgdoc ("apply " ++ (SymbolT.A alias).nice g ++ " to at least " + E.error pos (msgdoc ("apply " ++ alias.nice g ++ " to at least " ++ show (length alias.vars) ++ " type arguments")) unit @@ -555,7 +555,7 @@ transTApp (con:as) = do targs <- mapSt forceTau sargs let env = TM.fromList (zip (map Tau.var alias.vars) targs) return (substSigma env alias.typ) - | otherwise = do E.error pos (msgdoc("Apply " ++ (SymbolT.A alias).nice g + | otherwise = do E.error pos (msgdoc("Apply " ++ alias.nice g ++ " to exactly " ++ show alias.vars.length ++ " type arguments.")) unit diff --git a/frege/compiler/classes/Nice.fr b/frege/compiler/classes/Nice.fr index 03c1de27..1d664ebe 100644 --- a/frege/compiler/classes/Nice.fr +++ b/frege/compiler/classes/Nice.fr @@ -91,6 +91,29 @@ instance Nice SName where nice s _ = s.show +instance Nice (SymT Global) where + nice sym = nice $ SymbolT.T sym + nicer sym = nicer $ SymbolT.T sym +instance Nice (SymL Global) where + nice sym = nice $ SymbolT.L sym + nicer sym = nicer $ SymbolT.L sym +instance Nice (SymD Global) where + nice sym = nice $ SymbolT.D sym + nicer sym = nicer $ SymbolT.D sym +instance Nice (SymC Global) where + nice sym = nice $ SymbolT.C sym + nicer sym = nicer $ SymbolT.C sym +instance Nice (SymI Global) where + nice sym = nice $ SymbolT.I sym + nicer sym = nicer $ SymbolT.I sym +instance Nice (SymV Global) where + nice sym = nice $ SymbolT.V sym + nicer sym = nicer $ SymbolT.V sym +instance Nice (SymA Global) where + nice sym = nice $ SymbolT.A sym + nicer sym = nicer $ SymbolT.A sym + + instance Nice Symbol where nice (sym@(SymbolT.L SymL{alias})) g = category sym g ++ " `" ++ alias.nice g ++ "`" nice sym g = category sym g ++ " `" ++ (view SymbolT.name sym).nice g ++ "`" diff --git a/frege/compiler/gen/java/DataCode.fr b/frege/compiler/gen/java/DataCode.fr index cadbf493..101f760f 100644 --- a/frege/compiler/gen/java/DataCode.fr +++ b/frege/compiler/gen/java/DataCode.fr @@ -33,7 +33,7 @@ dataCode :: Symbol → StG [JDecl] -} dataCode (SymbolT.T (sym@SymT{enum = true})) = do g ← getST - E.logmsg TRACEG sym.pos (text ("dataCode for enum " ++ nicer (SymbolT.T sym) g)) + E.logmsg TRACEG sym.pos (text ("dataCode for enum " ++ nicer sym g)) sub <- subDecls (SymbolT.T sym) @@ -58,7 +58,7 @@ dataCode (SymbolT.T (sym@SymT{enum = true})) = do -} dataCode (SymbolT.T (sym@SymT{product = true, newt = true})) = do g ← getST - E.logmsg TRACEG sym.pos (text ("dataCode for newtype " ++ nicer (SymbolT.T sym) g)) + E.logmsg TRACEG sym.pos (text ("dataCode for newtype " ++ nicer sym g)) sub <- subDecls (SymbolT.T sym) let result = JClass{attr = attrs [JAbstract, JPublic, JStatic], @@ -79,7 +79,7 @@ dataCode (SymbolT.T (sym@SymT{product = true, newt = true})) = do -} dataCode (SymbolT.T (sym@SymT{ product = true })) = do g ← getST - E.logmsg TRACEG sym.pos (text ("dataCode for product " ++ nicer (SymbolT.T sym) g)) + E.logmsg TRACEG sym.pos (text ("dataCode for product " ++ nicer sym g)) con <- conDecls $ head [ con | SymbolT.D con <- values sym.env ] sub <- subDecls (SymbolT.T sym) @@ -132,7 +132,7 @@ dataCode (SymbolT.T (sym@SymT{ product = true })) = do -} dataCode (SymbolT.T (sym@SymT{ nativ = Nothing, product = false, newt = false })) = do g ← getST - E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer (SymbolT.T sym) g)) + E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer sym g)) -- constructors let csyms = [ con | SymbolT.D con <- values sym.env ] @@ -173,7 +173,7 @@ dataCode (SymbolT.T (sym@SymT{ nativ = Nothing, product = false, newt = false }) return (if null csyms then [] -- no code for empty data (i.e. a -> b) - else [JComment (nice (SymbolT.T sym) g), result]) + else [JComment (nice sym g), result]) {-- Native data types are mapped to a class that acts as namespace @@ -181,7 +181,7 @@ dataCode (SymbolT.T (sym@SymT{ nativ = Nothing, product = false, newt = false }) -} dataCode (SymbolT.T (sym@SymT{ nativ = Just _ })) = do -- nativ g ← getST - E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer (SymbolT.T sym) g)) + E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer sym g)) sub <- subDecls (SymbolT.T sym) @@ -193,7 +193,7 @@ dataCode (SymbolT.T (sym@SymT{ nativ = Just _ })) = do gvars = [], extend = Nothing, implement = [], defs = sub} - pure [JComment (nice (SymbolT.T sym) g), result] + pure [JComment (nice sym g), result] dataCode sym = do g ← getST @@ -273,7 +273,7 @@ conDecls sym = do ++ (if arity == 0 then [single, singleton] else [make]) -- (if isTupleLike then [makeStrict] else []) ++ members - comment = JComment (nice (SymbolT.D sym) g) + comment = JComment (nice sym g) ttype = si.returnJT ctype = variantType g si.returnJT (SymbolT.D sym) constrargs = argDefs attrFinal si (getArgs g) @@ -337,7 +337,7 @@ asThunkMethod t = atomMethod "asThunk" (inThunk t) "null" subDecls ∷ Symbol → StG [JDecl] subDecls (SymbolT.T sym) = do g ← getST - E.logmsg TRACEG sym.pos (text ("subDecls for " ++ nicer (SymbolT.T sym) g)) + E.logmsg TRACEG sym.pos (text ("subDecls for " ++ nicer sym g)) let isSymD (SymbolT.D _) = true isSymD _ = false let subdefs = filter (not . isSymD) (values sym.env) -- no constructors diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index f78c4a58..d33d6c00 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -99,7 +99,7 @@ classCode (SymbolT.C (sym@SymC{tau = TVar{var,kind}})) = do -- type cl name, gvars, implement = superclasses, defs = concat abstrFuns} - stio [JComment (nice (SymbolT.C sym) g), result] + stio [JComment (nice sym g), result] --- If given something else than a type class this is a fatal compiler error classCode sym = do @@ -172,7 +172,7 @@ abstractFun symc sym = do name = latinF ++ (symJavaName g (SymbolT.V sym)).base, args = formalctxs ++ formalargs, body = JEmpty} - pure [JComment ((nicer (SymbolT.V sym) g) ++ " :: " ++ nicer sym.typ g), result] + pure [JComment ((nicer sym g) ++ " :: " ++ nicer sym.typ g), result] abstractFun symc symx = do g ← getST @@ -347,7 +347,7 @@ instanceCode (SymbolT.I sym) = do -- instance definition ++ make ++ instFuns ++ concat instImpls} - pure [JComment (nice (SymbolT.I sym) g ++ " :: " ++ nice sym.typ g), result] + pure [JComment (nice sym g ++ " :: " ++ nice sym.typ g), result] --- If given something else than a type class this is a fatal compiler error instanceCode sym = do @@ -374,7 +374,7 @@ instFun symc symi mname = do -- replace symc with class where method was introduced let unsafeToSymC s = case s of { SymbolT.C x -> x; } symc <- unsafeToSymC <$> findC (view SymbolT.name cmem).tynm - E.logmsg TRACEG symi.pos (text "instFun" <+> text (nicer (SymbolT.V sym) g) + E.logmsg TRACEG symi.pos (text "instFun" <+> text (nicer sym g) <+> text "for" <+> text (nicer cmem g)) -- We need to tweek the types a bit so that java type variables won't conflict. -- hypothetical scenario diff --git a/frege/compiler/gen/java/Match.fr b/frege/compiler/gen/java/Match.fr index 12541cc4..122ad09e 100644 --- a/frege/compiler/gen/java/Match.fr +++ b/frege/compiler/gen/java/Match.fr @@ -239,7 +239,7 @@ match assert (pat@PCon {pos,qname,pats}) bind cont binds = do else realize "$" vbind -- TList.DCons $2 = $1._DCons() E.logmsg TRACEG pos (text "match constructor " - <+> text (nicer (SymbolT.D symd) g) + <+> text (nicer symd g) text "realized at " <+> text (show varb) text "fields:" diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index c2813675..f31f61b2 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -162,13 +162,13 @@ topFun (sym@SymV {expr = Just dx}) binds = do -- args = ctxArgs ++ strictArgs, -- body = JBlock [strictStmt]} - pure ([JComment ((nicer (SymbolT.V sym) g) ++ " " ++ show sym.strsig ++ " " ++ show sym.rkind), + pure ([JComment ((nicer sym g) ++ " " ++ show sym.strsig ++ " " ++ show sym.rkind), JComment (nicer sym.typ g), worker]) topFun sym binds = do g ← getST - error ("topFun: no SymV with expression " ++ nicer (SymbolT.V sym) g) + error ("topFun: no SymV with expression " ++ nicer sym g) {-- Code for a let/where bound function that has at least one of the following properties: @@ -216,13 +216,13 @@ localFun (sym@SymV {expr = Just dx}) binds = do args = ctxArgs ++ methArgs, body = JBlock stmts} - pure ([JComment ((nicer (SymbolT.V sym) g) ++ " " ++ show sym.strsig ++ " " ++ show sym.rkind), + pure ([JComment ((nicer sym g) ++ " " ++ show sym.strsig ++ " " ++ show sym.rkind), JComment (nicer sym.typ g), worker]) localFun sym binds = do g ← getST - E.fatal sym.pos (text "invalid local fun " <+> text ((SymbolT.V sym).nice g)) + E.fatal sym.pos (text "invalid local fun " <+> text (sym.nice g)) --- Used to remove the @final@ attributes of arguments. Needed for polymorphic recursion. unFinal ∷ Bool → FormalArg → FormalArg @@ -274,7 +274,7 @@ innerFun (SymbolT.V (sym@SymV {expr = Just dx})) binds = do !member = JMember{attr = attrFinal, jtype = funcjt, name = methName, init = Just (JCast funcjt lambda)} - pure [JComment ((nicer (SymbolT.V sym) g) ++ " :: " ++ nicer sym.typ g), + pure [JComment ((nicer sym g) ++ " :: " ++ nicer sym.typ g), member] innerFun sym binds = do @@ -320,7 +320,7 @@ cafCode (sym@SymV {name, depth = 0, expr = Just dx}) binds = do changeSym $ SymbolT.V sym.{rkind=xkind} let comments = [ - JComment ((nicer (SymbolT.V sym) g) ++ " " ++ show sym.strsig ++ " " ++ show xkind), + JComment ((nicer sym g) ++ " " ++ show sym.strsig ++ " " ++ show xkind), JComment (nicer sym.typ g), JComment (nicer x g)] name = symJavaName g (SymbolT.V sym) -- P.foo @@ -337,7 +337,7 @@ cafCode (sym@SymV {name, depth = 0, expr = Just dx}) binds = do code ← do let badguard = openCaseWhen g x jthrow = [JThrow (JNew (Ref (JName "frege.runtime" "GuardFailed") []) [ - JAtom (show (nicer (SymbolT.V sym) g)), + JAtom (show (nicer sym g)), JAtom (show sym.pos)])] code <- compiling (SymbolT.V sym) (genReturn stype x binds) case badguard of @@ -388,7 +388,7 @@ innerCaf :: SymV Global -> TreeMap Int Binding -> Bool -> StG [JDecl] innerCaf sym binds mutual = do g ← getST - E.logmsg TRACEG sym.pos (text ("compiling inner " ++ (SymbolT.V sym).nice g)) + E.logmsg TRACEG sym.pos (text ("compiling inner " ++ sym.nice g)) let memName = (symJavaName g (SymbolT.V sym)).base memAttrs = attrs [JFinal] diff --git a/frege/compiler/passes/Easy.fr b/frege/compiler/passes/Easy.fr index c377b92f..c7bb9d08 100644 --- a/frege/compiler/passes/Easy.fr +++ b/frege/compiler/passes/Easy.fr @@ -109,9 +109,9 @@ checkDepth (SymbolT.V (vsym@SymV {pos, name = MName inst base})) = do cmeth <- unsafeToSymV <$> classMethodOfInstMethod pos inst base when (cmeth.depth > vsym.depth) do U.symWarning E.hint (SymbolT.V vsym) (msgdoc ( - nicer (SymbolT.V vsym) g ++ " has depth " ++ show vsym.depth + nicer vsym g ++ " has depth " ++ show vsym.depth ++ " while " - ++ nicer (SymbolT.V cmeth) g ++ " has depth " ++ show cmeth.depth)) + ++ nicer cmeth g ++ " has depth " ++ show cmeth.depth)) when (cmeth.depth < vsym.depth) do changeSym $ SymbolT.V vsym.{depth = cmeth.depth} return () @@ -127,7 +127,7 @@ checkDepth (SymbolT.L (vsym@SymL {pos, alias, name = MName inst base})) = do ++ nicer vsym.name g ++ " because it has depth " ++ show d ++ " while " - ++ nicer (SymbolT.V cmeth) g ++ " has depth " ++ show cmeth.depth)) + ++ nicer cmeth g ++ " has depth " ++ show cmeth.depth)) return () checkDepth bad = do g <- getST @@ -165,7 +165,7 @@ depthSym (vsym@SymV {pos}) ++ " :: " ++ maybe "nix" (flip nice g) nx.typ)) changeSym $ SymbolT.V vsym.{expr = Just (return newx), typ, depth = newd} when (newd != (length sigmas)) do - E.fatal vsym.pos (text (nice (SymbolT.V vsym) g ++ ": after eta expansion depth=" + E.fatal vsym.pos (text (nice vsym g ++ ": after eta expansion depth=" ++ show newd ++ ", length sigmas=" ++ show (length sigmas) ++", turn on -x9")) | otherwise = changeSym $ SymbolT.V vsym.{depth = length sigmas} diff --git a/frege/compiler/passes/LetUnroll.fr b/frege/compiler/passes/LetUnroll.fr index dbf26283..cccaaebb 100644 --- a/frege/compiler/passes/LetUnroll.fr +++ b/frege/compiler/passes/LetUnroll.fr @@ -58,7 +58,7 @@ unrollSym (vsym@SymV {pos}) | otherwise = stio () -- do nothing unrollSym sym = do g <- getST - E.fatal sym.pos (text ("unrollSym no SymV : " ++ (SymbolT.V sym).nice g)) + E.fatal sym.pos (text ("unrollSym no SymV : " ++ sym.nice g)) unLetSym (vsym@SymV {pos}) @@ -68,7 +68,7 @@ unLetSym (vsym@SymV {pos}) | otherwise = stio () -- do nothing unLetSym sym = do g <- getST - E.fatal sym.pos (text ("unLetSym no SymV : " ++ (SymbolT.V sym).nice g)) + E.fatal sym.pos (text ("unLetSym no SymV : " ++ sym.nice g)) unrollExpr = U.mapEx true unrollLet @@ -147,7 +147,7 @@ unusedLet (x@Let {env,ex}) = do foreach syms (\sym -> unless (sym.name.base ~ ´^_´) do E.hint (getrange $ SymbolT.V sym) (msgdoc ( - nicer (SymbolT.V sym) g ++ " is not used anywhere.")) + nicer sym g ++ " is not used anywhere.")) ) stio (Left ex) else stio (Left x) diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index 823af589..7f893757 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -92,7 +92,7 @@ easyClassMethodSym (sym@SymV{expr = Just dx, typ}) = do easy <- goodClassMethod x unless ( easy ) do g <- getST - U.symWarning E.warn (SymbolT.V sym) (text (nice (SymbolT.V sym) g + U.symWarning E.warn (SymbolT.V sym) (text (nice sym g ++ (if easy then "" else " is not easy enough ") ++ (if RSafeTC `member` sym.rkind then "" else " recurses deeply ") ++ (if RTailRec `member` sym.rkind then " is tail recursive " else ""))) @@ -453,7 +453,7 @@ strictName sids nm = do let unsafeToSymV s = case s of { SymbolT.V x -> x; } v <- unsafeToSymV <$> U.findV nm when (v.state != StrictChecked) do - E.logmsg TRACES v.pos (text ("strictness analysis for " ++ (SymbolT.V v).nice g)) + E.logmsg TRACES v.pos (text ("strictness analysis for " ++ v.nice g)) let ari = U.arity $ SymbolT.V v -- ... based on type notLazy sym = RValue `member` sym.rkind case v of @@ -522,7 +522,7 @@ strictName sids nm = do ++ show strsig)) changeSym $ SymbolT.V v.{strsig, state = StrictChecked} stio [] - other -> E.fatal other.pos (text ("strictness: strange symbol " ++ (SymbolT.V other).nice g)) + other -> E.fatal other.pos (text ("strictness: strange symbol " ++ other.nice g)) {-- diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index dd774d6e..7a035e49 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -163,7 +163,7 @@ inlineCandidates = do notOurCode (sym, p) = do g <- getST E.warn (Pos (SName.id p) (SName.id p)) - (text ("Cannot export code of " ++ nicer (SymbolT.V sym) g + (text ("Cannot export code of " ++ nicer sym g ++ (if g.ourSym (SymbolT.V sym) then " because it has none." -- no code else " because defined elsewhere.") -- not our @@ -521,7 +521,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do case find ((meth.name.base ==)•("upd$"++)•unJust•ConField.name) flds of Just cf -> do E.logmsg TRACE5 meth.pos (text "polymorphic update " - <+> text (nice (SymbolT.V meth) g) + <+> text (nice meth g) <+> text " :: " <+> text (nice cf.typ g)) let mtyp = ForAll (dtyp.typ.bound) rho1 where @@ -531,7 +531,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do cft = cf.typ kim ← fst <$> kiSigma [] [] mtyp changeSym $ SymbolT.V meth.{typ = kim, anno = true} - E.logmsg TRACE5 meth.pos (text (nice (SymbolT.V meth) g ++ " :: " ++ nicer mtyp g)) + E.logmsg TRACE5 meth.pos (text (nice meth g ++ " :: " ++ nicer mtyp g)) return () Nothing -> E.fatal dtyp.pos (text (nice meth.name g ++ ": field not found.")) -- determine type of chg$f method when field f is polymorphic, like in @@ -556,7 +556,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do chgPolyAnn :: SymT Global -> [ConField QName] -> SymV Global -> StG () chgPolyAnn dtyp flds meth = do g <- getST - E.logmsg TRACE5 meth.pos (text ("polymorphic change " ++ nice (SymbolT.V meth) g)) + E.logmsg TRACE5 meth.pos (text ("polymorphic change " ++ nice meth g)) case find ((meth.name.base ==)•("chg$"++)•unJust•ConField.name) flds of Just cf -> do -- we have: @@ -590,7 +590,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do rho = record}} kir ← fst <$> kiSigma [] [] result changeSym $ SymbolT.V meth.{typ = kir, anno = true} - E.logmsg TRACE5 meth.pos (text (nice (SymbolT.V meth) g ++ " :: " ++ nicer kir g)) + E.logmsg TRACE5 meth.pos (text (nice meth g ++ " :: " ++ nicer kir g)) pure () Nothing -> E.fatal dtyp.pos (text (nice meth.name g ++ ": field not found.")) @@ -609,7 +609,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do sigmas <- mapSt (transSigma1 • ConField.typ) d.flds let nfs sigs = zipWith ConField.{typ=} con.flds sigs typ = ForAll bndrs (foldr (RhoFun []) rho sigmas) - E.logmsg TRACE5 con.pos (text ((SymbolT.D con).nice g ++ " :: " ++ typ.nice g)) + E.logmsg TRACE5 con.pos (text (con.nice g ++ " :: " ++ typ.nice g)) sig <- U.validSigma typ >>= kiSigma [] [] >>= pure . fst let additional = filter (`notElem` map _.var bndrs) (map _.var sig.bound) unless (null additional) do @@ -954,7 +954,7 @@ transExpr env fname ex = do stio (D.Let {env=nenv, ex, typ=Nothing}) where checkDefined (SymV {expr = Just _}) = stio () - checkDefined sym = E.error sym.pos (msgdoc (nice (SymbolT.V sym) g ++ " is annotated but not defined.")) + checkDefined sym = E.error sym.pos (msgdoc (nice sym g ++ " is annotated but not defined.")) enterlocal :: [QName] -> LetMemberS -> StG [QName] enterlocal env def = case findLocal env (defname def) of Local 0 _ = do -- not yet entered @@ -1024,7 +1024,7 @@ transExpr env fname ex = do f2s = if length miss == 1 then "field " else "fields " unless (null badf) do g <- getST - E.error pos (msgdoc (nice (SymbolT.D symd) g ++ " has no " ++ f1s ++ joined ", " badf)) + E.error pos (msgdoc (nice symd g ++ " has no " ++ f1s ++ joined ", " badf)) unless (null miss) do g <- getST E.error pos (msgdoc (f2s ++ joined ", " miss ++ " missing in construction of " From 1b872dcb5af1ca3cb4aa0df602afcef2166fc8f0 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 12:05:06 +0900 Subject: [PATCH 07/95] Modify findV to return SymV, same for other Sym?s Lots of redundant unsafeToSymVs and its friends were removed. --- frege/compiler/Classes.fr | 69 +++++++++-------------- frege/compiler/GenMeta.fr | 6 +- frege/compiler/Javatypes.fr | 4 +- frege/compiler/Kinds.fr | 55 ++++++++---------- frege/compiler/Typecheck.fr | 72 +++++++++--------------- frege/compiler/Utilities.fr | 49 ++++++++-------- frege/compiler/common/ImpExp.fr | 4 +- frege/compiler/common/Trans.fr | 8 +-- frege/compiler/gen/java/InstanceCode.fr | 9 +-- frege/compiler/gen/java/Instantiation.fr | 6 +- frege/compiler/gen/java/Match.fr | 27 ++++----- frege/compiler/gen/java/VarCode.fr | 30 ++++------ frege/compiler/passes/Easy.fr | 12 ++-- frege/compiler/passes/Fields.fr | 5 +- frege/compiler/passes/GenCode.fr | 2 +- frege/compiler/passes/GlobalLam.fr | 3 +- frege/compiler/passes/LetUnroll.fr | 20 +++---- frege/compiler/passes/Strict.fr | 20 +++---- frege/compiler/passes/Transdef.fr | 14 ++--- frege/compiler/tc/Util.fr | 13 ++--- 20 files changed, 172 insertions(+), 256 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index 2e37c36f..9ddb6dda 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -118,8 +118,7 @@ passC = do -- bring all super classes in dependency order deporder :: QName -> StG () deporder clas = do - let unsafeToSymC s = case s of { SymbolT.C x -> x; } - symc <- unsafeToSymC <$> U.findC clas + symc <- U.findC clas let allsups = superclasses (SymbolT.C symc) g newsups = [ s | s <- ordered, s `elem` allsups ] changeSym $ SymbolT.C symc.{supers=newsups} @@ -154,10 +153,9 @@ passC = do not (isPSigma typ), ] let newkind = if kind `keq` KVar then KType else kind - let unsafeToSymC s = case s of { SymbolT.C x -> x; } - symc <- unsafeToSymC <$> U.findC symc.name + symc <- U.findC symc.name changeSym $ SymbolT.C symc.{tau <- Tau.{kind = newkind}} -- update class var - symc <- unsafeToSymC <$> U.findC symc.name + symc <- U.findC symc.name foreach symc.supers (supercheck $ SymbolT.C symc) foreach (values symc.env) (methodcheck symc) nothing -> E.fatal Position.null (text ("lost class " ++ QName.nice qcls g)) @@ -374,11 +372,11 @@ passI alien = do alienInstsForClass c = do g <- getST csym <- U.findC c - E.logmsg TRACE6 (view SymbolT.pos csym) (text ("alien instances for " ++ QName.nice c g)) + E.logmsg TRACE6 csym.pos (text ("alien instances for " ++ QName.nice c g)) let insts = -- (map Symbol.name • sortBy (descending (Position.start • Symbol.pos))) [ ins.name | env <- values g.packages, SymbolT.I ins <- values env, - ins.clas == c || ins.clas == view SymbolT.name csym] + ins.clas == c || ins.clas == csym.name] foreach insts (instForClass true c) -- foreach insts (checkTypeAgainst true c) stio (length insts) @@ -386,25 +384,23 @@ alienInstsForClass c = do instsForClass c = do g <- getST csym <- U.findC c - E.logmsg TRACE6 (view SymbolT.pos csym) (text ("instances for " ++ QName.nice c g)) + E.logmsg TRACE6 csym.pos (text ("instances for " ++ QName.nice c g)) let insts = [ ins.name | SymbolT.I ins <- values g.thisTab, - ins.clas == c || ins.clas == (view SymbolT.name csym)] + ins.clas == c || ins.clas == csym.name] foreach insts (instForClass false c) -- foreach insts (checkTypeAgainst c) stio (length insts) instForClass alien c iname = do g <- getST - let unsafeToSymC s = case s of { SymbolT.C x -> x; } - unsafeToSymI s = case s of { SymbolT.I x -> x; } - csym <- unsafeToSymC <$> U.findC c + csym <- U.findC c when (not alien) do -- check if class kind matches - isym <- unsafeToSymI <$> U.findI iname + isym <- U.findI iname (sig, ki) <- K.kiSigmaX isym.typ csym.tau.kind changeSym $ SymbolT.I isym.{typ=sig} - isym <- unsafeToSymI <$> U.findI iname + isym <- U.findI iname case instTSym isym.typ g of Just (SymbolT.T (tsym@SymT{pos})) -> do E.logmsg TRACE6 isym.pos (text (isym.nice g ++ " " ++ tsym.nice g)) @@ -415,7 +411,7 @@ instForClass alien c iname = do foreach (reverse csym.supers) (instForThisClass isym.name tsym.name) csyms <- mapSt U.findC (csym.name:csym.supers) - isym <- unsafeToSymI <$> U.findI isym.name + isym <- U.findI isym.name when (not alien || g.our isym.name) do tcInstMethods csyms $ SymbolT.I isym mu -> E.fatal isym.pos (text ("instForClass: bad instance type " ++ isym.typ.nice g)) @@ -434,15 +430,13 @@ instForClass alien c iname = do -} checkSuperInstance iname tname cname bname = do g <- getST - let unsafeToSymI s = case s of { SymbolT.I x -> x; } - unsafeToSymC s = case s of { SymbolT.C x -> x; } - isym <- unsafeToSymI <$> U.findI iname - bsym <- unsafeToSymC <$> U.findC bname + isym <- U.findI iname + bsym <- U.findC bname -- look for super instance case filter ((tname ==) • fst) bsym.insts of (_,sinst):_ -> do - ssym <- unsafeToSymI <$> U.findI sinst -- this is the super instance + ssym <- U.findI sinst -- this is the super instance let msg = "instance " ++ cname.nicer g ++ " " ++ isym.typ.rho.nicer g ++ " has a super instance " ++ bname.nicer g ++ " " ++ ssym.typ.rho.nicer g E.logmsg TRACE6 isym.pos (text msg) @@ -488,11 +482,9 @@ checkSuperInstance iname tname cname bname = do instForThisClass :: QName -> QName -> QName -> StG () instForThisClass iname tname cname = do g <- getST - let unsafeToSymI s = case s of { SymbolT.I x -> x; } - unsafeToSymC s = case s of { SymbolT.C x -> x; } tsym <- U.findT tname - isym <- unsafeToSymI <$> U.findI iname - csym <- unsafeToSymC <$> U.findC cname + isym <- U.findI iname + csym <- U.findC cname let previ = case filter ((tname ==) • fst) csym.insts of ((_,inst):_) -> Just inst _ -> Nothing @@ -500,7 +492,7 @@ instForThisClass iname tname cname = do case previ of Just oldinst | oldinst != iname = do - iold <- unsafeToSymI <$> U.findI oldinst + iold <- U.findI oldinst when (iold.clas == isym.clas) do U.symWarning E.warn (SymbolT.I isym) (msgdoc (tsym.nice g ++ " is already an instance of " ++ csym.nice g ++ " (" ++ oldinst.nice g @@ -516,9 +508,8 @@ instForThisClass iname tname cname = do E.logmsg TRACE6 isym.pos (text ("make " ++ tname.nice g ++ " an instance of " ++ csym.nice g)) foreach (map (view SymbolT.name) (values csym.env)) (funForCIT cname iname tname) - let unsafeToSymC c = case c of { SymbolT.C x -> x; } - csym <- unsafeToSymC <$> U.findC cname - changeSym $ SymbolT.C csym.{insts <- ((view SymbolT.name tsym, iname):)} + csym <- U.findC cname + changeSym $ SymbolT.C csym.{insts <- ((tsym.name, iname):)} --- check instance member function definition {-- @@ -539,14 +530,10 @@ instForThisClass iname tname cname = do funForCIT :: QName -> QName -> QName -> QName -> StG () funForCIT cname iname tname (mname@MName _ base) = do g <- getST - let unsafeToSymT s = case s of { SymbolT.T x -> x; } - unsafeToSymI s = case s of { SymbolT.I x -> x; } - unsafeToSymC s = case s of { SymbolT.C x -> x; } - unsafeToSymV s = case s of { SymbolT.V x -> x; } - tsym <- unsafeToSymT <$> U.findT tname - isym <- unsafeToSymI <$> U.findI iname - csym <- unsafeToSymC <$> U.findC cname - msym <- unsafeToSymV <$> U.findV mname + tsym <- U.findT tname + isym <- U.findI iname + csym <- U.findC cname + msym <- U.findV mname E.logmsg TRACE6 isym.pos (text ("funForCit class: " ++ nicer cname g ++ ", inst: " ++ nicer iname g ++ ", type: " ++ nicer tname g @@ -555,7 +542,7 @@ funForCIT cname iname tname (mname@MName _ base) = do tvmb = tsym.env.lookup mname.key -- implemented vsym = isJust (Symbol.expr vsym) || isJust (Symbol.nativ vsym) inherit xname = do - mem <- unsafeToSymV <$> U.findV xname + mem <- U.findV xname E.logmsg TRACE6 isym.pos (text ("inheriting " ++ mem.nice g)) if implemented $ SymbolT.V mem then do -- use default implementation @@ -718,21 +705,19 @@ implemented (SymbolT.V vsym) = isJust vsym.expr || isJust vsym.nativ {-- check for each method in an instance if the type is more specific than the class type -} -tcInstMethods :: [Symbol] -> Symbol -> StG () +tcInstMethods :: [SymC Global] -> Symbol -> StG () tcInstMethods supers inst = foreach (values (unsafePartialView SymbolT.env inst)) (tcInstMethod supers inst) {-- check if the type of an instance method is more specific than the type of the class method -} -tcInstMethod :: [Symbol] -> Symbol -> Symbol -> StG () +tcInstMethod :: [SymC Global] -> Symbol -> Symbol -> StG () tcInstMethod [] isym msym = do g <- getST E.error (view SymbolT.pos msym) (msgdoc (msym.nice g ++ " is not a class member function")) -tcInstMethod (sc':scs) isym msym +tcInstMethod (sc:scs) isym msym | hasTyp msym || isSymL msym = do - let unsafeToSymC (SymbolT.C x) = x - sc = unsafeToSymC sc' g <- getST case sc.env.lookupS (view SymbolT.name msym).key of Nothing -> tcInstMethod scs isym msym diff --git a/frege/compiler/GenMeta.fr b/frege/compiler/GenMeta.fr index 6aa70f3f..33f05b85 100644 --- a/frege/compiler/GenMeta.fr +++ b/frege/compiler/GenMeta.fr @@ -427,8 +427,7 @@ expIndex exp = encodeX exp >>= mbIndex let var = Vbl{pos=Position.null, name=Local 0 "", typ=Nothing} qexs ← mapM (expIndex . var.{name=}) env -- the list of symbols corresponding to the let bound names - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - syms ← mapM (fmap unsafeToSymV . U.findV) env + syms ← mapM U.findV env -- make (and encode) the list of sigmas sigs ← mapM (\s -> if SymV.anno s then sigIndex s.typ else return (-1)) syms -- make and encode the list of expressions @@ -445,8 +444,7 @@ expIndex exp = encodeX exp >>= mbIndex where k = if negated then -(ord kind) else ord kind encodeX (Vbl {name=Local u s}) = stio (Just defEA.{subx1 = u}) encodeX (Vbl {name}) = do -- no private data - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> U.findV name + sym <- U.findV name stio (if sym.vis != Private then Just defEA.{xkind = 8, name = Just name} else Nothing) encodeX exp = stio Nothing encodeP (PAnn {pat, typ}) = do diff --git a/frege/compiler/Javatypes.fr b/frege/compiler/Javatypes.fr index 7e7474de..97000438 100644 --- a/frege/compiler/Javatypes.fr +++ b/frege/compiler/Javatypes.fr @@ -109,8 +109,8 @@ findAllSupers name Left l -> liftStG do g <- getST syms <- mapM U.findT (U.typesOfNativ name g) - let oss = filter (g.ourSym) syms - pos = if null oss then Position.null else view SymbolT.pos (head oss) + let oss = filter (g.ourSym . SymbolT.T) syms + pos = if null oss then Position.null else (head oss).pos E.error pos (text ("`" ++ name ++ "` is not a known java class")) changeST Global.{javaEnv <- _.delete name} Right c -> do diff --git a/frege/compiler/Kinds.fr b/frege/compiler/Kinds.fr index be636cb5..6ca3722f 100644 --- a/frege/compiler/Kinds.fr +++ b/frege/compiler/Kinds.fr @@ -80,8 +80,7 @@ kiTypes = do --- do kind inference on a group of types kiTypeGroup qns = do - let unsafeToSymT s = case s of { SymbolT.T x -> x; } - types <- mapM (fmap unsafeToSymT . U.findT) qns + types <- mapM U.findT qns let vartypes = filter (varKind . SymT.kind) types -- with kinds that contain KVar names = map SymT.name vartypes foreach vartypes (kiTypeSym names . SymbolT.T) @@ -95,8 +94,7 @@ kiTypeSym names sym = do let cons = [ con | con@(SymbolT.D _) <- values $ unsafePartialView SymbolT.env sym ] foreach cons (kiConSym names) g ← getST - let unsafeToSymT s = case s of { SymbolT.T x -> x; } - sym <- fmap unsafeToSymT $ U.findT $ view SymbolT.name sym + sym <- U.findT $ view SymbolT.name sym let kflat (KApp k ks) = k : kflat ks kflat ks = [ks] typ = ForAll (zipWith Tau.{kind=} (sym.typ.bound) (kflat sym.kind)) sym.typ.rho @@ -221,13 +219,11 @@ kiRho names env (it@RhoFun{context,sigma,rho}) = do --- kind inference on a 'Ctx', takes into account kind checked classes only kiCtx names env Ctx{cname, tau} = do cls <- U.findC cname - case cls of - SymbolT.C symc -> - case symc.tau.kind of - KVar -> return env -- not yet kind checked - k -> do - (_, env) <- unifyTauKind names env tau k - return env + case cls.tau.kind of + KVar -> return env -- not yet kind checked + k -> do + (_, env) <- unifyTauKind names env tau k + return env type Envs = [TreeMap String Kind] @@ -295,25 +291,24 @@ unifyTauKind names env (TVar{pos,var,kind}) exp = do unifyTauKind names env (TCon{pos,name}) exp = do g <- getST sym <- U.findT name - case sym of - SymbolT.T symt -> do - E.logmsg TRACEK pos (text ("unifyTauKind: " ++ nice name g - ++ " initial " ++ show symt.kind - ++ " expected " ++ show exp)) - - case unifyKind symt.kind exp of - Just k -> do - when (! (k `keq` symt.kind) && symt.name `elem` names) do - changeSym $ SymbolT.T symt.{kind=k} - E.logmsg TRACEK pos (text ("unifyTauKind: " ++ nice name g ++ " result " ++ show k)) - return (k, env) - Nothing -> do - g <- getST - E.error pos (text ("kind error, type constructor `" ++ name.nice g - ++ "` has kind " - ++ show symt.kind - ++ ", expected was " ++ show exp)) - return (symt.kind, env) + + E.logmsg TRACEK pos (text ("unifyTauKind: " ++ nice name g + ++ " initial " ++ show sym.kind + ++ " expected " ++ show exp)) + + case unifyKind sym.kind exp of + Just k -> do + when (! (k `keq` sym.kind) && sym.name `elem` names) do + changeSym $ SymbolT.T sym.{kind=k} + E.logmsg TRACEK pos (text ("unifyTauKind: " ++ nice name g ++ " result " ++ show k)) + return (k, env) + Nothing -> do + g <- getST + E.error pos (text ("kind error, type constructor `" ++ name.nice g + ++ "` has kind " + ++ show sym.kind + ++ ", expected was " ++ show exp)) + return (sym.kind, env) -- TCon b ~ exp => check TCon for kb -> exp and b for kb unifyTauKind names env (it@TApp a b) exp = do diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index 5b26a8e9..ccff00bd 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -275,7 +275,7 @@ checkgroup7 nms = do g <- getST E.logmsg TRACEZ Position.null (text ("typechecking group: " ++ joined " " (map (flip QName.nice g) nms))) unless (null g.typEnv) do - mapSt findV nms >>= mapM_ renameSigma + mapSt findV nms >>= mapM_ (renameSigma . SymbolT.V) -- we set up typEnv with the names of the group members so that 'envTvs' will find them changeST Global.{typEnv <- (nms ++)} @@ -284,8 +284,7 @@ checkgroup7 nms = do -- foreach syms (\sym -> U.linkq (Local (show (Symbol.sid sym))) sym) -- foreach nms verbose foreach nms checkName - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - syms <- mapSt (fmap unsafeToSymV . findV) nms + syms <- mapSt findV nms when (length syms > 1 || any ((==Recursive) . _.state) syms) (foreach nms checkName) changeST Global.{typEnv <- drop (length nms)} @@ -304,14 +303,13 @@ checkgroup7 nms = do where verbose nm = do g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> findV nm + sym <- findV nm let sig = sym.typ E.explain sym.pos (text (sym.nice g ++ " :: " ++ sig.nicer g)) typeSanity nm = do sym <- findV nm let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> checkKind sym + sym <- unsafeToSymV <$> checkKind (SymbolT.V sym) checkAmbiguous (SymbolT.V sym) sym.typ checkReturn (SymbolT.V sym) sym.typ case sym.name of @@ -339,8 +337,7 @@ checkgroup7 nms = do Nothing -> return Nothing changeSym $ SymbolT.V it.{typ=sig, expr = nex} removeCtx (it@Let{env}) = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - syms <- mapM (fmap unsafeToSymV . U.findV) env + syms <- mapM U.findV env foreach syms scrapCtx return (Left it) removeCtx x = return (Left x) @@ -364,7 +361,7 @@ checkKind sym = fmap SymbolT.V $ correctK empty $ unsafeToSymV sym return new correctKind subst Let{env, ex, typ} = do - syms <- mapM (fmap unsafeToSymV . U.findV) env + syms <- mapM U.findV env mapM_ (correctK subst) syms ex' <- mapEx false (correctKind subst) ex pure $ Right Let{env, ex = ex', typ = fmap (substSigma subst) typ } @@ -451,8 +448,7 @@ substInstMethod :: QName -> StG () substInstMethod qname = do g <- getST -- when (U.isOn g.options.flags OPTIMIZE) do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> findV qname + sym <- findV qname case sym.expr of Nothing -> stio () Just dx -> do @@ -469,14 +465,12 @@ substInst (vbl@Vbl {pos, name = MName tn bs, typ = Just (ForAll [] rho)}) let tau = reducedTau g ctau case instTauSym tau g of Just symt -> do -- we have a type name - let unsafeToSymC s = case s of { SymbolT.C x -> x; } - symc <- unsafeToSymC <$> findC tn -- must be a class because it appears in a contexts cname + symc <- findC tn -- must be a class because it appears in a contexts cname case filter ((view SymbolT.name symt ==) • fst) symc.insts of -- find instance [] -> E.fatal pos (text (symc.nice g ++ " has no instance for " ++ symt.nice g)) [(_,iname)] {- | MName iname bs != qname -} -> do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - mem <- unsafeToSymV <$> findV vbl.name + mem <- findV vbl.name case g.findit (MName iname bs) of Just imem -> do let nrho = rho.{context <- filter (not • sameCtx ctx)} @@ -526,7 +520,7 @@ substInst x = stio (Left x) renameSigma ∷ Symbol -> StG () renameSigma sym' | sym.name.isLocal && sym.anno = do g ← getST - outer <- mapSt (fmap unsafeToSymV . findV) g.typEnv + outer <- mapSt findV g.typEnv let avoid = \c → c `elem` concatMap (Sigma.vars . _.typ) outer || (any (null . Sigma.vars . _.typ) outer && avoidBinders g c) newsym = sym.{typ ← avoidSigma avoid } @@ -546,13 +540,12 @@ renameSigma other = pure () checkName nm = do g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> findV nm + sym <- findV nm E.logmsg TRACEZ sym.pos (text ("checkName: " ++ sym.name.nice g ++ " :: " ++ sym.typ.nice g)) sigma <- checkSym sym unless (nm.isLocal) do sym <- findV nm - resolveConstraints sym + resolveConstraints $ SymbolT.V sym where checkSym sym = do g <- getST @@ -589,8 +582,7 @@ checkName nm = do RhoFun{} -> do changeSym $ SymbolT.V sym.{state=Typechecking, typ = ForAll [] rho0} checkRho x rho0 - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> findV sym.name -- refresh, might be updated meanwhile + sym <- findV sym.name -- refresh, might be updated meanwhile let newstate = if sym.state != Recursive then Typechecked else Recursive newsig <- maybe (error "untyped after checkRho") pure ex.typ changeSym $ SymbolT.V sym.{typ = newsig, expr=Just (return ex), state = newstate} @@ -611,8 +603,7 @@ checkName nm = do x <- dx (rho, ex) <- inferRho x rho <- zonkRho rho - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> findV sym.name -- refresh, might be updated meanwhile + sym <- findV sym.name -- refresh, might be updated meanwhile let newsig = ForAll [] rho changeSym $ SymbolT.V sym.{typ = newsig, expr=Just (return ex), state = Typechecked} stio newsig @@ -624,11 +615,11 @@ checkName nm = do quantifyOne nms = do g <- getST let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> U.findV (head nms) + sym <- U.findV (head nms) lsyms <- mapSt U.findV g.typEnv let rec = [ sym.typ | sym <- lsyms - , sym <- unsafeToSymV <$> g.follow sym -- follow aliases + , sym <- unsafeToSymV <$> g.follow (SymbolT.V sym) -- follow aliases , sym.state == Recursive] when (false && null sym.typ.rho.context && not (TH.isFun sym.typ g) && null rec) do quantifyWith (quantifiedExcept sym.sid) nms @@ -636,8 +627,7 @@ quantifyOne nms = do quantifyMany = quantifyWith quantified quantifyWith f nms = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - syms <- mapSt (fmap unsafeToSymV . findV) nms -- unquantified symbols + syms <- mapSt findV nms -- unquantified symbols g <- getST unless (null syms) do E.logmsg TRACET (head syms).pos (text ("quantify " ++ joined ", " (map (flip QName.nice g) nms))) @@ -658,8 +648,7 @@ quantifyWith f nms = do foreach asyms changeSig where changeSig (qnm, sigm) = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> findV qnm + sym <- findV qnm case sym of SymV {expr = Just dx} -> do x <- dx @@ -679,7 +668,7 @@ zonkRigid bound ex = do -- g <- getST mapEx false zonk ex where - symWork (SymbolT.V (symv@SymV{expr, typ = sig})) = do + symWork (symv@SymV{expr, typ = sig}) = do g <- getST -- E.logmsg TRACEZ (getpos ex) (text ("symWork: " ++ show (bound ++ sig.vars) ++ " " ++ nice ex g)) rhoz ← zonkRho sig.rho @@ -737,7 +726,7 @@ zonkExpr x = mapEx false zonk x foreach syms symWork stio (Left x.{typ = Just sig}) where - symWork (SymbolT.V (symv@SymV{expr = Just dex, typ = sig})) = do + symWork (symv@SymV{expr = Just dex, typ = sig}) = do sig <- zonkSigma sig ex <- dex ex <- zonkExpr ex @@ -967,8 +956,7 @@ tcRho' (x@Vbl {name}) ety = do true -> if symv.state == Unchecked then do checkName name - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> findV name + sym <- findV name rho <- instantiate sym.typ instRho x rho ety else if symv.state == Typechecking @@ -981,8 +969,7 @@ tcRho' (x@Vbl {name}) ety = do g <- getST E.fatal (getpos x) (text ("tcRho: untyped " ++ x.nice g ++ ", state=" ++ show symv.state)) tcRho' (x@Con {name}) ety = do - let unsafeToSymD s = case s of { SymbolT.D x -> x; } - sym <- unsafeToSymD <$> U.findD name + sym <- U.findD name rho <- instantiate sym.typ instRho x rho ety @@ -1215,16 +1202,14 @@ tcPat' (p@PLit {pos,kind}) ety = case kind of LRegex -> instPatSigma p (sigString) ety tcPat' (p@PVar {uid,var}) (ety@Check sig) = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> findV (Local{uid, base=var}) + sym <- findV (Local{uid, base=var}) case isPSigma sym.typ of true -> do changeSym $ SymbolT.V sym.{typ=sig, state=Typechecked} instPatSigma p sig ety false -> instPatSigma p sym.typ ety tcPat' (p@PVar {uid,var}) ety = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> findV (Local{uid, base=var}) + sym <- findV (Local{uid, base=var}) case isPSigma sym.typ of true -> do sig <- newSigmaTyVar (var, KType) @@ -1237,8 +1222,7 @@ tcPat' (p@PMat {pos,uid,var}) ety = do instPatSigma p sigString ety tcPat' (p@PCon {qname,pats}) ety = do - let unsafeToSymD s = case s of { SymbolT.D x -> x; } - sym <- unsafeToSymD <$> findD qname + sym <- findD qname rho <- instantiate sym.typ let spRho (RhoFun _ s r) = case spRho r of (args, ret) -> (s:args,ret) @@ -1359,8 +1343,7 @@ resolveHas expr = do countMem !acc Mem{} = return . Left $! (acc+1) countMem !acc Vbl{name} | not name.isLocal = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> U.findV name + sym <- U.findV name case sym.over of [] -> return . Right $! acc -- not overloaded _ -> return . Right $! (acc+1) -- overloaded @@ -1410,8 +1393,7 @@ rHas _ (x@Mem{ex, member, typ = Nothing}) = do error ("expression " ++ x.nicer g ++ " is untyped") rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> U.findV name + sym <- U.findV name case sym.over of [] -> return (Right v) _ -> resolveOver v $ SymbolT.V sym diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index 391897a1..93e6ff77 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -120,37 +120,41 @@ supersOfNativ nativ g = case g.javaEnv.lookup nativ of --- find a specific symbol or die +findC :: QName -> StG (SymC Global) findC qname = do g <- getST case g.findit qname of - Just (symc@(SymbolT.C _)) -> stio symc + Just (SymbolT.C sym) -> stio sym Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for class " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for class " ++ qname.nice g ++ ", found Nothing"))) +findI :: QName -> StG (SymI Global) findI qname = do g <- getST case g.findit qname of - Just (symc@(SymbolT.I _)) -> stio symc + Just (SymbolT.I sym) -> stio sym Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for instance " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for instance " ++ qname.nice g ++ ", found Nothing"))) +findT :: QName -> StG (SymT Global) findT qname = do g <- getST case g.findit qname of - Just (symc@(SymbolT.T _)) -> stio symc + Just (SymbolT.T sym) -> stio sym Just sym -> E.fatal (view SymbolT.pos sym) (fill (break("looked for type " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for type " ++ qname.nice g ++ ", found Nothing"))) +findV :: QName -> StG (SymV Global) findV qname = do g <- getST case g.findit qname of - Just (symc@(SymbolT.V _)) -> stio symc + Just (SymbolT.V sym) -> stio sym Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for function " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for function " ++ qname.nice g ++ ", found Nothing"))) @@ -166,10 +170,11 @@ findVD qname = do Nothing -> E.fatal Position.null (fill (break ("looked for function " ++ qname.nice g ++ ", found Nothing"))) +findD :: QName -> StG (SymD Global) findD qname = do g <- getST case g.findit qname of - Just (symc@SymbolT.D _) -> stio symc + Just (SymbolT.D sym) -> stio sym Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for constructor " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for constructor " ++ qname.nice g ++ ", found Nothing"))) @@ -693,7 +698,7 @@ foldEx b f a ex = do Let {env,ex} | b = do syms <- mapSt findV env - xs <- sequence [ x | SymbolT.V SymV{expr=Just x} <- syms ] + xs <- sequence [ x | SymV{expr=Just x} <- syms ] a <- foldSt (foldEx b f) a xs foldEx b f a ex | otherwise = foldEx b f a ex @@ -740,20 +745,20 @@ mapEx b f x = do Let {env,ex,typ} | b = do syms <- mapSt findV env - let xs = [ sy | sy@(SymbolT.V SymV{expr=Just _}) <- syms ] + let xs = [ sy | sy@SymV{expr=Just _} <- syms ] foreach xs mapsub ex <- mapEx b f ex stio (Let {env,ex,typ}) | otherwise = do ex <- mapEx b f ex stio (Let {env,ex,typ}) - where mapsub (SymbolT.V (sy@SymV {expr=Just dx})) = do + where mapsub (sy@SymV {expr=Just dx}) = do x <- dx x <- mapEx b f x changeSym $ SymbolT.V sy.{expr=Just (return x)} mapsub sy = do g <- getST - E.fatal (view SymbolT.pos sy) (text ("mapEx: strange symbol in let def rhs: " + E.fatal sy.pos (text ("mapEx: strange symbol in let def rhs: " ++ sy.nice g)) Lam {pat,ex,typ} = do ex <- mapEx b f ex @@ -858,17 +863,16 @@ copyExpr mbp t x = mapEx false (copy t) x where --- copy a local symbol copySym mbp tree qname = do sym <- findV qname - case sym of - SymbolT.V symt -> case tree.lookupI symt.sid of + case tree.lookupI sym.sid of Just nuid -> do - mex <- maybeST symt.expr id + mex <- maybeST sym.expr id mbx <- maybeST mex (copyExpr mbp tree) - let name = symt.name.{uid=nuid} - npos = (fromMaybe symt.pos mbp).change VARID name.base - nsym = symt.{pos = npos, name, expr = fmap return mbx, sid = nuid} + let name = sym.name.{uid=nuid} + npos = (fromMaybe sym.pos mbp).change VARID name.base + nsym = sym.{pos = npos, name, expr = fmap return mbx, sid = nuid} enter $ SymbolT.V nsym stio name - Nothing -> Prelude.error ("Can't find sid " ++ show symt.sid ++ " for name " ++ show symt.name) + Nothing -> Prelude.error ("Can't find sid " ++ show sym.sid ++ " for name " ++ show sym.name) maybeST (Just f) act = do @@ -886,12 +890,10 @@ maybeST Nothing _ = stio Nothing untypeExpr x = mapEx true unty x where untySy qn = do - sym <- findV qn - case sym of - SymbolT.V symv -> - changeSym $ SymbolT.V - symv.{ typ = if symv.anno then symv.typ else pSigma - , state = Unchecked } + symv <- findV qn + changeSym $ SymbolT.V + symv.{ typ = if symv.anno then symv.typ else pSigma + , state = Unchecked } unty (x@Ann{}) = return (Left x) -- keep type signatures intact unty (x@Lam{pat}) = do foreach (patNames pat) untySy @@ -1024,8 +1026,7 @@ returnTypeN n rho = Prelude.error "returnTypeN: too many arguments" --- tell if a given type is a java type isJavaType (TCon {name}) = do sym <- findT name - case sym of - SymbolT.T symt -> stio (isJust symt.nativ) + stio (isJust sym.nativ) isJavaType (tapp@TApp _ _) = isJavaType (head tapp.flat) isJavaType (Meta tv) | tv.isFlexi = do g <- getST diff --git a/frege/compiler/common/ImpExp.fr b/frege/compiler/common/ImpExp.fr index 3034fab0..84778d72 100644 --- a/frege/compiler/common/ImpExp.fr +++ b/frege/compiler/common/ImpExp.fr @@ -244,9 +244,7 @@ exprFromA sarray earray exa = case exa.xkind of mkStrictPVars PUser{pat,lazy} | PVar{pos,uid,var} <- pat = do sym <- U.findV (Local {base=var, uid}) - case sym of - SymbolT.V symv -> - changeSym $ SymbolT.V symv.{state=StrictChecked, strsig=if lazy then U else S[]} + changeSym $ SymbolT.V sym.{state=StrictChecked, strsig=if lazy then U else S[]} | otherwise = mkStrictPVars pat mkStrictPVars PAnn{pat} = mkStrictPVars pat mkStrictPVars PAt{pat} = mkStrictPVars pat diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index 47c6919c..11d90728 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -61,7 +61,7 @@ references sids x = U.foldEx true refs 0 x stio (Right (n + lrefs)) refs n (Let {env,ex}) = do syms <- mapSt U.findV env - srefs <-sequence [ subex | SymbolT.V SymV{expr = Just subex} <- syms ] >>= mapSt (references sids) + srefs <-sequence [ subex | SymV{expr = Just subex} <- syms ] >>= mapSt (references sids) lrefs <- references sids ex stio (Right (n + 2*sum srefs + lrefs)) refs n x = do @@ -166,8 +166,7 @@ patternStrictness :: Pattern -> StG Strictness patternStrictness p = case p of PVar {uid,var} -> do g ← getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - v <- unsafeToSymV <$> U.findV (Local uid var) + v <- U.findV (Local uid var) E.logmsg TRACES (getpos p) ( text "patternStrictness: " <+> text (nicer p g) @@ -189,8 +188,7 @@ patternStrictness p = case p of ps <- patternStrictness pat if lazy then case pat of PVar{uid, var} -> do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - v <- unsafeToSymV <$> U.findV (Local uid var) + v <- U.findV (Local uid var) when v.strsig.isStrict do changeSym $ SymbolT.V v.{strsig = U} pure U other → pure U diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index d33d6c00..8a7ebae0 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -212,8 +212,7 @@ abstractFun symc symx = do -} instanceCode (SymbolT.I sym) = do -- instance definition g <- getST - let unsafeToSymC s = case s of { SymbolT.C x -> x; } - csym <- unsafeToSymC <$> findC sym.clas + csym <- findC sym.clas let classes = sym.clas:csym.supers special = isSpecialClass csym @@ -360,8 +359,7 @@ instanceCode sym = do instFun :: SymC Global -> SymI Global -> QName -> StG JDecl instFun symc symi mname = do g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> findV mname + sym <- findV mname let classnames = symc.name:symc.supers special = isSpecialClass symc cmems = [ m | cln <- classnames @@ -372,8 +370,7 @@ instFun symc symi mname = do <+> text " but no class member found.") cmem:_ → do -- replace symc with class where method was introduced - let unsafeToSymC s = case s of { SymbolT.C x -> x; } - symc <- unsafeToSymC <$> findC (view SymbolT.name cmem).tynm + symc <- findC (view SymbolT.name cmem).tynm E.logmsg TRACEG symi.pos (text "instFun" <+> text (nicer sym g) <+> text "for" <+> text (nicer cmem g)) -- We need to tweek the types a bit so that java type variables won't conflict. diff --git a/frege/compiler/gen/java/Instantiation.fr b/frege/compiler/gen/java/Instantiation.fr index f2f4fcd1..ef2f9b81 100644 --- a/frege/compiler/gen/java/Instantiation.fr +++ b/frege/compiler/gen/java/Instantiation.fr @@ -81,14 +81,12 @@ resolveConstraint pos (ctx@Ctx {cname, tau}) = do pure (JAtom "UNKNOWN_CONTEXT") else pure ((JAtom • head) ok) makeCtx = do - let unsafeToSymC (SymbolT.C x) = x - csym <- unsafeToSymC <$> U.findC cname + csym <- U.findC cname let special = isSpecialClassName cname case tcon of TCon {name} -> case filter ((name ==) • fst) csym.insts of (_,iname):_ -> do - let unsafeToSymI (SymbolT.I x) = x - inst <- unsafeToSymI <$> U.findI iname + inst <- U.findI iname g <- getST let crho = RhoTau [] tau csig = ForAll [] crho diff --git a/frege/compiler/gen/java/Match.fr b/frege/compiler/gen/java/Match.fr index 122ad09e..056066f7 100644 --- a/frege/compiler/gen/java/Match.fr +++ b/frege/compiler/gen/java/Match.fr @@ -88,8 +88,7 @@ match :: Bool -> TreeMap Int Binding -> StG (Binding, [JStmt]) match assert (PVar {pos,uid,var}) bind cont binds = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - vsym <- unsafeToSymV <$> U.findV local + vsym <- U.findV local g ← getST let strict = vsym.strsig.isStrict @@ -127,8 +126,7 @@ match assert (p@PAt {pat,uid,var}) bind cont binds = do -- let patty = patternRMode g pat let local = Local uid var jname = (javaName g local).base - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - vsym <- unsafeToSymV <$> U.findV local + vsym <- U.findV local let comment bind = sComment ("match " ++ nice p g ++ "::" ++ nicer vsym.typ g ++ " with " ++ show bind) @@ -167,17 +165,14 @@ match assert (pat@PLit {kind=LBool, value}) bind cont binds = do match assert (pat@PCon {pos,qname,pats}) bind cont binds = do -- g <- getST - let unsafeToSymD s = case s of { SymbolT.D x -> x; } - symd <- unsafeToSymD <$> U.findD qname -- forall a.a -> List a -> List a - symt' <- U.findT symd.name.tynm -- forall a.List a - case symt' of - SymbolT.T symt -> - if symt.enum then matchEnum (SymbolT.D symd) (SymbolT.T symt) - else if symt.product - then if symt.newt - then matchNew (SymbolT.D symd) (SymbolT.T symt) - else matchProd (SymbolT.D symd) (SymbolT.T symt) -- pat bind cont binds - else matchVariant (SymbolT.D symd) (SymbolT.T symt) -- pat bind cont binds + symd <- U.findD qname -- forall a.a -> List a -> List a + symt <- U.findT symd.name.tynm -- forall a.List a + if symt.enum then matchEnum (SymbolT.D symd) (SymbolT.T symt) + else if symt.product + then if symt.newt + then matchNew (SymbolT.D symd) (SymbolT.T symt) + else matchProd (SymbolT.D symd) (SymbolT.T symt) -- pat bind cont binds + else matchVariant (SymbolT.D symd) (SymbolT.T symt) -- pat bind cont binds where unKindedStrict g lbnd = case strictBind g lbnd of kbnd -> case kbnd.jtype of @@ -381,7 +376,7 @@ match _ pat b c bs = do matchCon assert (PCon {pos,qname, pats}) con bexs cont binds = do g <- getST sym <- U.findD qname - if view SymbolT.sid sym != view SymbolT.sid con + if sym.sid != view SymbolT.sid con then do E.fatal pos (text ("matchCon: " ++ nice qname g ++ " against " ++ nice con g)) else do diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index f31f61b2..6a725702 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -507,8 +507,7 @@ genStmts jret rm (x@Case {ckind,ex=cex,alts=calts}) binds = genCaseStmt jret rm genStmts jret rm (x@Let {env, ex}) binds = do case env of [k] -> do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - symv <- unsafeToSymV <$> U.findV k + symv <- U.findV k -- change -- > let !name = simple in ex @@ -752,7 +751,7 @@ genCaseStmt jret rm (x@Case {ckind,ex=cex,alts=calts}) binds = do case pat of PCon {qname} -> do sym <- U.findD qname - if view SymbolT.sid sym == con.sid then do + if sym.sid == con.sid then do let nbexs = case stri of S ss -> zipWith (bexStr g) bexs (ss ++ allLazy) _ -> bexs @@ -782,8 +781,7 @@ genCaseStmt jret rm (x@Case {ckind,ex=cex,alts=calts}) binds = do -- check if an expression is a constructor application constrApp (ex@App _ _ _) = case map fst (flatx ex) of Con {name}:xs -> do - let unsafeToSymD s = case s of { SymbolT.D x -> x; } - sym <- unsafeToSymD <$> U.findD name + sym <- U.findD name if length sym.flds == length xs then pure (Just (sym, xs)) else pure Nothing -- for example: case (,) a of mktuple -> mktuple b @@ -793,8 +791,7 @@ genCaseStmt jret rm (x@Case {ckind,ex=cex,alts=calts}) binds = do conUVarAlt false _ = pure false conUVarAlt true (CAlt {pat = PCon {pos}}) = pure true conUVarAlt true (CAlt {pat = PVar {var,uid}, ex}) = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> U.findV (Local uid var) + sym <- U.findV (Local uid var) refs <- T.references [sym.sid] ex pure (refs == 0) conUVarAlt _ _ = pure false @@ -867,8 +864,7 @@ genLet jret rm x binds = do incls = concat (take (length envxx - length after) envxx) genLetEnvs jret rm (map SymbolT.V before) (map SymbolT.V incls) (map SymbolT.V after) letex binds where - unsafeToSymV s = case s of { SymbolT.V x -> x; } - toSym = mapM (fmap unsafeToSymV . U.findV) + toSym = mapM U.findV (letex, envqq) = collect x [] -- collect the environments of nested lets in reverse order collect ∷ ExprT → [[QName]] → (ExprT,[[QName]]) @@ -905,8 +901,7 @@ genLetEnvs jret rm before' inclass' after' ex binds = do g <- getST forM syms (changeSym . SymbolT.V . _.{rkind ← (BitSet.`unionE` RMethod)}) -- refresh the symbols - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - syms <- mapM (fmap unsafeToSymV . U.findV) (map _.name syms) + syms <- mapM U.findV (map _.name syms) u <- uniqid let base = "Let$" ++ show u name = "let$" ++ show u @@ -1271,8 +1266,7 @@ genExpr rflg rm ex binds = do E.error pos (text "FATAL COMPILER ERROR " <+> text (nicer ex g) <+> text " not bound") - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> U.findV ex.name + sym <- U.findV ex.name result (newBind g sym.typ (JAtom ("UNBOUND." ++ ex.name.base))) Con{pos, name} | Just (SymbolT.D (sym@SymD{cid, flds})) <- g.findit name = @@ -1423,8 +1417,7 @@ genExpr rflg rm ex binds = do | otherwise = result (delayBind bind) -- possibly nested! -- constructors genApp (con@Con {pos, name, typ = Just csigma}) args = do - let unsafeToSymD s = case s of { SymbolT.D x -> x; } - sym <- unsafeToSymD <$> U.findD name + sym <- U.findD name symt <- U.findT sym.name.tynm () ← E.logmsg TRACEG pos ( text "genApp: constructor " <+> text name.base <+> text " :: " @@ -1489,9 +1482,9 @@ genExpr rflg rm ex binds = do any | nargs > ari = etaShrink (nargs - ari) | nargs < ari = etaWrap sigs where nargs = length args - SymbolT.T SymT{newt = true, product = true} + SymT{newt = true, product = true} = genExpr rflg rm (head args) binds - SymbolT.T _ + _ = do -- resolve the contexts, if any ctxs ← mapM (resolveConstraint pos) contexts @@ -1508,8 +1501,7 @@ genExpr rflg rm ex binds = do _ = noGenApp "not yet" con args genApp (vbl@Vbl {pos, name, typ = Just vsigma}) args = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - symv <- unsafeToSymV <$> U.findV name + symv <- U.findV name --vsigma ← (_.{bound=[]} . fst) <$> kiSigma [] [] xsigma --ft ← (_.{bound=[]} . fst) <$> kiSigma [] [] ft let symtyp = rhoTauInSigma symv.typ diff --git a/frege/compiler/passes/Easy.fr b/frege/compiler/passes/Easy.fr index c7bb9d08..7ade97cd 100644 --- a/frege/compiler/passes/Easy.fr +++ b/frege/compiler/passes/Easy.fr @@ -176,8 +176,7 @@ depthSym (vsym@SymV {pos}) depthX x | Let {env} <- x = do g ← getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - syms <- mapSt (fmap unsafeToSymV . U.findV) env + syms <- mapSt U.findV env foreach syms depthSym stio (Left x) | otherwise = stio (Left x) @@ -335,8 +334,7 @@ inlined = U.mapEx true inline Vbl {pos = newpos, name, typ = Just sig} <- fun, not name.isLocal = do g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> U.findV name + sym <- U.findV name case sym.expr of Just dx -- we can't inline any class methods @@ -359,8 +357,7 @@ inlined = U.mapEx true inline inline (vbl@Vbl{pos, name, typ = Just sig}) | not name.isLocal = do g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> U.findV name + sym <- U.findV name case sym.expr of Just dx | MName tname _ <- name, Just (SymbolT.C _) <- g.findit tname = return (Left vbl) @@ -527,8 +524,7 @@ mkEasy (x@App f arg t) = do mkEasy (x@Let{env,ex}) = do -- TODO: handle non-recursive let/case/if g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - mapM (fmap unsafeToSymV . U.findV) env >>= mapM_ easySym + mapM U.findV env >>= mapM_ easySym mkEasy ex >>= pure . x.{ex=} diff --git a/frege/compiler/passes/Fields.fr b/frege/compiler/passes/Fields.fr index b2bcc828..00cdfb62 100644 --- a/frege/compiler/passes/Fields.fr +++ b/frege/compiler/passes/Fields.fr @@ -63,8 +63,8 @@ chgddef (d@DatDcl {pos}) = do -- changeST _.{sub <- _.{toExport <- (exports++)}} stio d.{defs <- (++ newdefs)} where - work :: Global -> Symbol -> ([FunDcl], [SName]) - work g (SymbolT.T (dsym@SymT {env})) = + work :: Global -> SymT Global -> ([FunDcl], [SName]) + work g (dsym@SymT {env}) = let cons = [ sym | SymbolT.D sym <- values env ] fields = (uniqBy (using fst) . sort) [ (f,p) | con <- cons, Field {pos = p, name = Just f} <- con.flds ] in ([ d | (f,p) <- fields, d <- gen g p dsym.name cons f], @@ -73,7 +73,6 @@ chgddef (d@DatDcl {pos}) = do (p.change VARID (s ++ f)).first | (f, p) <- fields, s <- ["chg$", "upd$"]] else []) - work _ _ = error "work: need a SymT" gen :: Global -> Position -> QName -> [SymD Global] -> String -> [FunDcl] gen g fpos tname cons f = let pos = fpos.{first <- Token.{offset <- succ}} diff --git a/frege/compiler/passes/GenCode.fr b/frege/compiler/passes/GenCode.fr index 9cf8f1ba..f61086c3 100644 --- a/frege/compiler/passes/GenCode.fr +++ b/frege/compiler/passes/GenCode.fr @@ -175,7 +175,7 @@ pass = do liftStG ( mapSt U.fundep vars >>= mapSt U.findV . concat . tsort - >>= mapSt (varCode TreeMap.empty)) + >>= mapSt (varCode TreeMap.empty . SymbolT.V)) >>= liftIO . ppDecls g . concat -- generate the class for constants diff --git a/frege/compiler/passes/GlobalLam.fr b/frege/compiler/passes/GlobalLam.fr index 57c25bbd..df89439e 100644 --- a/frege/compiler/passes/GlobalLam.fr +++ b/frege/compiler/passes/GlobalLam.fr @@ -129,8 +129,7 @@ closedLambda (letex@Let{env,ex}) = do -- now we can lift harmless inner la pure (Right result) where inner (env, ex) qn = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> U.findV qn + sym <- U.findV qn case sym.expr of Just def -> do def <- def diff --git a/frege/compiler/passes/LetUnroll.fr b/frege/compiler/passes/LetUnroll.fr index cccaaebb..7320375e 100644 --- a/frege/compiler/passes/LetUnroll.fr +++ b/frege/compiler/passes/LetUnroll.fr @@ -5,7 +5,6 @@ import frege.Prelude hiding(<+>) import frege.data.TreeMap as TM(TreeMap, TreeSet, lookup, insert, keys, values, each, fromKeys, including, contains, union) import frege.data.List as DL(uniq, sort, sortBy, groupBy, partitioned, elemBy) import frege.data.Graph(stronglyConnectedComponents tsort) -import frege.compiler.common.Lens (view) import frege.compiler.enums.Flags import frege.compiler.enums.Visibility import frege.compiler.types.Positions @@ -86,11 +85,10 @@ unrollLet (x@Let {env,ex}) = do changeSym $ SymbolT.V sy.{expr=Just (return x)} mapsub sy = error "mapsub: no var" ex <- unrollExpr ex - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - syms <- mapSt (fmap unsafeToSymV . U.findV) env + syms <- mapSt U.findV env foreach syms mapsub let -- kvs = each env - xdep k = do sym <- unsafeToSymV <$> U.findV k; ldep (k, sym) + xdep k = do sym <- U.findV k; ldep (k, sym) ldep (k, SymV {expr=Nothing}) = stio (k, []) ldep (k, SymV {expr=Just ex}) = do deps <- ex >>= letlocals @@ -141,8 +139,7 @@ unusedLet (x@Let {env,ex}) = do down <- references (map QName.uid env) ex if down == 0 then do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - syms <- mapSt (fmap unsafeToSymV . U.findV) env + syms <- mapSt U.findV env g <- getST foreach syms (\sym -> unless (sym.name.base ~ ´^_´) do @@ -157,8 +154,7 @@ unusedLet x = stio (Left x) --- lift mutual recursive let functions to the top level unLet (x@Let {env,ex}) | length env > 1 = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - vals <- mapSt (fmap unsafeToSymV . U.findV) env + vals <- mapSt U.findV env g <- getST if (any _.anno vals) then unLetMutual g vals x @@ -192,7 +188,7 @@ unLet (x@Let {env,ex}) used <- U.localSyms x inner <- innerSids x let uids = filter (not • (inner `contains`)) (keys used) - mapSt (fmap unsafeToSymV . U.findV) [ Local uid "_" | uid <- uids ] + mapSt U.findV [ Local uid "_" | uid <- uids ] toPass :: StG [SymV Global] -- symbols we must pass to each global val toPass = do @@ -223,8 +219,7 @@ unLet (x@Let {env,ex}) stio gsym.{expr = Just (return ex), typ} unLetName nm = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - symv <- unsafeToSymV <$> U.findV nm + symv <- U.findV nm unLetSym symv unLetMutual g vals x = error "unLetMutual" @@ -232,8 +227,7 @@ unLet (xlet@Let {env=letenv,ex=letex,typ=lettyp}) | [x] <- letenv = do -- let x = ... in ex g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> U.findV x + sym <- U.findV x case sym.gExpr g of Just (Lam {pat,ex,typ}) = do -- let x = \_ -> ... in ex diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index 7f893757..be7a3ca4 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -116,8 +116,7 @@ easyClassMethodSym (sym@SymV{expr = Just dx, typ}) = do App{} -> liftM2 (&&) (goodClassMethod x.fun) (goodClassMethod x.arg) Vbl{name=Local{}} -> return true Vbl{name} -> do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - vsym <- unsafeToSymV <$> U.findV name + vsym <- U.findV name return (vsym.vis != Private) Con{name} -> return true -- constructors always exported Case{} -> do @@ -280,8 +279,7 @@ returnExprKind syms sym (x@Con {pos}) = stio defaultRKind returnExprKind syms sym (x@Ann {ex}) = returnExprKind syms sym ex returnExprKind syms sym (x@Vbl {name}) = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - symv <- unsafeToSymV <$> U.findV name + symv <- U.findV name g <- getST case symv.gExpr g of Nothing -> case symv.name of @@ -302,8 +300,7 @@ returnExprKind syms sym (ex@App a b typ) = do -- app = App a b typ case f of Vbl {name} -> do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - symf <- unsafeToSymV <$> U.findV name + symf <- U.findV name g <- getST let ari = if isJust symf.expr then symf.depth else U.arity $ SymbolT.V symf rwa = defaultRKind.intersection symf.rkind @@ -393,8 +390,7 @@ minRkind a b = (safetc.union tailbit).union wrbits where * The @names@ list gives the names that are mutually dependent on this one. -} returnNames sids nms = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - syms <- mapSt (fmap unsafeToSymV . U.findV) nms + syms <- mapSt U.findV nms let !deps = sids ++ map _.sid syms foreach syms setsafetc foreach syms (returnKind deps) @@ -451,7 +447,7 @@ lambdaStrictness x = stio [] -- not a lambda strictName sids nm = do g <- getST let unsafeToSymV s = case s of { SymbolT.V x -> x; } - v <- unsafeToSymV <$> U.findV nm + v <- U.findV nm when (v.state != StrictChecked) do E.logmsg TRACES v.pos (text ("strictness analysis for " ++ v.nice g)) let ari = U.arity $ SymbolT.V v -- ... based on type @@ -560,7 +556,7 @@ strictReturn notLazy sids x = strictness sids x where them = filter ((`notElem` mine) . view SymbolT.sid) case x of Vbl {name=Local{}} -> do - v <- U.findV x.name + v <- fmap SymbolT.V $ U.findV x.name E.logmsg TRACES (getpos x) (text ("strictness " ++ nice x g ++ " :: " ++ names g [v])) stio (x, if notLazy then [v] else []) Vbl {name} -> do @@ -683,8 +679,8 @@ strictReturn notLazy sids x = strictness sids x where appstr (app@((f,mbt):as)) = do g <- getST v <- case f of - Con {name} -> U.findD name - Vbl {name} -> U.findV name + Con {name} -> fmap SymbolT.D $ U.findD name + Vbl {name} -> fmap SymbolT.V $ U.findV name _ -> E.fatal (getpos f) (text ("Can't handle " ++ nice f g ++ " applications")) let fsym | Local {} <- view SymbolT.name v = [v] | otherwise = [] diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index 7a035e49..bf7dda32 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -144,8 +144,7 @@ inlineCandidates = do rslvd <- mapM (toQ g.thisPack) g.sub.toExport g <- getST when (g.errors == 0) do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - syms <- mapM (fmap unsafeToSymV . U.findV) rslvd + syms <- mapM U.findV rslvd -- for the time being, inlining higher rank functions is not supported foreach syms (\sym -> changeSym $ SymbolT.V sym.{exported=notHigherConstraint sym}) let zs = zip syms g.sub.toExport @@ -472,7 +471,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do foreach d.ctrs (transCon (unsafePartialView SymbolT.typ sym) (MName tname)) foreach d.defs (transdef [] (MName tname)) polymorphicFields tname - U.findT tname >>= newtCheck + U.findT tname >>= newtCheck . SymbolT.T other -> do E.fatal pos (text ("Cannot happen, data " ++ tname.nice g ++ " missing")) where newtCheck (SymbolT.T (symt@SymT{newt=true})) -- this is declared as newtype @@ -492,8 +491,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do pure () newtCheck other = pure () polymorphicFields tname = do - let unsafeToSymT s = case s of { SymbolT.T x -> x; } - symt <- unsafeToSymT <$> U.findT tname + symt <- U.findT tname let cons = [ c | SymbolT.D c <- values symt.env ] fields = [ f | con <- cons, -- from constructors f@Field {name = Just n} <- con.flds, -- take named fields @@ -805,8 +803,7 @@ transPatUnique fname pat = do pat <- transPat fname pat case pat of PVar{pos, uid, var} -> do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> U.findV Local{uid, base=var} + sym <- U.findV Local{uid, base=var} changeSym $ SymbolT.V sym.{state=StrictChecked, strsig = if s == "?" then U else S[]} return PUser{pat, lazy=s=="?"} @@ -948,8 +945,7 @@ transExpr env fname ex = do nenv <- foldM enterlocal [] (annosLast defs) foreach defs (transLetMemberS (nenv++env) fname) ex <- transExpr (nenv++env) fname ex - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - syms <- mapSt (fmap unsafeToSymV . U.findV) nenv + syms <- mapSt U.findV nenv foreach syms checkDefined stio (D.Let {env=nenv, ex, typ=Nothing}) where diff --git a/frege/compiler/tc/Util.fr b/frege/compiler/tc/Util.fr index 6acabde5..271f9d7a 100644 --- a/frege/compiler/tc/Util.fr +++ b/frege/compiler/tc/Util.fr @@ -441,11 +441,10 @@ unified ex tau1 tau2 = do g ← getST E.logmsg TRACET (getpos ex) (text ("unifyj: " ++ nice t1 g ++ " and " ++ nice t2 g)) sym1 <- U.findT t1 - let unsafeNativ (SymbolT.T s) = s.nativ - case unsafeNativ sym1 of + case sym1.nativ of Just c1 -> do sym2 <- U.findT t2 - case unsafeNativ sym2 of + case sym2.nativ of Just c2 -- Don't unify A and B when either one is based on a primitive type -- not even (and foremost) if it's the same one! @@ -697,7 +696,7 @@ contexts ex typ = do Let {env,ex} -> do let ectx = exContext g ex syms <- mapSt U.findV env - subexs <- sequence [ ex | SymbolT.V SymV{expr = Just ex} <- syms ] + subexs <- sequence [ ex | SymV{expr = Just ex} <- syms ] let rctxss = map (exContext g) subexs let rctxs = [ ctx | ctxs <- rctxss, ctx <- ctxs ] -- take only contexts that have at least 1 flexi tv @@ -847,8 +846,7 @@ instanceOf pos qn tau = do case tcon of TCon {name} -> do E.logmsg TRACET pos (text ("tcon is " ++ showtn name)) - let unsafeToSymC (SymbolT.C s) = s - clas <- unsafeToSymC <$> findC qn + clas <- findC qn E.logmsg TRACET pos (text ("class " ++ showtn clas.name ++ " has instances for " ++ joined ", " (map (showtn • fst) clas.insts))) case filter ((name ==) • fst) clas.insts of @@ -856,8 +854,7 @@ instanceOf pos qn tau = do E.error pos (msgdoc (nicer tau g ++ " is not an instance of " ++ nice qn g)) stio [] (_,iname):_ -> do - let unsafeToSymI (SymbolT.I s) = s - inst <- unsafeToSymI <$> findI iname + inst <- findI iname E.logmsg TRACET pos (text ("found instance " ++ nicer inst.typ g)) E.explain pos (text ("there is an instance for " ++ nicer inst.typ g)) rho <- instantiate inst.typ From 7803c9e865a64d840f0af5c2ac0c4118f28e3248 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 12:51:41 +0900 Subject: [PATCH 08/95] Change the return type of patLocal, mkLocal, vSym to SymV --- frege/compiler/Utilities.fr | 8 +++++--- frege/compiler/common/ImpExp.fr | 24 ++++++++++-------------- frege/compiler/common/Trans.fr | 5 ++--- frege/compiler/gen/java/VarCode.fr | 11 ++++------- frege/compiler/passes/Easy.fr | 3 +-- frege/compiler/passes/Enter.fr | 20 ++++++-------------- frege/compiler/passes/Strict.fr | 3 +-- frege/compiler/passes/Transdef.fr | 3 +-- frege/compiler/tc/Patterns.fr | 3 ++- 9 files changed, 32 insertions(+), 48 deletions(-) diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index 93e6ff77..a4677fac 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -288,6 +288,7 @@ pVarLocal p = Local p.uid p.var {-- @patLocal pos name@ creates a local variable symbol from pos and name -} +patLocal :: Position -> Int -> String -> SymV g patLocal pos uid name = vSym pos (Local uid name) @@ -299,10 +300,10 @@ setuid uid = over SymbolT.name QName.{uid} . set SymbolT.sid uid Make a new local symbol from a 'PVar' and enters it in the symbol table. Will fail if argument is not a 'PVar' -} -mkLocal :: Pattern -> StG Symbol +mkLocal :: Pattern -> StG (SymV Global) mkLocal pvar = do let sym = patLocal pvar.pos (abs pvar.uid) pvar.var - enter sym + enter $ SymbolT.V sym stio sym --- make a completely fresh var @@ -326,7 +327,8 @@ replaceLocals syms x = stio (Left x) * and 'Symbol.name' set to standard values. * If the name is a 'Local' one, the 'Symbol.sid' is set to the 'QName.uid' -} -vSym pos name = SymbolT.V $ SymV {pos, +vSym :: Position -> QName -> SymV g +vSym pos name = SymV {pos, sid= if QName.{uid?} name then name.uid else 0, name, vis=Private, doc=Nothing, typ=pSigma, expr=Nothing, nativ=Nothing, diff --git a/frege/compiler/common/ImpExp.fr b/frege/compiler/common/ImpExp.fr index 84778d72..42978d79 100644 --- a/frege/compiler/common/ImpExp.fr +++ b/frege/compiler/common/ImpExp.fr @@ -206,7 +206,7 @@ exprFromA sarray earray exa = case exa.xkind of pat <- dpat ex <- dex pat <- U.pReturn pat -- make sure it has numbers - syms <- mapSt U.mkLocal (patVars pat) + syms <- mapSt (fmap SymbolT.V . U.mkLocal) (patVars pat) mkStrictPVars pat ex <- U.mapEx true (U.replaceLocals syms) ex stio CAlt {pat, ex} @@ -216,25 +216,21 @@ exprFromA sarray earray exa = case exa.xkind of mklet triples body = do syms ← mapSt letbound triples syms `foreach` - \sym -> case sym of - SymbolT.V symv -> - changeSym $ SymbolT.V symv.{expr <- fmap (>>= U.mapEx true (U.replaceLocals syms))} - ex ← xref body >>= U.mapEx true (U.replaceLocals syms) - return Let{env=map (view SymbolT.name) syms, ex, typ=Nothing} + \sym -> changeSym $ SymbolT.V sym.{expr <- fmap (>>= U.mapEx true (U.replaceLocals $ map SymbolT.V syms))} + ex ← xref body >>= U.mapEx true (U.replaceLocals $ map SymbolT.V syms) + return Let{env=map _.name syms, ex, typ=Nothing} letbound (varix, sigix, rhsix) = do pat ← pref varix >>= U.pReturn let pvar = patVars pat case pvar of [p@PVar{}] → do sym ← U.mkLocal p - case sym of - SymbolT.V symv -> do - let bound = symv.{expr = Just (xref rhsix), - typ = if sigix >= 0 - then nSigma sigix - else pSigma} - changeSym $ SymbolT.V bound - return $ SymbolT.V bound + let bound = sym.{expr = Just (xref rhsix), + typ = if sigix >= 0 + then nSigma sigix + else pSigma} + changeSym $ SymbolT.V bound + return bound _ -> do g <- getST Err.fatal (getpos pat) ( diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index 11d90728..4a28ad04 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -431,7 +431,7 @@ etaExpand x = case x.typ of -- all other expressions pos = (getpos x).change VARID var arg = ForAll [] (RhoTau [] farg) res = RhoTau [] fret - sym = unsafeToSymV $ U.patLocal pos uniq var + sym = U.patLocal pos uniq var y = cleanVarType g x app = App y (Vbl {pos, name=sym.name, typ = Just arg}) (Just (ForAll [] res)) pat = PVar {pos=pos, uid=uniq, var} @@ -447,7 +447,7 @@ etaExpand x = case x.typ of -- all other expressions let pos = (getpos x).change VARID name name = "η" ++ show uniq pat = PVar{pos=getpos x, uid=uniq, var=name} - sym = unsafeToSymV $ U.patLocal pos uniq name + sym = U.patLocal pos uniq name iarg = ForAll [] (snd sarg) -- Num t42#a => t42#a -> t42#a y = cleanVarType g x app = App y (Vbl {pos, name=sym.name, typ = Just iarg}) (Just (ForAll [] res)) @@ -476,7 +476,6 @@ etaExpand x = case x.typ of -- all other expressions vtyp = ForAll [b | b ← (unsafePartialView SymbolT.typ sym).bound, not (TM.member b.var subst)] (T.substRho subst (unsafePartialView SymbolT.typ sym).rho) other → error ("etaExpand: variable not found:" ++ nicer name g) cleanVarType g novar = novar - unsafeToSymV s = case s of { SymbolT.V x -> x; } diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index 6a725702..6e888b04 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -1026,8 +1026,7 @@ etaWrap ex sigs binds (rm@Func{gargs}) = do <+> text " as " <+> text (show rm) ) uids ← replicateM n uniqid - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - let syms = [ (unsafeToSymV $ U.patLocal (pos.change VARID ("η" ++ show u)) u "η").{typ=s} + let syms = [ (U.patLocal (pos.change VARID ("η" ++ show u)) u "η").{typ=s} | (u,s) <- zip uids sigs] atoms = map (JAtom . ("η$" ++) . show) uids ctoms = map (JAtom . ("ctx$" ++) . show) uids @@ -1045,7 +1044,7 @@ etaWrap ex sigs binds (rm@Func{gargs}) = do subrm = case drop n gargs of [x] -> lazy x gs -> Func gs - fake = (unsafeToSymV $ U.patLocal (getpos ex) 0 "\\lambda").{depth=a,typ=ft} + fake = (U.patLocal (getpos ex) 0 "\\lambda").{depth=a,typ=ft} mapM_ (SymTab.enter . SymbolT.V) syms call ← compiling (SymbolT.V fake) (genExpr false subrm nex newbinds) let lambda = JCast (boxed rm) JLambda{fargs = cargs ++ fargs, code} @@ -1080,7 +1079,6 @@ etaWrap ex _ binds rm = E.fatal (getpos ex) (text "etaWrap: " wrapHigher ∷ Bool → ExprT → TreeMap Int Binding → [Context] → Sigma → StG Binding wrapHigher rflg ex binds tctxs sigma = do g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } let depth = length tctxs ctxNames = take depth (getCtxs g) ctxLnams = map ("l" ++) ctxNames @@ -1095,7 +1093,7 @@ wrapHigher rflg ex binds tctxs sigma = do (map (JX.invoke [] . JX.xmem "call" . JAtom) ctxLnams) jfunc = sigmaJT g sigma innerjt = lazy (funcResult jfunc) -- rhoJT g sigma.rho.{context = []} - fakesym = (unsafeToSymV $ U.patLocal (getpos ex) 0 "\\rankN").{depth = 0, typ = sigma} + fakesym = (U.patLocal (getpos ex) 0 "\\rankN").{depth = 0, typ = sigma} E.logmsg TRACEG (getpos ex) (text "wrapHigher: " <+> text (nicer ex g) <+/> text " :: " <+> text (nice sigma g) @@ -1702,12 +1700,11 @@ genExpr rflg rm ex binds = do result (newBind g ft (JAtom "cannot(gen,application)")) Lam{} | Func{gargs} ← boxed rm = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } let n = length gargs - 1 us ← map (("arg$" ++) . show) <$> replicateM n uniqid let (_, sigs) = U.returnTypeN n ft.rho args = zip4 (repeat attrFinal) sigs (map lazy (take n gargs)) us - fake = (unsafeToSymV $ U.patLocal (getpos ex) 0 "\\lambda").{depth=n} + fake = (U.patLocal (getpos ex) 0 "\\lambda").{depth=n} grm = lazy $ case drop n gargs of [x] → x ys → Func ys diff --git a/frege/compiler/passes/Easy.fr b/frege/compiler/passes/Easy.fr index 7ade97cd..d2a0023b 100644 --- a/frege/compiler/passes/Easy.fr +++ b/frege/compiler/passes/Easy.fr @@ -247,9 +247,8 @@ mkSimple x = do mkLet :: Expr -> (Expr -> Expr) -> StG Expr mkLet ex f = do uid <- uniqid - let unsafeToSymV s = case s of { SymbolT.V x -> x; } let pos = getpos ex - patsym = unsafeToSymV $ U.patLocal pos uid pat.var + patsym = U.patLocal pos uid pat.var pat = PVar{pos, uid, var="tmp"} var = Vbl{pos, name=sym.name, typ=ex.typ} aex = f var diff --git a/frege/compiler/passes/Enter.fr b/frege/compiler/passes/Enter.fr index 0dbaa8c5..a9322cbc 100644 --- a/frege/compiler/passes/Enter.fr +++ b/frege/compiler/passes/Enter.fr @@ -121,9 +121,7 @@ enter1FunDcl fname (d@FunDcl {positions}) = case funbinding d of Just name -> do let qname = fname name.value foreach positions (register qname) - case vSym (positionOf name) qname of - SymbolT.V symv -> - ST.enter $ SymbolT.V symv.{vis=d.vis, doc=d.doc} + ST.enter $ SymbolT.V (vSym (positionOf name) qname).{vis=d.vis, doc=d.doc} sonst | not (patbinding d), @@ -133,10 +131,8 @@ enter1FunDcl fname (d@FunDcl {positions}) = case funbinding d of Just name <- funbinding d.{lhs=pat, pats=[]} -> do let !qname = fname name.value register qname name - case vSym (positionOf name) qname of - SymbolT.V symv -> - ST.enter $ SymbolT.V symv.{vis=d.vis, doc=d.doc, - strsig = if excl.value == "!" then S[] else U} + ST.enter $ SymbolT.V (vSym (positionOf name) qname).{vis=d.vis, doc=d.doc, + strsig = if excl.value == "!" then S[] else U} | otherwise = do g <- getST E.error (getpos d.lhs) (msgdoc ("Strange declaration: " @@ -154,10 +150,8 @@ enter1NatDcl fname (d@NatDcl {pos}) = do changeST Global.{ sub <- SubSt.{ idKind <- insert (KeyTk pos.first) (Right qname)}} - case vSym pos qname of - SymbolT.V symv -> - ST.enter $ SymbolT.V - symv.{vis=d.vis, doc=d.doc, nativ=Just d.meth, pur=d.isPure} + ST.enter $ SymbolT.V + (vSym pos qname).{vis=d.vis, doc=d.doc, nativ=Just d.meth, pur=d.isPure} enter1AnnDcl :: (String -> QName) -> AnnDcl -> StG () enter1AnnDcl fname (d@AnnDcl {pos}) = do @@ -187,9 +181,7 @@ enter1AnnDcl fname (d@AnnDcl {pos}) = do Just sym -> E.error pos (msgdoc ("cannot annotate " ++ sym.nice g)) Nothing -> do -- either class method or implementation missing. - case vSym d.pos qname of - SymbolT.V symv -> - ST.enter $ SymbolT.V symv.{vis=d.vis, doc=d.doc, anno = true} + ST.enter $ SymbolT.V (vSym d.pos qname).{vis=d.vis, doc=d.doc, anno = true} changeST Global.{ sub <- SubSt.{ idKind <- insert (KeyTk pos.first) (Right qname)}} diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index be7a3ca4..4db46e61 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -446,7 +446,6 @@ lambdaStrictness x = stio [] -- not a lambda strictName sids nm = do g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } v <- U.findV nm when (v.state != StrictChecked) do E.logmsg TRACES v.pos (text ("strictness analysis for " ++ v.nice g)) @@ -493,7 +492,7 @@ strictName sids nm = do eta n x = do let pos = getpos x nums <- sequence (take n (repeat uniqid)) - syms <- mapSt (fmap unsafeToSymV . U.mkLocal) [ PVar{pos=pos,uid,var="$"} | uid <- nums ] + syms <- mapSt U.mkLocal [ PVar{pos=pos,uid,var="$"} | uid <- nums ] let vars = map _.name syms mkapp ex n = nApp ex (Vbl {pos, name=n, typ = Nothing}) -- mklam :: Expr -> Int -> Expr diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index bf7dda32..8e56ecba 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -728,10 +728,9 @@ transPatUnique fname pat = do Vbl{name} | Simple t <- name = do u <- uniqid - let unsafeToSymV s = case s of { SymbolT.V x -> x; } let pos = positionOf t var = t.value - sym = unsafeToSymV $ U.patLocal pos u var + sym = U.patLocal pos u var enter $ SymbolT.V sym when (var != "_") do changeST Global.{sub <- SubSt.{ diff --git a/frege/compiler/tc/Patterns.fr b/frege/compiler/tc/Patterns.fr index 5c0fad4b..aefd5242 100644 --- a/frege/compiler/tc/Patterns.fr +++ b/frege/compiler/tc/Patterns.fr @@ -10,6 +10,7 @@ import Compiler.types.Positions import Compiler.types.Packs import Compiler.types.QNames import Compiler.types.Patterns as P +import Compiler.types.Symbols (SymbolT) import Compiler.types.Expression import Compiler.types.Global as G @@ -55,7 +56,7 @@ replDWIM p = case p of let pvar = PVar{pos, uid, var = "dwim" ++ show uid} xvar = Vbl{pos, name = Local{uid, base="dwim" ++ show uid}, typ = Nothing} xlit = Lit{pos, kind, value, typ=Nothing, negated} - enter (U.patLocal pos uid pvar.var) + enter $ SymbolT.V $ U.patLocal pos uid pvar.var return (PUser{pat = pvar, lazy = false}, [eq `nApp` xlit `nApp` xvar]) else return (p, []) PVar{pos, uid, var} -> return (p, []) From 5a0459a0d4becb61f6a1f41eacf2754ce9594af0 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 13:01:36 +0900 Subject: [PATCH 09/95] Remuve uses of unsafePartialView from frege.compiler.Kinds by tightening the types of parameters --- frege/compiler/Kinds.fr | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/frege/compiler/Kinds.fr b/frege/compiler/Kinds.fr index 6ca3722f..8a44f24c 100644 --- a/frege/compiler/Kinds.fr +++ b/frege/compiler/Kinds.fr @@ -83,18 +83,18 @@ kiTypeGroup qns = do types <- mapM U.findT qns let vartypes = filter (varKind . SymT.kind) types -- with kinds that contain KVar names = map SymT.name vartypes - foreach vartypes (kiTypeSym names . SymbolT.T) + foreach vartypes (kiTypeSym names) -kiTypeSym :: [QName] -> Symbol -> StG () +kiTypeSym :: [QName] -> SymT Global -> StG () kiTypeSym names sym = do g <- getST - E.logmsg TRACEK (view SymbolT.pos sym) (text ("kind check for " ++ nice sym g)) + E.logmsg TRACEK sym.pos (text ("kind check for " ++ nice sym g)) -- kind check all constructor sigmas - let cons = [ con | con@(SymbolT.D _) <- values $ unsafePartialView SymbolT.env sym ] + let cons = [ con | SymbolT.D con <- values $ sym.env ] foreach cons (kiConSym names) g ← getST - sym <- U.findT $ view SymbolT.name sym + sym <- U.findT $ sym.name let kflat (KApp k ks) = k : kflat ks kflat ks = [ks] typ = ForAll (zipWith Tau.{kind=} (sym.typ.bound) (kflat sym.kind)) sym.typ.rho @@ -105,11 +105,12 @@ kiTypeSym names sym = do ) +kiConSym :: [QName] -> SymD Global -> StG () kiConSym names con = do g <- getST - E.logmsg TRACEK (view SymbolT.pos con) (text ("kind check for " ++ nice con g)) - (sigma,_) <- kiSigma names [] (unsafePartialView SymbolT.typ con) - changeSym $ set SymbolT.typ sigma con + E.logmsg TRACEK con.pos (text ("kind check for " ++ nice con g)) + (sigma,_) <- kiSigma names [] con.typ + changeSym $ SymbolT.D con.{typ=sigma} -- kind inference on a 'Sigma' type where something else than 'KType' is expected kiSigmaX :: Sigma -> Kind -> StG (Sigma, Kind) From f83552d3530faae75bebe3e9c2f0b57a497ca463 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 13:17:19 +0900 Subject: [PATCH 10/95] Reduce warnings on frege.tools.doc.Utilities - removed redundant pattern from `sref` - changed the type of `overSig` to take `SymV Global` --- frege/tools/doc/Utilities.fr | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/frege/tools/doc/Utilities.fr b/frege/tools/doc/Utilities.fr index 5f8ff58e..820ef961 100644 --- a/frege/tools/doc/Utilities.fr +++ b/frege/tools/doc/Utilities.fr @@ -136,7 +136,6 @@ badref s = T (A "unknown") (P s) tref tn g = Ref tn (text $ nicer tn g) --- a reference to a symbol sref (SymL {name,alias}) g = Ref alias (text $ nicer name g) -sref sym g = tref sym.name g --- a reference to a function or constructor name fref qn g = Ref qn (text $ nicer qn g) --- makes a single text from a list of texts @@ -271,7 +270,7 @@ docSym g (SymbolT.D SymD{name, doc, typ, vis, op, flds}) = (code title, docit g drho (ForAll _ r) = dRho2 g r [] docSym g (SymbolT.V (sym@SymV{name, typ, doc, nativ, pur, strsig, op, over=(_:_)})) - | sigs <- overSig g (SymbolT.V sym) = (code (title sigs), docit g doc) where + | sigs <- overSig g sym = (code (title sigs), docit g doc) where tpur = if pur then (bold • text $ "pure ") else text "" tnat (Just s) = break :- tpur :- (bold • text $ "native ") :- text s tnat Nothing = text "" @@ -332,7 +331,8 @@ overloadOf g sym = [ SymbolT.V o | otherwise = [] --- Give a list of sigmas and throws clauses of the overloads for this one -overSig g sym = [(o.typ, o.throwing) | q <- (unsafeToSymV sym).over, o <- unsafeToSymV <$> Global.findit g q] +overSig :: Global -> SymV Global -> [(Sigma, [Tau])] +overSig g sym = [(o.typ, o.throwing) | q <- sym.over, o <- unsafeToSymV <$> Global.findit g q] where unsafeToSymV (SymbolT.V x) = x From 8c03d3fb4db49da6de6121e746f4dab75b31cbf7 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 13:18:17 +0900 Subject: [PATCH 11/95] Remove uses of unsafePartialView from frege.compiler.passes.Imp By changing the type of the local function `rbSymT` to return `SymT` --- frege/compiler/passes/Imp.fr | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/frege/compiler/passes/Imp.fr b/frege/compiler/passes/Imp.fr index c419cd68..c1c4d226 100644 --- a/frege/compiler/passes/Imp.fr +++ b/frege/compiler/passes/Imp.fr @@ -47,7 +47,7 @@ import Data.TreeMap as TM(TreeMap, keys, insert, insertWith, each, values, looku import Data.List as DL(sortBy, zipWith4) import Data.Bits(BitSet.BitSet) -import frege.compiler.common.Lens (unsafePartialView, view) +import frege.compiler.common.Lens (view) import Compiler.enums.Flags import Compiler.enums.TokenID(CONID, VARID, defaultInfix, ROP4) @@ -581,8 +581,8 @@ importClassData pos why pack = do enter (rbSymI sym) foreach (enumFromTo 0 (sym.funs.length-1)) (enter • rbSymV sym.funs) foreach (enumFromTo 0 (sym.lnks.length-1)) (enter • rbSymL sym.lnks) - rbSymT :: CT.SymT -> Symbol - rbSymT sym = SymbolT.T $ SymT {sid=0, pos=mkpos sym.offset sym.name.base, + rbSymT :: CT.SymT -> SymT Global + rbSymT sym = SymT {sid=0, pos=mkpos sym.offset sym.name.base, vis = if sym.publik then Public else Protected, doc=strMB sym.doc, name = rebuildQN sym.name, typ = nSigma sym.typ, product = sym.prod, enum = sym.isEnum, @@ -594,12 +594,12 @@ importClassData pos why pack = do rebuildTyp n = do let sym = elemAt fp.symts n let rsym = rbSymT sym - enter rsym + enter $ SymbolT.T rsym foreach (enumFromTo 0 (sym.cons.length-1)) (enter • rbSymD sym.cons) foreach (enumFromTo 0 (sym.funs.length-1)) (enter • rbSymV sym.funs) foreach (enumFromTo 0 (sym.lnks.length-1)) (enter • rbSymL sym.lnks) - case unsafePartialView SymbolT.nativ rsym of - Just nativ -> U.nativeType nativ (view SymbolT.name rsym) + case rsym.nativ of + Just nativ -> U.nativeType nativ rsym.name nothing -> return () From 596b2e0dca8de0d7d5a3c2744f7ccff44d3a7703 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 13:27:07 +0900 Subject: [PATCH 12/95] Reduce uses of partial functions in frege.ide.Utilities --- frege/ide/Utilities.fr | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/frege/ide/Utilities.fr b/frege/ide/Utilities.fr index 514d2d20..7d7415cc 100644 --- a/frege/ide/Utilities.fr +++ b/frege/ide/Utilities.fr @@ -470,7 +470,7 @@ proposeContent !global root !offset !tokens !index = propose conts ∷ Bool → Maybe Symbol → [String] conts parens tsym = case tsym of Just sym -> case cons of - (_:_) -> (map (conText parens . SymbolT.D) . sortBy (comparing _.cid)) cons + (_:_) -> (map (conText parens) . sortBy (comparing _.cid)) cons [] -> if view SymbolT.name sym == TName pPreludeBase "Bool" then ["true", "false"] else ["_"] @@ -479,19 +479,19 @@ proposeContent !global root !offset !tokens !index = propose -- null cons = ["_"] -- otherwise = map conText cons - conText parens sym = enclosed (snd (symProp (base sym) sym)) + conText :: Bool -> SymD Global -> String + conText parens sym = enclosed (snd (symProp (base sym) $ SymbolT.D sym)) where - unsafeToSymD (SymbolT.D x) = x base sym - | view SymbolT.vis sym != Public, - MName{tynm, base} <- view SymbolT.name sym = tynm.base ++ "." ++ base - | otherwise = (view SymbolT.name sym).base + | sym.vis != Public, + MName{tynm, base} <- sym.name = tynm.base ++ "." ++ base + | otherwise = sym.name.base -- put complicated constructor in (), if required enclosed it | parens, - (view SymbolT.name sym).base != ":", -- not list cons - (view SymbolT.name sym).base !~ ´^\(´, -- not tuple - any (isNothing . ConField.name) ((unsafeToSymD sym).flds) = "(" ++ it ++ ")" + sym.name.base != ":", -- not list cons + sym.name.base !~ ´^\(´, -- not tuple + any (isNothing . ConField.name) sym.flds = "(" ++ it ++ ")" | otherwise = it -- Find a proposal for id.member From a4cb12980e0e16136b13928e85d1c48a90ba791d Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 13:31:50 +0900 Subject: [PATCH 13/95] Remove redundant cases in frege.compiler.gen.java.Common --- frege/compiler/gen/java/Common.fr | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/frege/compiler/gen/java/Common.fr b/frege/compiler/gen/java/Common.fr index 0560f720..3d40a6f1 100644 --- a/frege/compiler/gen/java/Common.fr +++ b/frege/compiler/gen/java/Common.fr @@ -249,11 +249,11 @@ tauJT g (TSig sig) = sigmaJT g sig taujtApp g qname rest app - | Just (sym@(SymbolT.T symt)) <- g.findit qname = case symt of + | Just (SymbolT.T symt) <- g.findit qname = case symt of SymT{product=true, kind, newt=true} -> - let sigmas = [ ConField.typ f | sym@(SymbolT.D SymD{flds}) <- values symt.env, f <- flds ] + let sigmas = [ ConField.typ f | SymbolT.D SymD{flds} <- values symt.env, f <- flds ] in case sigmas of - [] -> Prelude.error (nice sym g ++ " has no fields") + [] -> Prelude.error (nice symt g ++ " has no fields") (s:_) -> case (substJT subst . lambdaType . sigmaJT g) s of other → other where @@ -270,13 +270,12 @@ taujtApp g qname rest app | enum = jtEnum | qname.base == "->" = Func args - | otherwise = Ref {jname = symJavaName g sym, gargs = args} + | otherwise = Ref {jname = symJavaName g $ SymbolT.T symt, gargs = args} where restPlusWilds = (map (boxed . tauJT g) rest ++ wilds) args = map fst (zip restPlusWilds symt.typ.bound) subst = fromList (zip symt.typ.vars restPlusWilds) gargs = mapMaybe (subst.lookup . _.var) symt.gargs - other -> undefined -- can not happen because catched in U.findT | otherwise = Prelude.error (nice qname g ++ " not a type") @@ -658,7 +657,6 @@ getArgs g = drop used argNames where used = sum (map unsafeGetDepth g.genEnv) unsafeGetDepth (SymbolT.V SymV{depth}) = depth - --- Compute a list of context names we can use for a new function --- This drops the ones from 'ctxNames' that are currently used in outer scopes. @@ -824,9 +822,9 @@ specialClassNames = ["ListEmpty", "ListMonoid", "ListSemigroup", "ListView", "Li isSpecialClassName TName{pack, base} = pack == pPreludeList && base `elem` specialClassNames isSpecialClassName other = false ---- checks if a 'Symbol' is a special class +--- checks if a 'SymC' is a special class +isSpecialClass :: SymC g -> Bool isSpecialClass SymC{name} = isSpecialClassName name -isSpecialClass other = false --- names of the type classes for arrays arrayClassNames = ["ArrayElement", "PrimitiveArrayElement"] @@ -834,8 +832,8 @@ arrayClassNames = ["ArrayElement", "PrimitiveArrayElement"] isArrayClassName TName{pack, base} = pack == pPreludeArrays && base `elem` arrayClassNames isArrayClassName _ = false +isArrayClass :: SymC g -> Bool isArrayClass SymC{name} = isArrayClassName name -isArrayClass _ = false --- check if a type class is higher kinded isHigherKindedClass :: SymbolT a -> Bool From d9c176b90f5315eb15f588b62f6a00e85189aced Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 13:47:28 +0900 Subject: [PATCH 14/95] Change the return type of envConstructors to [SymD Global] --- frege/compiler/Utilities.fr | 4 ++-- frege/compiler/common/Trans.fr | 10 ++++------ frege/compiler/passes/Instances.fr | 2 +- 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index a4677fac..b9a287ad 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -230,8 +230,8 @@ freeTauTVars _ collected _ = collected --- return a list of constructors in this environment ordered by constructor number -envConstructors :: Symtab -> [Symbol] -envConstructors env = map SymbolT.D $ sortBy (comparing SymD.cid) [ syd | SymbolT.D syd <- values env ] +envConstructors :: Symtab -> [SymD Global] +envConstructors env = sortBy (comparing SymD.cid) [ syd | SymbolT.D syd <- values env ] --- provide a new Position for a Pattern diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index 4a28ad04..39f9021b 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -282,19 +282,19 @@ patsComplete g ps else missingLiteral ps missing (ps@(PLit {pos}:_)) = missingLiteral ps missing (ps@(PCon {qname}:_)) - | s:_ <- filter (not . (`elem` pnames) . view SymbolT.name) (cons qname) = Just (mkCon s) + | s:_ <- filter (not . (`elem` pnames) . _.name) (cons qname) = Just (mkCon s) | otherwise = case (filter isJust • map groupcheck) (group ps) of some:_ -> some [] -> Nothing where pnames = map Pattern.qname ps + cons :: QName -> [SymD Global] cons (MName tname _) = case Global.findit g tname of Just (SymbolT.T (SymT {env})) -> U.envConstructors env _ -> [] cons _ = [] - mkCon (SymbolT.D SymD{name,flds}) = PCon {pos=Position.null, qname=name, + mkCon (SymD{name,flds}) = PCon {pos=Position.null, qname=name, pats = map (const pany) flds} - mkCon _ = error "mkCon: no constructor" group :: [Pattern] -> [(QName, [[Pattern]])] group [] = [] group (PCon {qname,pats}:ps) = (qname, pats:map Pattern.pats same):group other @@ -331,10 +331,8 @@ patsComplete g ps constructors (lit@PLit {kind=LBool}) = [ lit.{value=s} | s <- ["true", "false"] ] constructors (con@PCon {qname=MName tname _}) = case g.findit tname of Just (SymbolT.T (SymT {env})) -> - let unsafeToSymD s = case s of { SymbolT.D x -> x; } - in [ PCon con.pos sym.name (take (length sym.flds) dummies) | - sym <- unsafeToSymD <$> U.envConstructors env ] where + sym <- U.envConstructors env ] where dummies = repeat (PVar con.pos 0 "_") _ -> [] constructors _ = [] diff --git a/frege/compiler/passes/Instances.fr b/frege/compiler/passes/Instances.fr index 3144288d..96dce8a2 100644 --- a/frege/compiler/passes/Instances.fr +++ b/frege/compiler/passes/Instances.fr @@ -62,7 +62,7 @@ deriveInst (d@DrvDcl{pos}) = do clas <- defaultXName pos (TName pPreludeBase "Eq") d.clas typ <- U.transSigma d.typ case instTSym typ g of - Just (sym@(SymbolT.T SymT{env})) | ctrs <- U.envConstructors env, + Just (sym@(SymbolT.T SymT{env})) | ctrs <- map SymbolT.D $ U.envConstructors env, not (null ctrs) || inPrelude clas.pack g && clas.base == "ArrayElement" || inPrelude clas.pack g && clas.base == "JavaType" From d8ce200b2c9bd69a46c13fc12ea6544317cae0bf Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 13:51:08 +0900 Subject: [PATCH 15/95] Remove uses of partial functions in frege.compiler.passes.Instances by tightening the parameter types --- frege/compiler/passes/Instances.fr | 48 +++++++++++++----------------- 1 file changed, 21 insertions(+), 27 deletions(-) diff --git a/frege/compiler/passes/Instances.fr b/frege/compiler/passes/Instances.fr index 96dce8a2..4b1cf955 100644 --- a/frege/compiler/passes/Instances.fr +++ b/frege/compiler/passes/Instances.fr @@ -5,8 +5,6 @@ module frege.compiler.passes.Instances where import Data.List as DL(uniqBy, sort, sortBy) import frege.lib.PP(text, msgdoc) -import frege.compiler.common.Lens (unsafePartialView, view) - -- import Compiler.enums.Flags as Compilerflags(TRACE3, TRACE4) import Compiler.enums.TokenID import Compiler.enums.Visibility @@ -62,7 +60,7 @@ deriveInst (d@DrvDcl{pos}) = do clas <- defaultXName pos (TName pPreludeBase "Eq") d.clas typ <- U.transSigma d.typ case instTSym typ g of - Just (sym@(SymbolT.T SymT{env})) | ctrs <- map SymbolT.D $ U.envConstructors env, + Just (SymbolT.T (sym@SymT{env})) | ctrs <- U.envConstructors env, not (null ctrs) || inPrelude clas.pack g && clas.base == "ArrayElement" || inPrelude clas.pack g && clas.base == "JavaType" @@ -95,19 +93,15 @@ deriveInst (d@DrvDcl{pos}) = do derivable = ["Hashable", "Eq", "Ord", "Enum", "Bounded", "Show", "Exceptional"] --- arity of a constructor -arity ∷ Symbol → Int -arity sym = length (unsafeGetFlds sym) - where - unsafeGetFlds (SymbolT.D SymD{flds}) = flds +arity :: SymD Global -> Int +arity sym = length sym.flds -deriveClass :: Position → QName → Symbol → [Symbol] → RhoT SName -> Global → String → [DefinitionS] -deriveClass pos clas forty ctrs' instrho g toderive = deriveClass toderive +deriveClass :: Position -> QName -> SymT Global -> [SymD Global] -> RhoT SName -> Global -> String -> [DefinitionS] +deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive where - ctrs = flip map ctrs' $ \x -> case x of - SymbolT.D c -> c con = head ctrs isEnum ∷ Bool - isEnum = all (0==) (map (arity . SymbolT.D) ctrs) + isEnum = all (0==) (map arity ctrs) -- displayed name of a constructor cname :: SymD Global -> SName cname sym = case sym.name of @@ -123,7 +117,7 @@ deriveClass pos clas forty ctrs' instrho g toderive = deriveClass toderive conpat con s = Term app -- PCon {qname=cname con, pos=pos.change QCONID con.name.base, pats} where app = fold App Con{name=cname con} pats - pats = take ((arity . SymbolT.D) con) (subpats s) + pats = take (arity con) (subpats s) -- construct simple (pattern) variables var :: String -> ExprS @@ -203,7 +197,7 @@ deriveClass pos clas forty ctrs' instrho g toderive = deriveClass toderive halts = map hashalt ctrs hashalt con = calt p hashex where - a = (arity . SymbolT.D) con + a = arity con p = conpat con "a" vs = take a (subvars "a") c = nApp (gvar "PreludeBase" "constructor") varg1 @@ -228,7 +222,7 @@ deriveClass pos clas forty ctrs' instrho g toderive = deriveClass toderive -- (C,C) -> true, (C1 a1 a2, C1 b1 b2) -> a1 == b1 && a2==b2 mkequalalt con = calt (ptup peq1 peq2) eqex where - a = (arity . SymbolT.D) con + a = arity con peq1 = conpat con "a" peq2 = conpat con "b" sub1 = take a (subvars "a") @@ -242,7 +236,7 @@ deriveClass pos clas forty ctrs' instrho g toderive = deriveClass toderive deriveClass "Ord" | [prod] <- ctrs = [DefinitionS.Fun $ publicfun "<=>" [conpat prod "a", conpat prod "b"] - (ordex ((arity . SymbolT.D) prod) 0)] + (ordex (arity prod) 0)] | otherwise = [DefinitionS.Fun $ publicfun "<=>" [parg1, parg2] outercase] where --* case a1 <=> b1 of { Eq -> case a2 <=> b2 of { ... @@ -260,7 +254,7 @@ deriveClass pos clas forty ctrs' instrho g toderive = deriveClass toderive --* (C ai, C bi) -> ordex ai bi mkeqcase con = calt (ptup peq1 peq2) oex where - a = (arity . SymbolT.D) con + a = arity con peq1 = conpat con "a" -- C a1 a2 .. an peq2 = conpat con "b" -- C b1 b2 .. bn oex = ordex a 0 @@ -274,7 +268,7 @@ deriveClass pos clas forty ctrs' instrho g toderive = deriveClass toderive eqexs = (map mkeqcase ctrs) ++ [default_] default_ = calt (var "_") vEq deriveClass "Show" - | (view SymbolT.name forty).base ~ ´^\(,+\)´ = let -- tuple + | forty.name.base ~ ´^\(,+\)´ = let -- tuple sex = Case CNormal (var "r") [(mktupshowalt con)] show = publicfun "show" [var "r"] sex -- showsub = publicfun "showsub" [] (var "show") @@ -292,7 +286,7 @@ deriveClass pos clas forty ctrs' instrho g toderive = deriveClass toderive mkshowalt con = calt (conpat con "a") sx where scon = string (con.name.base) - sub = take ((arity . SymbolT.D) con) (subvars "a") + sub = take (arity con) (subvars "a") sx = joinit scon sub blanked s = s `mkapp` string " " showit v = gvar "PreludeText" "showsub" `nApp` v @@ -303,11 +297,11 @@ deriveClass pos clas forty ctrs' instrho g toderive = deriveClass toderive let salt = mkshowalt con subx = (string "(" `mkapp` salt.ex) `mkapp` string ")" - in if (arity . SymbolT.D) con == 0 then salt + in if arity con == 0 then salt else salt.{ex=subx} mktupshowalt con = calt (conpat con "a") sx where scon = string "(" - sub = take ((arity . SymbolT.D) con) (subvars "a") + sub = take (arity con) (subvars "a") sx = joinit scon sub showsv s v d = (s `mkapp` showit v) `mkapp` string d joinit s [] = s `mkapp` string ")" @@ -339,7 +333,7 @@ deriveClass pos clas forty ctrs' instrho g toderive = deriveClass toderive sex = Case CNormal (var "r") (mkalts "succ " ctup) pex = Case CNormal (var "r") (mkalts "pred " ctdn) last = calt (var "_") (nApp vError msg) -- _ -> error ... - msg = (string ((view SymbolT.name forty).nice g) + msg = (string (forty.name.nice g) `mkapp` string ".from ") `mkapp` showit (var "r") -- "X" ++ ".from " ++ show r fromalt ctr = calt (int (SymD.cid ctr)) (Con {name=cname ctr}) @@ -366,20 +360,20 @@ deriveClass pos clas forty ctrs' instrho g toderive = deriveClass toderive DefinitionS.Nat $ NatDcl{pos, vis=Public, name="javaClass", txs = [(ForAll [] (RhoTau [] tapp), [])], - meth = fromMaybe (rawName jt) (unsafePartialView SymbolT.nativ forty) ++ ".class", + meth = fromMaybe (rawName jt) forty.nativ ++ ".class", isPure = true, gargs = Nothing, doc = Nothing}] where tapp = TApp pClass this this | RhoTau{tau} <- instrho = tau | otherwise = error ("Cannot derive for non type: " ++ nicer forty g) - jt = sigmaJT g (unsafePartialView SymbolT.typ forty) + jt = sigmaJT g forty.typ deriveClass "JavaType" = deriveClass "Exceptional" deriveClass "ArrayElement" = deriveClass "Exceptional" deriveClass s = error ("can't deriveClass " ++ s) -deriveDcls :: Position -> QName -> Symbol -> [Symbol] -> RhoT SName -> StG [DefinitionS] +deriveDcls :: Position -> QName -> SymT Global -> [SymD Global] -> RhoT SName -> StG [DefinitionS] deriveDcls pos clas forty ctrs instrho = do g <- getST -- E.logmsg TRACE4 pos (text ("derive " ++ QName.nice clas g ++ " for " ++ Symbol.nice forty g)) @@ -389,7 +383,7 @@ deriveDcls pos clas forty ctrs instrho = do ccc `elem` ["Enum", "Bounded"] -> if all (0==) (map arity ctrs) then stio (dC ccc) else do - let bad = [ (view SymbolT.name c).nice g | c <- ctrs, arity c != 0 ] + let bad = [ c.name.nice g | c <- ctrs, arity c != 0 ] E.error pos (msgdoc ("Can't derive " ++ clas.nice g ++ " for " ++ forty.nice g ++ " because " ++ (if length bad == 1 then head bad ++ " is not a nullary constructor" @@ -400,7 +394,7 @@ deriveDcls pos clas forty ctrs instrho = do TName ppp "ArrayElement" | inPrelude ppp g = return (dC "ArrayElement") TName ppp "Exceptional" - | inPrelude ppp g = if isJust (unsafePartialView SymbolT.nativ forty) + | inPrelude ppp g = if isJust forty.nativ then return (dC "Exceptional") else do E.error pos (msgdoc ("Can't derive Exceptional for " ++ forty.nicer g From 6f2e5a4193658a3f0de0f006faf7065986093aa0 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 14:01:59 +0900 Subject: [PATCH 16/95] Remove some of partial functions in frege.compiler.Classes by tightening the types of parameters --- frege/compiler/Classes.fr | 48 +++++++++++++++++++-------------------- 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index 9ddb6dda..1b9d4e41 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -228,8 +228,8 @@ passC = do when (isJust msym.nativ) do T.subsCheck (SymbolT.V msym) msym.typ osym.typ case g.findit osym.name.tynm of - Just (ssym@(SymbolT.C _)) -> do - mkanno (SymbolT.C symc) (SymbolT.V msym) (SymbolT.V osym) ssym + Just (SymbolT.C ssym) -> do + mkanno symc (SymbolT.V msym) osym ssym return () nothing -> E.fatal pos (text ("methodcheck: class " ++ osym.name.tynm.nice g ++ " vanished.")) _ -> E.fatal pos (text (msym.name.nice g ++ " occurs in more than one super class of " ++ symc.name.nice g)) @@ -244,8 +244,8 @@ passC = do [osym] | Just (SymbolT.V ali) <- g.findit msym.alias, ali.anno, -- symc.name == same, - Just (ssym@(SymbolT.C _)) <- g.findit osym.name.tynm = do - sig <- mkanno (SymbolT.C symc) (SymbolT.L msym) (SymbolT.V osym) ssym + Just (SymbolT.C ssym) <- g.findit osym.name.tynm = do + sig <- mkanno symc (SymbolT.L msym) osym ssym T.subsCheck (SymbolT.V ali) ali.typ sig | otherwise = E.error pos (msgdoc (nicer msym g ++ " may only point to a value whose type is known through annotation or import.")) @@ -262,35 +262,35 @@ passC = do * t is the class variable of this class and n is a new name * that replaces accidental occurrences of t in the annotation of the super method -} - mkanno :: Symbol -> Symbol -> Symbol -> Symbol -> StG Sigma - mkanno csym' msym osym ssym' = do + mkanno :: SymC Global -> Symbol -> SymV Global -> SymC Global -> StG Sigma + mkanno csym msym osym ssym = do g <- getST i <- uniqid - let csym = case csym' of { SymbolT.C x -> x; } - ssym = case ssym' of { SymbolT.C x -> x; } let newvar = TVar {pos=view SymbolT.pos msym, var=noClashIdent ("t" ++ show i), kind = KVar} oldvar = ssym.tau.var thsvar = csym.tau.var tree1 = TreeMap.insert empty oldvar csym.tau tree | oldvar != thsvar = tree1.insert thsvar newvar | otherwise = tree1 - case isPSigma (unsafePartialView SymbolT.typ osym) of + case isPSigma osym.typ of false -> do let - rho1 = substRho tree (unsafePartialView SymbolT.typ osym).rho + rho1 = substRho tree osym.typ.rho rep (ctx@Ctx {cname, tau = TVar {var=x}}) | cname == ssym.name, x == thsvar = ctx.{pos=view SymbolT.pos msym, cname=csym.name} rep ctx = ctx rho = rho1.{context <- map rep} repv tv = TM.lookupDefault tv tv.var tree - memtyp = ForAll (map repv (unsafePartialView SymbolT.typ osym).bound) rho - when (isJust $ preview SymbolT.typ msym) $ do - case msym of - SymbolT.V msymv -> - changeSym $ SymbolT.V msymv.{typ = memtyp, anno = true} + memtyp = ForAll (map repv osym.typ.bound) rho + case msym of + SymbolT.V msymv -> + changeSym $ SymbolT.V msymv.{typ = memtyp, anno = true} + SymbolT.L _ -> pure () + -- msym can only be SymT or SymV + -- TODO express this in type return memtyp true -> - E.fatal (view SymbolT.pos osym) (text ("mkanno:: untyped " ++ osym.nice g)) + E.fatal osym.pos (text ("mkanno:: untyped " ++ osym.nice g)) checklink (symm@SymV {name=MName cls base}) = do g <- getST @@ -412,7 +412,7 @@ instForClass alien c iname = do csyms <- mapSt U.findC (csym.name:csym.supers) isym <- U.findI isym.name - when (not alien || g.our isym.name) do tcInstMethods csyms $ SymbolT.I isym + when (not alien || g.our isym.name) do tcInstMethods csyms isym mu -> E.fatal isym.pos (text ("instForClass: bad instance type " ++ isym.typ.nice g)) {-- @@ -705,13 +705,13 @@ implemented (SymbolT.V vsym) = isJust vsym.expr || isJust vsym.nativ {-- check for each method in an instance if the type is more specific than the class type -} -tcInstMethods :: [SymC Global] -> Symbol -> StG () -tcInstMethods supers inst = foreach (values (unsafePartialView SymbolT.env inst)) (tcInstMethod supers inst) +tcInstMethods :: [SymC Global] -> SymI Global -> StG () +tcInstMethods supers inst = foreach (values inst.env) (tcInstMethod supers inst) {-- check if the type of an instance method is more specific than the type of the class method -} -tcInstMethod :: [SymC Global] -> Symbol -> Symbol -> StG () +tcInstMethod :: [SymC Global] -> SymI Global -> Symbol -> StG () tcInstMethod [] isym msym = do g <- getST E.error (view SymbolT.pos msym) (msgdoc (msym.nice g ++ " is not a class member function")) @@ -733,7 +733,7 @@ tcInstMethod (sc:scs) isym msym ++ " class method type: " ++ s.nicer g ++ " own type: " ++ mtnice)) -- forall i. S i => I i ==> S 42 => I 42 - rhotau <- T.instantiate (unsafePartialView SymbolT.typ isym) + rhotau <- T.instantiate isym.typ case tauRho rhotau of RhoTau ctx tau -> do -- must be RhoTau, see Enter -- C c => c a -> c b ==> forall a b.C (I 42) => I 42 a -> I 42 b @@ -771,7 +771,7 @@ tcInstMethod (sc:scs) isym msym case msym of SymbolT.V msymv -> changeSym $ SymbolT.V msymv.{typ = msig, anno = true} _ -> pure () - other -> E.fatal (view SymbolT.pos isym) (msgdoc ("RhoTau expected, got " ++ rhotau.nicer g)) + other -> E.fatal isym.pos (msgdoc ("RhoTau expected, got " ++ rhotau.nicer g)) Just (SymbolT.V (symv@SymV {typ=sig})) | isPSigma sig -> do E.fatal symv.pos (text (symv.nice g ++ " of " ++ sc.nice g ++ " is not annotated")) -- Some class has a default method that links somewhere else @@ -784,10 +784,10 @@ tcInstMethod (sc:scs) isym msym isSymL (SymbolT.L _) = true isSymL _ = false -tcInstMethod (sc:scs) isym (msym@SymbolT.V (SymV{pos, typ=s})) | not (isPSigma s) = do +tcInstMethod _ _ (msym@SymbolT.V (SymV{pos, typ=s})) | not (isPSigma s) = do g <- getST E.fatal pos (text ("tcInstMethod: " ++ msym.nice g ++ " annotated with " ++ s.nicer g)) -tcInstMethod (sc:scs) isym msym = do +tcInstMethod _ _ msym = do g <- getST E.fatal (view SymbolT.pos msym) (text ("tcInstMethod: strange symbol " ++ msym.nice g)) From efac3c0c3c44a2eca88911959c22dd1cfd934268 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 14:17:40 +0900 Subject: [PATCH 17/95] Remove a dead case in frege.compiler.gen.java.InstanceCode --- frege/compiler/gen/java/InstanceCode.fr | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index 8a7ebae0..40f9e45f 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -174,17 +174,6 @@ abstractFun symc sym = do body = JEmpty} pure [JComment ((nicer sym g) ++ " :: " ++ nicer sym.typ g), result] -abstractFun symc symx = do - g ← getST - E.fatal symx.pos ( - text "abstractFun: argument is " - <+> text (nice symx g) - <+> text " for " - <+> text (nice symc g) - ) - - - {-- Code for instances From 727656c26a47bbda2c48184669a68fa1202ac17e Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 14:18:13 +0900 Subject: [PATCH 18/95] Remove a dead case in frege.compiler.gen.java.DataCode --- frege/compiler/gen/java/DataCode.fr | 1 - 1 file changed, 1 deletion(-) diff --git a/frege/compiler/gen/java/DataCode.fr b/frege/compiler/gen/java/DataCode.fr index 101f760f..d5ef241d 100644 --- a/frege/compiler/gen/java/DataCode.fr +++ b/frege/compiler/gen/java/DataCode.fr @@ -306,7 +306,6 @@ conDecls sym = do body = JBlock [JReturn JCast{jt=ttype, jex=JAtom single.name}]} members = zipWith mkMember namedfields constrargs return decls -conDecls _ = error "no SymD" --- generate --- >final public int constructor() { return n; } From 9caad72bb008e4ec6654fb524a898fd5e6c6783c Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 14:22:35 +0900 Subject: [PATCH 19/95] Remove some partial functions and dead cases in frege.c.g.j.VarCode --- frege/compiler/gen/java/VarCode.fr | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index 6e888b04..2e2ae131 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -862,7 +862,7 @@ genLet jret rm x binds = do after = concat . reverse . takeWhile (not . needClassForLet) . reverse $ envxx -- the remaining elements must be in a class incls = concat (take (length envxx - length after) envxx) - genLetEnvs jret rm (map SymbolT.V before) (map SymbolT.V incls) (map SymbolT.V after) letex binds + genLetEnvs jret rm before incls after letex binds where toSym = mapM U.findV (letex, envqq) = collect x [] @@ -871,12 +871,8 @@ genLet jret rm x binds = do collect (x@Let {env,ex}) acc = collect ex (env:acc) collect x acc = (x, acc) -genLetEnvs ∷ (JExpr→[JStmt]) → JType → [Symbol] → [Symbol] → [Symbol] → ExprT → TreeMap Int Binding → StG [JStmt] -genLetEnvs jret rm before' inclass' after' ex binds = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - let before = map unsafeToSymV before' - inclass = map unsafeToSymV inclass' - after = map unsafeToSymV after' +genLetEnvs :: (JExpr -> [JStmt]) -> JType -> [SymV Global] -> [SymV Global] -> [SymV Global] -> ExprT -> TreeMap Int Binding -> StG [JStmt] +genLetEnvs jret rm before inclass after ex binds = do g ← getST let bbinds = fold (mkbind g JAtom) binds before bdecls ← map (map JLocal) <$> mapM (gen false bbinds) before @@ -1272,6 +1268,7 @@ genExpr rflg rm ex binds = do then etaWrap (snd (U.returnType ft.rho)) else if case g.findit name.tynm of Just (SymbolT.T symt) -> symt.enum + -- symt must be SymT Nothing -> false then do let item = symJavaName g (SymbolT.D sym) @@ -1496,7 +1493,6 @@ genExpr rflg rm ex binds = do call = JInvoke make arguments bind = (newBind g ft call).{jtype = retjt} appResult true bind - _ = noGenApp "not yet" con args genApp (vbl@Vbl {pos, name, typ = Just vsigma}) args = do symv <- U.findV name @@ -1689,7 +1685,6 @@ genExpr rflg rm ex binds = do (JInvoke stref arguments) call = call0.{jtype = retjt} appResult safetc call - _ → noGenApp "unknown SymV" vbl args genApp bad args = noGenApp "no Con or Vbl" bad args noGenApp why bad args = do E.error (getpos ex) (text "Cannot genApp" From 81e25948c1af088f03ba853fd0a39095019168ef Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 14:25:44 +0900 Subject: [PATCH 20/95] Remove partial functions in frege.compiler.gen.java.Match by tightening the parameters --- frege/compiler/gen/java/Match.fr | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/frege/compiler/gen/java/Match.fr b/frege/compiler/gen/java/Match.fr index 056066f7..f7584db9 100644 --- a/frege/compiler/gen/java/Match.fr +++ b/frege/compiler/gen/java/Match.fr @@ -13,7 +13,7 @@ import frege.Prelude hiding(apply, <+>) import Data.TreeMap as TM(TreeMap, values, keys, each, insert, lookup) import Data.List as DL(sortBy, partitioned) -import frege.compiler.common.Lens (unsafePartialView, view) +import frege.compiler.common.Lens (view) import Compiler.enums.Literals @@ -170,9 +170,9 @@ match assert (pat@PCon {pos,qname,pats}) bind cont binds = do if symt.enum then matchEnum (SymbolT.D symd) (SymbolT.T symt) else if symt.product then if symt.newt - then matchNew (SymbolT.D symd) (SymbolT.T symt) - else matchProd (SymbolT.D symd) (SymbolT.T symt) -- pat bind cont binds - else matchVariant (SymbolT.D symd) (SymbolT.T symt) -- pat bind cont binds + then matchNew symd symt + else matchProd symd symt -- pat bind cont binds + else matchVariant symd symt -- pat bind cont binds where unKindedStrict g lbnd = case strictBind g lbnd of kbnd -> case kbnd.jtype of @@ -192,12 +192,12 @@ match assert (pat@PCon {pos,qname,pats}) bind cont binds = do ifc = if assert then JAssert comp : body else [JCond "if" comp body] stio (sbnd, comment g : ifc) - matchNew :: Symbol -> Symbol -> StG (Binding, [JStmt]) + matchNew :: SymD Global -> SymT Global -> StG (Binding, [JStmt]) matchNew symd symt = do g <- getST let -- box0 = adaptSigma g bind - arg = (unsafePartialView SymbolT.typ symd).rho.sigma -- first arg of data con - tree = unifySigma g (unsafePartialView SymbolT.typ symt) bind.ftype -- instantiate type args a -> Int + arg = symd.typ.rho.sigma -- first arg of data con + tree = unifySigma g symt.typ bind.ftype -- instantiate type args a -> Int sig = substSigma tree arg -- substitute in arg E.logmsg TRACEG (getpos pat) ( text "matchNew:" <+> text (nicer pat g) PP.nest 4 ( @@ -210,9 +210,8 @@ match assert (pat@PCon {pos,qname,pats}) bind cont binds = do let box1 = (newBind g sig bind.jex).{jtype = bind.jtype} match assert (head pats) box1 cont binds - matchVariant :: Symbol -> Symbol -> StG (Binding, [JStmt]) - matchVariant symd' (SymbolT.T symt) = do - let symd = case symd' of { SymbolT.D x -> x; } + matchVariant :: SymD Global -> SymT Global -> StG (Binding, [JStmt]) + matchVariant symd symt = do g <- getST E.logmsg TRACEG (getpos pat) (text "match pattern " <+> text (nicer pat g) @@ -267,7 +266,7 @@ match assert (pat@PCon {pos,qname,pats}) bind cont binds = do stio (boxd, (comment g : code1) ++ code2 ++ ifn) - matchProd :: Symbol -> Symbol -> StG (Binding, [JStmt]) + matchProd :: SymD Global -> SymT Global -> StG (Binding, [JStmt]) matchProd symd symt = matchVariant symd symt -- for the time being From 56e7ac8e78991c486ed65fe84ab926503119cd16 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 14:40:17 +0900 Subject: [PATCH 21/95] Change the return type of allourvars and allvars to [SymV Global] allvars was changed from monadic value to a plain function because it doesn't change nay state. Some functions in other modules had their parameters tightened. --- frege/compiler/Typecheck.fr | 8 +++----- frege/compiler/Utilities.fr | 11 +++++------ frege/compiler/passes/Easy.fr | 5 ++--- frege/compiler/passes/GlobalLam.fr | 6 +----- frege/compiler/passes/LetUnroll.fr | 9 +++------ frege/compiler/passes/Strict.fr | 2 +- frege/ide/Utilities.fr | 4 ++-- 7 files changed, 17 insertions(+), 28 deletions(-) diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index ccff00bd..84420529 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -132,7 +132,8 @@ memberTree = do where b = (view SymbolT.name sy).base stio mems -fundep mtree (SymbolT.V (SymV{name, expr=Just dx})) = do +fundep :: TreeMap String [Symbol] -> SymV Global -> StG (QName, [QName]) +fundep mtree SymV{name, expr=Just dx} = do g <- getST deptree <- dx >>= U.ourGlobalFuns mtree let needed sy = @@ -142,10 +143,7 @@ fundep mtree (SymbolT.V (SymV{name, expr=Just dx})) = do _ -> true dep = [ view SymbolT.name sy | sy <- keys deptree, g.ourSym sy, needed sy ] stio (name, dep) -fundep mtree (SymbolT.V (SymV{name, expr=Nothing})) = stio (name, []) -fundep mtree other = do - g <- getST - E.fatal (view SymbolT.pos other) (text ("fundep: strange symbol: " ++ other.nice g)) +fundep mtree SymV{name, expr=Nothing} = stio (name, []) --- collect all variable symbols and their dependencies diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index b9a287ad..cf1096d7 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -954,20 +954,19 @@ fundep other = do --- find all our 'SymV' symbols -allourvars :: Global -> [Symbol] +allourvars :: Global -> [SymV Global] allourvars g = let collectedenvs = g.thisTab : mapMaybe (preview SymbolT.env) (values g.thisTab) - in [ v | env <- collectedenvs, v@(SymbolT.V SymV{name}) <- values env, g.our name] + in [ v | env <- collectedenvs, SymbolT.V v <- values env, g.our v.name ] --- find all 'SymV' symbols, be they ours or not -allvars = do - g <- getST +allvars :: Global -> [SymV Global] +allvars g = let envEnvs env = env : mapMaybe (preview SymbolT.env) (values g.thisTab) packEnvs = values g.packages collectedenvs = fold (++) [] (map envEnvs packEnvs) - collectedvars = [ v | env::Symtab <- collectedenvs, v@(SymbolT.V _) <- values env] - stio collectedvars + in [ v | env::Symtab <- collectedenvs, SymbolT.V v <- values env ] {-- diff --git a/frege/compiler/passes/Easy.fr b/frege/compiler/passes/Easy.fr index d2a0023b..90b917e8 100644 --- a/frege/compiler/passes/Easy.fr +++ b/frege/compiler/passes/Easy.fr @@ -62,10 +62,9 @@ import frege.compiler.common.Trans -} pass = do g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } -- set lambdadepth for each symbol let collectedvars = allourvars g - foreach collectedvars (depthSym . unsafeToSymV) + foreach collectedvars depthSym -- check instance member's depth g <- getST @@ -76,7 +75,7 @@ pass = do -- make all expressions easy g <- getST let collectedvars = allourvars g - foreach collectedvars (easySym . unsafeToSymV) + foreach collectedvars easySym stio ("expressions", length collectedvars) diff --git a/frege/compiler/passes/GlobalLam.fr b/frege/compiler/passes/GlobalLam.fr index df89439e..5044b35a 100644 --- a/frege/compiler/passes/GlobalLam.fr +++ b/frege/compiler/passes/GlobalLam.fr @@ -2,7 +2,6 @@ module frege.compiler.passes.GlobalLam where -- generated by Splitter import frege.Prelude hiding(<+>) -import frege.compiler.common.Lens (view) import frege.compiler.enums.Flags import frege.compiler.types.Positions import frege.compiler.types.QNames @@ -38,14 +37,11 @@ singleLetSym sym = do E.fatal sym.pos ("unrollSym no SymV : " ++ sym.nice g) -} -closedLambdaSym (SymbolT.V vsym) +closedLambdaSym vsym | Just x <- vsym.expr = do nx <- x >>= U.mapExBody true closedLambda changeSym $ SymbolT.V vsym.{expr = Just (return nx)} | otherwise = stio () -closedLambdaSym sym = do - g <- getST - E.fatal (view SymbolT.pos sym) (text ("closedLambdaSym no SymV : " ++ sym.nice g)) diff --git a/frege/compiler/passes/LetUnroll.fr b/frege/compiler/passes/LetUnroll.fr index 7320375e..1d3de40e 100644 --- a/frege/compiler/passes/LetUnroll.fr +++ b/frege/compiler/passes/LetUnroll.fr @@ -29,23 +29,20 @@ import frege.compiler.common.PatternCompiler pass = do g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - let allourvars' g = map unsafeToSymV (allourvars g) - -- unroll let expressions - let collectedvars = allourvars' g + let collectedvars = allourvars g foreach collectedvars unrollSym -- simplify let expressions by lifting local function bindings to the top -- or inlining variables g <- getST - let collectedvars = allourvars' g + let collectedvars = allourvars g foreach collectedvars unLetSym -- make multi-equation definitions ready for type check g <- getST let collectedvars = allourvars g - foreach collectedvars ccSym + foreach collectedvars (ccSym . SymbolT.V) stio ("symbols", 3 * length collectedvars) diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index 4db46e61..235e27a3 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -43,7 +43,7 @@ import frege.compiler.common.Trans pass = do g <- getST let ourvars = allourvars g - names <- mapSt U.fundep ourvars + names <- mapSt (U.fundep . SymbolT.V) ourvars let groups = tsort names diff --git a/frege/ide/Utilities.fr b/frege/ide/Utilities.fr index 7d7415cc..a5a19ffd 100644 --- a/frege/ide/Utilities.fr +++ b/frege/ide/Utilities.fr @@ -233,7 +233,7 @@ proposeContent !global root !offset !tokens !index = propose traceLn("before ¦" ++ show after) || true, Token{tokid=VARID, value} ← after, (sym:_) ← [ SymbolT.V s | - SymbolT.V (s@SymV{expr=Just _}) <- U.allourvars global ++ values global.locals, + SymbolT.V (s@SymV{expr=Just _}) <- (map SymbolT.V $ U.allourvars global) ++ values global.locals, s.name.base == value, -- not s.anno, s.pos.first.offset == offset], traceLn("rule anno ¦" ++ value) || true @@ -552,7 +552,7 @@ proposeContent !global root !offset !tokens !index = propose symoffset = Token.offset . Position.first . view SymbolT.pos (befores, afters) = DL.partitioned (( Date: Sat, 19 Oct 2019 14:44:28 +0900 Subject: [PATCH 22/95] Change fundep to take SymV --- frege/compiler/Utilities.fr | 8 +++----- frege/compiler/passes/GenCode.fr | 2 +- frege/compiler/passes/Strict.fr | 5 ++--- 3 files changed, 6 insertions(+), 9 deletions(-) diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index cf1096d7..2be46ba3 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -941,16 +941,14 @@ symVD f g sym = case sym of * [usage] @fundep expr@ * [returns] a list of our 'QName's that are directly mentioned in _ex_ -} -fundep (SymbolT.V SymV{name, expr=Just dx}) = do +fundep :: SymV Global -> StG (QName, [QName]) +fundep (SymV{name, expr=Just dx}) = do g <- getST x <- dx deptree <- ourGlobalFuns empty x let dep = [ name | sy <- keys deptree, let name = view SymbolT.name sy, g.our name ] stio (name, dep) -fundep (SymbolT.V SymV{name, expr=Nothing}) = stio (name, []) -fundep other = do - g <- getST - E.fatal (view SymbolT.pos other) (text("fundep: strange symbol: " ++ other.nice g)) +fundep (SymV{name, expr=Nothing}) = stio (name, []) --- find all our 'SymV' symbols diff --git a/frege/compiler/passes/GenCode.fr b/frege/compiler/passes/GenCode.fr index f61086c3..96e4982f 100644 --- a/frege/compiler/passes/GenCode.fr +++ b/frege/compiler/passes/GenCode.fr @@ -171,7 +171,7 @@ pass = do -- do variables in dependency order, this is so that CAFs refer only to CAFs -- whose java initialization occurs earlier - let vars = [ s | s@(SymbolT.V _) <- values g.thisTab ] + let vars = [ s | SymbolT.V s <- values g.thisTab ] liftStG ( mapSt U.fundep vars >>= mapSt U.findV . concat . tsort diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index 235e27a3..e6e893e7 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -43,7 +43,7 @@ import frege.compiler.common.Trans pass = do g <- getST let ourvars = allourvars g - names <- mapSt (U.fundep . SymbolT.V) ourvars + names <- mapSt U.fundep ourvars let groups = tsort names @@ -175,7 +175,7 @@ returnKind syms (sym@SymV {expr = Just dx, depth = 0}) = do self <- references [sym.sid] x -- is it self-referential? rec <- references syms x -- is it recursive g <- getST - (_, deps) <- U.fundep $ SymbolT.V sym + (_, deps) <- U.fundep sym let local = sym.name.isLocal -- is this a local item? sx = simpleCAF g local x let fwrefs @@ -517,7 +517,6 @@ strictName sids nm = do ++ show strsig)) changeSym $ SymbolT.V v.{strsig, state = StrictChecked} stio [] - other -> E.fatal other.pos (text ("strictness: strange symbol " ++ other.nice g)) {-- From f0b8d1c8b94898f6ff9d70374b6ba4ebcb93eb19 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 14:52:03 +0900 Subject: [PATCH 23/95] Change ccSym to take SymV --- frege/compiler/common/PatternCompiler.fr | 7 ++----- frege/compiler/passes/LetUnroll.fr | 2 +- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/frege/compiler/common/PatternCompiler.fr b/frege/compiler/common/PatternCompiler.fr index 692829d0..510b686d 100644 --- a/frege/compiler/common/PatternCompiler.fr +++ b/frege/compiler/common/PatternCompiler.fr @@ -49,15 +49,12 @@ import Compiler.Utilities as U(freshVar) - -ccSym (SymbolT.V (vsym@SymV {pos})) +ccSym :: SymV Global -> StG () +ccSym vsym | Just x ← vsym.expr = do nx ← x >>= ccExpr changeSym $ SymbolT.V vsym.{expr = Just (return nx)} | otherwise = pure () -ccSym sym = do - g <- getST - E.fatal (view SymbolT.pos sym) (text ("ccSym no SymV : " ++ sym.nice g)) diff --git a/frege/compiler/passes/LetUnroll.fr b/frege/compiler/passes/LetUnroll.fr index 1d3de40e..ff6421ab 100644 --- a/frege/compiler/passes/LetUnroll.fr +++ b/frege/compiler/passes/LetUnroll.fr @@ -42,7 +42,7 @@ pass = do -- make multi-equation definitions ready for type check g <- getST let collectedvars = allourvars g - foreach collectedvars (ccSym . SymbolT.V) + foreach collectedvars ccSym stio ("symbols", 3 * length collectedvars) From 8bef123c77aca3d7766f0d29a2ea2c6a82a91118 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 14:58:57 +0900 Subject: [PATCH 24/95] Change the type of Global.locals to TreeMap Int (SymV Global) --- frege/compiler/common/SymbolTable.fr | 30 ++++++++++++++-------------- frege/compiler/types/Global.fr | 4 ++-- frege/ide/Utilities.fr | 16 +++++++-------- 3 files changed, 25 insertions(+), 25 deletions(-) diff --git a/frege/compiler/common/SymbolTable.fr b/frege/compiler/common/SymbolTable.fr index 560959c9..6d090fed 100644 --- a/frege/compiler/common/SymbolTable.fr +++ b/frege/compiler/common/SymbolTable.fr @@ -96,19 +96,18 @@ enter sym = case sym of Local{uid} -> do g <- getST uid <- if uid > 0 then return uid else uniqid + let symv = case sym of { SymbolT.V x -> x; } case g.find name of Nothing - | uid == view SymbolT.sid sym -> do - E.logmsg TRACE3 (view SymbolT.pos sym) (text("enterLocal: " ++ - case sym of - SymbolT.V symv -> - show symv.sid ++ - " " ++ sym.nice g ++ " :: " ++ symv.typ.nice g ++ - ", " ++ show symv.state)) - changeST Global.{locals <- TreeMap.insertkvI uid sym} - | otherwise = E.fatal (view SymbolT.pos sym) (text ("enterLocal: uid=" ++ - show uid ++ ", sid=" ++ show (view SymbolT.sid sym) ++ " for " ++ show name)) - Just that -> E.error (view SymbolT.pos sym) (text ("already entered: " ++ nice sym g ++ " with uid " ++ show uid)) + | uid == symv.sid-> do + E.logmsg TRACE3 symv.pos (text("enterLocal: " ++ + show symv.sid ++ + " " ++ sym.nice g ++ " :: " ++ symv.typ.nice g ++ + ", " ++ show symv.state)) + changeST Global.{locals <- TreeMap.insertkvI uid symv} + | otherwise = E.fatal symv.pos (text ("enterLocal: uid=" ++ + show uid ++ ", sid=" ++ show symv.sid ++ " for " ++ show name)) + Just that -> E.error symv.pos (text ("already entered: " ++ nice symv g ++ " with uid " ++ show uid)) _ -> do g <- getST case g.find name of @@ -150,10 +149,11 @@ changeSym sym = do Nothing -> E.fatal (view SymbolT.pos sym) (text "no environment:" <+> text (t.nice g)) Local uid s -> do -- g <- getST - when (view SymbolT.sid sym != uid) do - E.fatal (view SymbolT.pos sym) (text("changeSym: name =" ++ show name - ++ ", sid=" ++ show (view SymbolT.sid sym))) - changeST Global.{locals <- TreeMap.updatekvI uid sym} + let symv = case sym of { SymbolT.V x -> x; } + when (symv.sid != uid) do + E.fatal symv.pos (text("changeSym: name =" ++ show name + ++ ", sid=" ++ show symv.sid)) + changeST Global.{locals <- TreeMap.updatekvI uid symv} private enterByName :: Symbol -> StG () diff --git a/frege/compiler/types/Global.fr b/frege/compiler/types/Global.fr index 1f3214c8..523703aa 100644 --- a/frege/compiler/types/Global.fr +++ b/frege/compiler/types/Global.fr @@ -137,7 +137,7 @@ data Global = !Global { namespaces :: TreeMap NSName Pack --- map namespaces to packages javaEnv :: TreeMap String ([String],[QName]) --- names of supertypes and types that implement a certain java type genEnv :: [Symbol] --- symbols of function that is being compiled - locals :: TreeMap Int Symbol --- local ids identified by name + locals :: TreeMap Int (SymV Global) --- local ids identified by name typEnv :: [QName] --- names of functions being type checked tySubst :: TreeMap Int Tau --- substitutions for type variables } where @@ -202,7 +202,7 @@ data Global = !Global { --- find the 'Symbol' for a 'QName', which may be a 'SymL' (symbolic link) find :: Global -> QName -> Maybe Symbol - find g (this@Local{uid}) = g.locals.lookupI uid + find g (this@Local{uid}) = fmap SymbolT.V $ g.locals.lookupI uid find g (this@TName p s) = case g.packages.lookup p of Just env -> env.lookupS this.key Nothing -> Nothing diff --git a/frege/ide/Utilities.fr b/frege/ide/Utilities.fr index a5a19ffd..c4aa2733 100644 --- a/frege/ide/Utilities.fr +++ b/frege/ide/Utilities.fr @@ -233,7 +233,7 @@ proposeContent !global root !offset !tokens !index = propose traceLn("before ¦" ++ show after) || true, Token{tokid=VARID, value} ← after, (sym:_) ← [ SymbolT.V s | - SymbolT.V (s@SymV{expr=Just _}) <- (map SymbolT.V $ U.allourvars global) ++ values global.locals, + s@SymV{expr=Just _} <- U.allourvars global ++ values global.locals, s.name.base == value, -- not s.anno, s.pos.first.offset == offset], traceLn("rule anno ¦" ++ value) || true @@ -531,16 +531,16 @@ proposeContent !global root !offset !tokens !index = propose -- Then, find the local symbols that are between them and make proposals for them localProposal :: Proposal -> [Proposal] localProposal model - = [ model.{proposal = label global sym, - newText = (view SymbolT.name sym).base} | - sym <- DL.uniqueBy (using (QName.base . view SymbolT.name)) [ sym | + = [ model.{proposal = label global (SymbolT.V sym), + newText = sym.name.base} | + sym <- DL.uniqueBy (using (QName.base . _.name)) [ sym | sym <- values global.locals, offBefore = maybe 0 symoffset before, offAfter = maybe 999999999 symoffset after, - symoffset sym > offBefore, - symoffset sym < offAfter, - (view SymbolT.name sym).base != "_", - (view SymbolT.name sym).base.startsWith model.prefix ] + symoffset (SymbolT.V sym) > offBefore, + symoffset (SymbolT.V sym) < offAfter, + sym.name.base != "_", + sym.name.base.startsWith model.prefix ] ] where before = if null befores From 7809062ec09f711cd71542559abffebbeb8968cc Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 15:36:22 +0900 Subject: [PATCH 25/95] Remove some partial functions in frege.compiler.passes.Transdef --- frege/compiler/passes/Transdef.fr | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index 8e56ecba..9bd385df 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -443,12 +443,12 @@ transInsDcl env fname (d@InsDcl {pos}) = do nothing -> do E.fatal pos (text ("Cannot happen, instance " ++ iname.nice g ++ " missing")) -private refreshTypeDatDcl :: DatDcl -> Symbol -> StG Symbol +private refreshTypeDatDcl :: DatDcl -> SymT Global -> StG (SymT Global) private refreshTypeDatDcl DatDcl{name, pos, vars} = refreshType name pos vars -private refreshTypeJavDcl :: JavDcl -> Symbol -> StG Symbol +private refreshTypeJavDcl :: JavDcl -> SymT Global -> StG (SymT Global) private refreshTypeJavDcl JavDcl{name, pos, vars} = refreshType name pos vars -private refreshType :: String -> Position -> [TauS] -> Symbol -> StG Symbol +private refreshType :: String -> Position -> [TauS] -> SymT Global -> StG (SymT Global) private refreshType name pos vars sym = do g ← getST vars <- mapM (\t -> transTau t >>= forceTau) vars @@ -457,8 +457,8 @@ private refreshType name pos vars sym = do dtau = dtcon.mkapp vars :: Tau !dsig = ForAll vars (RhoTau [] dtau) !kind = foldr KApp KType dsig.kinds :: Kind - newsym = set SymbolT.typ dsig $ set SymbolT.kind kind $ sym - changeSym newsym + newsym = sym.{typ=dsig, kind} + changeSym $ SymbolT.T newsym pure newsym transDatDcl :: [QName] -> (String -> QName) -> DatDcl -> StG () @@ -466,9 +466,9 @@ transDatDcl env fname (d@DatDcl {pos}) = do g <- getST let tname = TName g.thisPack d.name case g.findit tname of - Just sym | SymbolT.T _ <- sym = do - sym ← refreshTypeDatDcl d sym - foreach d.ctrs (transCon (unsafePartialView SymbolT.typ sym) (MName tname)) + Just sym | SymbolT.T symt <- sym = do + sym <- refreshTypeDatDcl d symt + foreach d.ctrs (transCon sym.typ (MName tname)) foreach d.defs (transdef [] (MName tname)) polymorphicFields tname U.findT tname >>= newtCheck . SymbolT.T @@ -623,10 +623,9 @@ transJavDcl env fname (d@JavDcl {pos}) = do let tname = TName g.thisPack d.name case g.findit tname of Just sym - | SymbolT.T SymT{nativ = Just nativ} <- sym = do + | SymbolT.T (symt@SymT{nativ = Just nativ}) <- sym = do -- Redo types - let unsafeToSymT s = case s of { SymbolT.T x -> x; } - sym <- unsafeToSymT <$> refreshTypeJavDcl d sym + sym <- refreshTypeJavDcl d symt -- extract and translate generic type arguments let doit (Just gs) = mapM transTau gs >>= mapM forceTau doit Nothing = pure sym.typ.tvars @@ -671,7 +670,7 @@ transClaDcl env fname (d@ClaDcl {pos}) = do ++ tname.nice g ++ " missing.")) -- stio Nothing Just sym - | SymbolT.C _ <- sym = do transclass d sym -- ; stio (Just d) + | SymbolT.C symc <- sym = transclass d symc | otherwise = do E.fatal pos (text ("expected class, found " ++ sym.nice g)) @@ -1168,9 +1167,8 @@ assoc t | otherwise = error ("no precedence for operator: " ++ show t) -transclass :: ClaDcl -> Symbol -> StG () -transclass def sym' = do - let sym = case sym' of { SymbolT.C x -> x; } +transclass :: ClaDcl -> SymC Global -> StG () +transclass def sym = do supers <- liftM (map unJust • filter isJust) (mapSt (resolveXName def.pos $ SymbolT.C sym) def.supers) changeSym $ SymbolT.C sym.{supers = unique supers} From daf9a49e1e68b17bf968cb59040196f090e3a3e7 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 15:42:09 +0900 Subject: [PATCH 26/95] Add instance Ord for SymT, SymL, etc. --- frege/compiler/types/Symbols.fr | 43 ++++++++++++++++++++++++++++++--- 1 file changed, 40 insertions(+), 3 deletions(-) diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 2fbaf5d7..99a6b7d3 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -212,12 +212,49 @@ data SymbolT global = vis f (V s) = (\vis -> V s.{vis}) <$> f s.vis vis f (A s) = (\vis -> A s.{vis}) <$> f s.vis + +instance Ord (SymT g) where + sym1 <=> sym2 = SymbolT.T sym1 <=> SymbolT.T sym2 + sym1 == sym2 = SymbolT.T sym1 == SymbolT.T sym2 + sym1 != sym2 = SymbolT.T sym1 != SymbolT.T sym2 + hashCode = hashCode . SymbolT.T +instance Ord (SymL g) where + sym1 <=> sym2 = SymbolT.L sym1 <=> SymbolT.L sym2 + sym1 == sym2 = SymbolT.L sym1 == SymbolT.L sym2 + sym1 != sym2 = SymbolT.L sym1 != SymbolT.L sym2 + hashCode = hashCode . SymbolT.L +instance Ord (SymD g) where + sym1 <=> sym2 = SymbolT.D sym1 <=> SymbolT.D sym2 + sym1 == sym2 = SymbolT.D sym1 == SymbolT.D sym2 + sym1 != sym2 = SymbolT.D sym1 != SymbolT.D sym2 + hashCode = hashCode . SymbolT.D +instance Ord (SymC g) where + sym1 <=> sym2 = SymbolT.C sym1 <=> SymbolT.C sym2 + sym1 == sym2 = SymbolT.C sym1 == SymbolT.C sym2 + sym1 != sym2 = SymbolT.C sym1 != SymbolT.C sym2 + hashCode = hashCode . SymbolT.C +instance Ord (SymI g) where + sym1 <=> sym2 = SymbolT.I sym1 <=> SymbolT.I sym2 + sym1 == sym2 = SymbolT.I sym1 == SymbolT.I sym2 + sym1 != sym2 = SymbolT.I sym1 != SymbolT.I sym2 + hashCode = hashCode . SymbolT.I +instance Ord (SymV g) where + sym1 <=> sym2 = SymbolT.V sym1 <=> SymbolT.V sym2 + sym1 == sym2 = SymbolT.V sym1 == SymbolT.V sym2 + sym1 != sym2 = SymbolT.V sym1 != SymbolT.V sym2 + hashCode = hashCode . SymbolT.V +instance Ord (SymA g) where + sym1 <=> sym2 = SymbolT.A sym1 <=> SymbolT.A sym2 + sym1 == sym2 = SymbolT.A sym1 == SymbolT.A sym2 + sym1 != sym2 = SymbolT.A sym1 != SymbolT.A sym2 + hashCode = hashCode . SymbolT.A + --- Symbols ordered by the 'Symbol.sid' field, which is a unique number. --- This allows us to have sets of symbols. instance Ord (SymbolT g) where - sym1 <=> sym2 = (view SymbolT.sid sym1). <=> (view SymbolT.sid sym2) - sym1 == sym2 = (view SymbolT.sid sym1). == (view SymbolT.sid sym2) - sym1 != sym2 = (view SymbolT.sid sym1). != (view SymbolT.sid sym2) + sym1 <=> sym2 = view SymbolT.sid sym1 <=> view SymbolT.sid sym2 + sym1 == sym2 = view SymbolT.sid sym1 == view SymbolT.sid sym2 + sym1 != sym2 = view SymbolT.sid sym1 != view SymbolT.sid sym2 From a316f7a95c007fd318af87ac056001ff51fd5063 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 15:43:30 +0900 Subject: [PATCH 27/95] Remove dead cases and partial functions from f.c.passes.LetUnroll --- frege/compiler/passes/LetUnroll.fr | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/frege/compiler/passes/LetUnroll.fr b/frege/compiler/passes/LetUnroll.fr index ff6421ab..134444dd 100644 --- a/frege/compiler/passes/LetUnroll.fr +++ b/frege/compiler/passes/LetUnroll.fr @@ -47,24 +47,20 @@ pass = do stio ("symbols", 3 * length collectedvars) -unrollSym (vsym@SymV {pos}) +unrollSym :: SymV Global -> StG () +unrollSym vsym | Just x <- vsym.expr = do nx <- x >>= unrollExpr changeSym $ SymbolT.V vsym.{expr = Just (return nx)} | otherwise = stio () -- do nothing -unrollSym sym = do - g <- getST - E.fatal sym.pos (text ("unrollSym no SymV : " ++ sym.nice g)) -unLetSym (vsym@SymV {pos}) +unLetSym :: SymV Global -> StG () +unLetSym vsym | Just x <- vsym.expr = do nx <- x >>= unLetExpr changeSym $ SymbolT.V vsym.{expr = Just (return nx)} | otherwise = stio () -- do nothing -unLetSym sym = do - g <- getST - E.fatal sym.pos (text ("unLetSym no SymV : " ++ sym.nice g)) unrollExpr = U.mapEx true unrollLet @@ -175,8 +171,6 @@ unLet (x@Let {env,ex}) where pos = getpos x - unsafeToSymV s = case s of { SymbolT.V x -> x; } - exprs :: [Expr] exprs = map (unJust . flip SymV.gExpr g) vals @@ -190,7 +184,7 @@ unLet (x@Let {env,ex}) toPass :: StG [SymV Global] -- symbols we must pass to each global val toPass = do exsyms <- mapSt freeSym exprs - stio $ (map unsafeToSymV . uniq . sort) [ SymbolT.V s | ss <- exsyms, s <- ss, SymbolT.V s `notElem` map SymbolT.V vals ] + stio $ (uniq . sort) [ s | ss <- exsyms, s <- ss, s `notElem` vals ] globalize :: SymV Global -> StG (SymV Global) globalize sym = do From 2c7fad558c40881c938aaa1b49c099e5258e8524 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 15:56:04 +0900 Subject: [PATCH 28/95] Remove some partial functions and dead cases in frege.compiler.Typecheck --- frege/compiler/Typecheck.fr | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index 84420529..a560acb3 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -273,7 +273,7 @@ checkgroup7 nms = do g <- getST E.logmsg TRACEZ Position.null (text ("typechecking group: " ++ joined " " (map (flip QName.nice g) nms))) unless (null g.typEnv) do - mapSt findV nms >>= mapM_ (renameSigma . SymbolT.V) + mapSt findV nms >>= mapM_ renameSigma -- we set up typEnv with the names of the group members so that 'envTvs' will find them changeST Global.{typEnv <- (nms ++)} @@ -306,8 +306,7 @@ checkgroup7 nms = do E.explain sym.pos (text (sym.nice g ++ " :: " ++ sig.nicer g)) typeSanity nm = do sym <- findV nm - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym <- unsafeToSymV <$> checkKind (SymbolT.V sym) + sym <- checkKind sym checkAmbiguous (SymbolT.V sym) sym.typ checkReturn (SymbolT.V sym) sym.typ case sym.name of @@ -340,10 +339,9 @@ checkgroup7 nms = do return (Left it) removeCtx x = return (Left x) -checkKind ∷ Symbol → StG Symbol -checkKind sym = fmap SymbolT.V $ correctK empty $ unsafeToSymV sym +checkKind :: SymV Global -> StG (SymV Global) +checkKind = correctK empty where - unsafeToSymV s = case s of { SymbolT.V x -> x; } correctK :: TreeMap String Tau -> SymV Global -> StG (SymV Global) correctK subst (sym@SymV{typ,expr}) = do sig ← bool @@ -515,8 +513,8 @@ substInst (lit@Lit{pos, kind, value, typ=Just (ForAll [] rho)}) not (null rho.context) = pure (Right lit.{typ=Just (ForAll [] rho.{context=[]})}) substInst x = stio (Left x) -renameSigma ∷ Symbol -> StG () -renameSigma sym' | sym.name.isLocal && sym.anno = do +renameSigma :: SymV Global -> StG () +renameSigma sym | sym.name.isLocal && sym.anno = do g ← getST outer <- mapSt findV g.typEnv let avoid = \c → c `elem` concatMap (Sigma.vars . _.typ) outer @@ -530,9 +528,6 @@ renameSigma sym' | sym.name.isLocal && sym.anno = do text "because of (potential) type variable naming conflicts.") changeSym $ SymbolT.V newsym pure () - where - unsafeToSymV s = case s of { SymbolT.V x -> x; } - sym = unsafeToSymV sym' renameSigma other = pure () @@ -612,12 +607,10 @@ checkName nm = do quantifyOne nms = do g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } sym <- U.findV (head nms) lsyms <- mapSt U.findV g.typEnv let rec = [ sym.typ | sym <- lsyms - , sym <- unsafeToSymV <$> g.follow (SymbolT.V sym) -- follow aliases , sym.state == Recursive] when (false && null sym.typ.rho.context && not (TH.isFun sym.typ g) && null rec) do quantifyWith (quantifiedExcept sym.sid) nms @@ -678,7 +671,6 @@ zonkRigid bound ex = do return (Just (return x)) Nothing -> return Nothing changeSym $ SymbolT.V symv.{expr, typ = ForAll sig.bound rho} - symWork _ = error "symWork: not a variable" zonk (x@Let {env,ex,typ = Just sigm}) = do let sig = substRigidSigma bound sigm From 81a68d278ef5dac51b6c6941483250af0eb49cb6 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 16:00:33 +0900 Subject: [PATCH 29/95] Remove partial functions in frege.compiler.GenMeta --- frege/compiler/GenMeta.fr | 42 +++++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/frege/compiler/GenMeta.fr b/frege/compiler/GenMeta.fr index 33f05b85..cac6605b 100644 --- a/frege/compiler/GenMeta.fr +++ b/frege/compiler/GenMeta.fr @@ -141,17 +141,17 @@ genmeta = do -- let ops = [ mkOp (s,x) | (s,x) <- each g.optab, x >= LOP0 ] - let asyms = [sym | sym@(SymbolT.A SymA{vis}) <- values g.thisTab, vis!=Private] + let asyms = [sym | SymbolT.A sym <- values g.thisTab, sym.vis!=Private] symas <- liftStG $ mapSt annoSymA asyms - let csyms = [sym | sym@(SymbolT.C SymC{vis}) <- values g.thisTab, vis!=Private] + let csyms = [sym | SymbolT.C sym <- values g.thisTab, sym.vis!=Private] symcs <- liftStG $ mapSt annoSymC csyms - let isyms = [sym | sym@(SymbolT.I SymI{vis}) <- values g.thisTab, vis!=Private] + let isyms = [sym | SymbolT.I sym <- values g.thisTab, sym.vis!=Private] symis <- liftStG $ mapSt annoSymI isyms - let tsyms = [sym | sym@(SymbolT.T SymT{vis}) <- values g.thisTab, vis!=Private] + let tsyms = [sym | SymbolT.T sym <- values g.thisTab, sym.vis!=Private] symts <- liftStG $ mapSt annoSymT tsyms symvs <- liftStG $ envValues g.thisTab @@ -202,7 +202,7 @@ genmeta = do --- create annotations for all SymV in an environment envValues :: Symtab -> StG [DOCUMENT] envValues env = do - let vsyms = [sym | sym@(SymbolT.V SymV{vis}) <- values env, vis != Private] + let vsyms = [sym | SymbolT.V sym <- values env, sym.vis != Private] symvs <- mapSt annoSymV vsyms stio symvs @@ -210,13 +210,13 @@ envValues env = do envLinks :: Symtab -> StG [DOCUMENT] envLinks env = do g <- getST - let syms = [ sym | sym@(SymbolT.L SymL{vis}) <- values env, vis != Private] + let syms = [ sym | SymbolT.L sym <- values env, sym.vis != Private] mapM annoSymL syms --- create annotations for all SymD in an environment envCons :: Symtab -> StG [DOCUMENT] envCons env = do - let syms = [sym | sym@(SymbolT.D _) <- values env] + let syms = [sym | SymbolT.D sym <- values env] mapSt annoSymD syms @@ -503,9 +503,9 @@ eaIndex expa = do changeST Global.{gen <- GenSt.{xunique <- (1+)} • GenSt.{xTree <- insert expa g.xunique}} stio g.xunique -annoSymA syma' = do +annoSymA :: SymA Global -> StG DOCUMENT +annoSymA syma = do g ← getST - let syma = case syma' of { SymbolT.A x -> x; } vars <- mapSt tauIndex syma.vars typ <- sigIndex syma.typ kind <- kindIndex syma.kind @@ -520,9 +520,9 @@ annoSymA syma' = do ] stio a -annoSymV symv' = do +annoSymV :: SymV Global -> StG DOCUMENT +annoSymV symv = do g <- getST - let symv = case symv' of { SymbolT.V x -> x; } gargs ← mapM tauIndex symv.gargs case isPSigma symv.typ of true -> E.fatal symv.pos (text (symv.nice g ++ " has no type.")) @@ -582,9 +582,9 @@ annoSymV symv' = do changeST Global.{gen <- _.{expSym <- insert symv.name exp}} stio a -annoSymL sym' = do +annoSymL :: SymL Global -> StG DOCUMENT +annoSymL sym = do g ← getST - let sym = case sym' of { SymbolT.L x -> x; } pure $ meta g "SymL" [ ("offset", anno sym.pos.first.offset), ("name", annoG g sym.name), @@ -592,9 +592,9 @@ annoSymL sym' = do ("publik", if sym.vis == Public then PP.nil else anno false), ] -annoSymD sym' = do +annoSymD :: SymD Global -> StG DOCUMENT +annoSymD sym = do g <- getST - let sym = case sym' of { SymbolT.D x -> x; } typ <- sigIndex sym.typ fields <- mapSt conFieldA sym.flds let a = meta g "SymD" [ @@ -626,9 +626,9 @@ instance AnnoG ConFieldA where ] -annoSymC sym' = do +annoSymC :: SymC Global -> StG DOCUMENT +annoSymC sym = do g ← getST - let sym = case sym' of { SymbolT.C x -> x; } tau <- tauIndex sym.tau meml <- envLinks sym.env memv <- envValues sym.env @@ -645,9 +645,9 @@ annoSymC sym' = do ("doc", maybe PP.nil anno sym.doc)] stio a -annoSymI sym' = do +annoSymI :: SymI Global -> StG DOCUMENT +annoSymI sym = do g ← getST - let sym = case sym' of { SymbolT.I x -> x; } typ <- sigIndex sym.typ meml <- envLinks sym.env memv <- envValues sym.env @@ -661,8 +661,8 @@ annoSymI sym' = do ("doc", maybe PP.nil anno sym.doc)] stio a -annoSymT :: Symbol -> StG DOCUMENT -annoSymT (SymbolT.T sym) = do +annoSymT :: SymT Global -> StG DOCUMENT +annoSymT sym = do g ← getST typ <- sigIndex sym.typ memc <- envCons sym.env From d1cbfc0277efac894987c70c31b8921080ff3524 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 19 Oct 2019 13:01:04 +0900 Subject: [PATCH 30/95] Remove unused imports --- frege/compiler/Javatypes.fr | 2 -- frege/compiler/common/ImpExp.fr | 2 -- frege/compiler/common/PatternCompiler.fr | 2 -- 3 files changed, 6 deletions(-) diff --git a/frege/compiler/Javatypes.fr b/frege/compiler/Javatypes.fr index 97000438..5cde1f4b 100644 --- a/frege/compiler/Javatypes.fr +++ b/frege/compiler/Javatypes.fr @@ -44,8 +44,6 @@ package frege.compiler.Javatypes where import frege.compiler.Utilities as U() import frege.lib.PP (text) -import frege.compiler.common.Lens (view) - import Compiler.types.Symbols(SymbolT) import Compiler.types.Positions(Position) import Compiler.types.Global as G diff --git a/frege/compiler/common/ImpExp.fr b/frege/compiler/common/ImpExp.fr index 42978d79..12012a8c 100644 --- a/frege/compiler/common/ImpExp.fr +++ b/frege/compiler/common/ImpExp.fr @@ -34,8 +34,6 @@ module frege.compiler.common.ImpExp inline (maybeQN, ctContext, ctTau, ctSigma) where -import frege.compiler.common.Lens (view) - import Compiler.types.External as E import Compiler.Classtools as CT() import Compiler.types.Expression diff --git a/frege/compiler/common/PatternCompiler.fr b/frege/compiler/common/PatternCompiler.fr index 510b686d..2d552b71 100644 --- a/frege/compiler/common/PatternCompiler.fr +++ b/frege/compiler/common/PatternCompiler.fr @@ -24,8 +24,6 @@ module frege.compiler.common.PatternCompiler where import frege.Prelude hiding (<+>) -import frege.compiler.common.Lens (view) - import Compiler.enums.Flags(TRACE7, STRICTLRPATS) import Compiler.enums.CaseKind import Compiler.enums.Literals From 03611c127428c7f7d1a682db30c723fcf243f70b Mon Sep 17 00:00:00 2001 From: matil019 Date: Mon, 21 Oct 2019 11:09:44 +0900 Subject: [PATCH 31/95] Assume main is SymV in frege.compiler.passes.GenCode --- frege/compiler/passes/GenCode.fr | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/frege/compiler/passes/GenCode.fr b/frege/compiler/passes/GenCode.fr index 96e4982f..af24db43 100644 --- a/frege/compiler/passes/GenCode.fr +++ b/frege/compiler/passes/GenCode.fr @@ -106,8 +106,6 @@ import Lib.PP(pretty) import Data.TreeMap(TreeMap, values) import Data.Graph (stronglyConnectedComponents tsort) -import frege.compiler.common.Lens (view) - import Compiler.Utilities as U() import Compiler.types.Global @@ -248,8 +246,8 @@ ppDecls g decls = do > if ret then System.exit(0) else System.exit(1); or System.exit(ret&255); or empty > } -} -mainCode ∷ Global → Symbol → [String] -mainCode g sym' = [ +mainCode :: Global -> SymV Global -> [String] +mainCode g sym = [ " public static void main(final java.lang.String[] argv) {", " try {", " frege.run.RunTM.argv = argv;", @@ -271,8 +269,7 @@ mainCode g sym' = [ " }" ] where - sym = case sym' of { SymbolT.V x -> x; } - shutdown = "frege.run.Concurrent.shutDownIfExists"; + shutdown = "frege.run.Concurrent.shutDownIfExists" name = (symJavaName g $ SymbolT.V sym).base jtype = tauJT g (fst (U.returnType sym.typ.rho)) isInt @@ -290,7 +287,7 @@ mainCode g sym' = [ list = if strict then stol else lazy stol --- tell if there is a main function in this module --- haveMain :: Global -> Bool +haveMain :: Global -> Maybe (SymV Global) haveMain g = case Global.findit g (VName g.thisPack "main") of - Just sym | (view SymbolT.name sym).pack == g.thisPack = Just sym - other = Nothing \ No newline at end of file + Just (SymbolT.V sym) | sym.name.pack == g.thisPack -> Just sym + _ -> Nothing From 4777ba65dcaefe917c3504e0725e60f1f9d17eaa Mon Sep 17 00:00:00 2001 From: matil019 Date: Mon, 21 Oct 2019 15:57:22 +0900 Subject: [PATCH 32/95] [prototype] Make insertSym and updateSym polymorphic --- frege/compiler/common/SymbolTable.fr | 32 ++++++++++++++-------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/frege/compiler/common/SymbolTable.fr b/frege/compiler/common/SymbolTable.fr index 6d090fed..5ba8506e 100644 --- a/frege/compiler/common/SymbolTable.fr +++ b/frege/compiler/common/SymbolTable.fr @@ -20,10 +20,10 @@ import frege.compiler.common.Annotate(lit) import frege.compiler.common.Errors as E() import frege.compiler.instances.Nicer -private insertGlobal p n s = enterWith insertSym p n s +private insertGlobal p n s = enterWith (insertSym id) p n s -private updateGlobal p n s = enterWith updateSym p n s +private updateGlobal p n s = enterWith (updateSym id) p n s private enterWith insupd p n s = do @@ -39,30 +39,30 @@ private enterWith insupd p n s = do {-- insert symbol, but make sure it does not exist yet -} -private insertSym :: Symtab -> String -> Symbol -> StG Symtab -private insertSym tab key value = case tab.lookupS key of +private insertSym :: (sym -> Symbol) -> TreeMap String sym -> String -> sym -> StG (TreeMap String sym) +private insertSym toSymbol tab key value = case tab.lookupS key of Nothing -> stio (tab.insertS key value) Just old -> do g <- getST - let on = Symbol.nice old g - qn = Symbol.nice value g - case value of + let on = (toSymbol old).nice g + qn = (toSymbol value).nice g + case toSymbol value of SymbolT.V SymV{pos, name} -> E.error pos (msgdoc("duplicate function or pattern binding for `" ++ name.nice g ++ "`, already bound on line " - ++ show (view SymbolT.pos old))) - _ -> E.error (view SymbolT.pos value) (msgdoc("redefinition of " ++ on ++ " with " ++ qn - ++ " introduced on line " ++ show (view SymbolT.pos old))) + ++ show (view SymbolT.pos (toSymbol old)))) + _ -> E.error (view SymbolT.pos (toSymbol value)) (msgdoc("redefinition of " ++ on ++ " with " ++ qn + ++ " introduced on line " ++ show (view SymbolT.pos (toSymbol old)))) stio (tab.insertS key value) {-- update symbol, but make sure it does already exist -} -private updateSym :: Symtab -> String -> Symbol -> StG Symtab -private updateSym tab key value = case tab.lookupS key of +private updateSym :: (sym -> Symbol) -> TreeMap String sym -> String -> sym -> StG (TreeMap String sym) +private updateSym toSymbol tab key value = case tab.lookupS key of Just _ -> stio (tab.insert key value) Nothing -> do g <- getST - let qn = Symbol.nice value g - E.error (view SymbolT.pos value) (fill (break ("cannot update " ++ qn ++ " " ++ show (keys tab)))) + let qn = (toSymbol value).nice g + E.error (view SymbolT.pos (toSymbol value)) (fill (break ("cannot update " ++ qn ++ " " ++ show (keys tab)))) stio (tab.insert key value) @@ -144,7 +144,7 @@ changeSym sym = do E.error (view SymbolT.pos sym) (fill ([text "namespace", text "`" <> text qn <> text "`"] ++ break "does not exist")) Just typ -> case preview SymbolT.env typ of Just typEnv -> do - env <- updateSym typEnv name.key sym + env <- updateSym id typEnv name.key sym updateGlobal t.pack t.key (set SymbolT.env env typ) Nothing -> E.fatal (view SymbolT.pos sym) (text "no environment:" <+> text (t.nice g)) Local uid s -> do @@ -180,7 +180,7 @@ private enterByName sym = do E.error pos (msgdoc("namespace `" ++ qn ++ "` does not exist")) Just typ -> case preview SymbolT.env typ of Just typEnv -> do - env <- insertSym typEnv name.key sym + env <- insertSym id typEnv name.key sym updateGlobal t.pack t.key (set SymbolT.env env typ) Nothing -> E.fatal pos (msgdoc ("no environment: " ++ t.nice g)) Local {} -> do From e0d5f1ed1d374fc62ffa256934e141cb2521053c Mon Sep 17 00:00:00 2001 From: matil019 Date: Tue, 22 Oct 2019 22:14:28 +0900 Subject: [PATCH 33/95] Add Prism Ported from Haskell's profunctors and lens --- frege/compiler/common/Lens.fr | 86 ++++++++++++++++++++++++++++++++++- 1 file changed, 85 insertions(+), 1 deletion(-) diff --git a/frege/compiler/common/Lens.fr b/frege/compiler/common/Lens.fr index a46aeac9..ae387558 100644 --- a/frege/compiler/common/Lens.fr +++ b/frege/compiler/common/Lens.fr @@ -1,12 +1,43 @@ +--- The code here is taken and modified from Haskell's "profunctors" and "lens" packages. +--- +--- profunctors: +--- Copyright 2011-2015 Edward Kmett +--- License BSD-3-Clause +--- +--- lens: +--- Copyright 2012-2016 Edward Kmett +--- License BSD-2-Clause module frege.compiler.common.Lens where import frege.data.Monoid (First) +import frege.data.wrapper.Boolean (All, Any) import frege.data.wrapper.Const (Const) import frege.data.wrapper.Identity (Identity) +class Profunctor p where + dimap :: (a -> b) -> (c -> d) -> p b c -> p a d + lmap :: (a -> b) -> p b c -> p a c + rmap :: (b -> c) -> p a b -> p a c + +instance Profunctor (->) where + dimap ab cd bc = cd . bc . ab + lmap = flip (.) + rmap = (.) + +class Profunctor p => Choice p where + left' :: p a b -> p (Either a c) (Either b c) + right' :: p a b -> p (Either c a) (Either c b) + +instance Choice (->) where + left' ab (Left a) = Left (ab a) + left' _ (Right c) = Right c + right' = fmap + -- note: currently the compiler fails to infer the correct kinds of @f@ -- when incrementally compiling, so you have to write type annotations without the aliases +type APrism s t a b = Market a b a (Identity b) -> Market a b s (Identity t) +type APrism' s a = APrism s s a a type ASetter s t a b = (a -> Identity b) -> s -> Identity t type ASetter' s a = ASetter s s a a type Getting r s a = (a -> Const r a) -> s -> Const r s @@ -14,9 +45,35 @@ type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t type Lens' s a = Lens s s a a type LensLike f s t a b = (a -> f b) -> s -> f t type LensLike' f s a = LensLike f s s a a +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) +type Prism' s a = Prism s s a a type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t type Traversal' s a = Traversal s s a a +data Market a b s t = Market (b -> t) (s -> Either t a) + +instance Functor (Market a b s) where + fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) + +instance Profunctor (Market a b) where + dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f) + lmap f (Market bt seta) = Market bt (seta . f) + rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) + +instance Choice (Market a b) where + left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of + Left s -> case seta s of + Left t -> Left (Left t) + Right a -> Right a + Right c -> Left (Right c) + right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of + Left c -> Left (Left c) + Right s -> case seta s of + Left t -> Left (Right t) + Right a -> Right a + +type Market' a = Market a a + -- getters -- dealing with Lenses @@ -29,8 +86,35 @@ views l f = Const.get . l (Const . f) -- dealing with optional fields (Traversals) +has :: Getting Any s a -> s -> Bool +has l = Any.unwrap . views l (\_ -> Any True) + +hasn't :: Getting All s a -> s -> Bool +hasn't l = All.unwrap . views l (\_ -> All False) + preview :: Getting (First a) s a -> s -> Maybe a -preview l s = First.getFirst $ views l (First . Just) s +preview l = First.getFirst . views l (First . Just) + +-- dealing with prisms + +prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b +prism bt seta = dimap seta (either pure (fmap bt)) . right' + +prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b +prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s)) + +withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r +withPrism k f = case k (Market Identity Right) of + Market bt seta -> f (Identity.run . bt) (either (Left . Identity.run) Right . seta) + +is :: APrism s t a b -> s -> Bool +is k = not . isn't k + +isn't :: APrism s t a b -> s -> Bool +isn't k s = either (\_ -> True) (\_ -> False) (matching k s) + +matching :: APrism s t a b -> s -> Either t a +matching k = withPrism k $ \_ seta -> seta -- setters From f95bcb3c5051c53778c76a6cc3d617f45ae5653c Mon Sep 17 00:00:00 2001 From: matil019 Date: Tue, 22 Oct 2019 22:38:03 +0900 Subject: [PATCH 34/95] Add prisms for SymbolT Ad-hoc isSym? functions were replaced with the prisms. --- frege/compiler/Classes.fr | 4 +--- frege/compiler/common/Resolve.fr | 4 +--- frege/compiler/gen/java/DataCode.fr | 4 +--- frege/compiler/passes/Enter.fr | 4 +--- frege/compiler/passes/Imp.fr | 4 +--- frege/compiler/types/Symbols.fr | 25 ++++++++++++++++++++++++- frege/ide/Utilities.fr | 4 +--- frege/tools/Doc.fr | 8 ++------ 8 files changed, 32 insertions(+), 25 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index 1b9d4e41..a7e734d6 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -717,7 +717,7 @@ tcInstMethod [] isym msym = do E.error (view SymbolT.pos msym) (msgdoc (msym.nice g ++ " is not a class member function")) tcInstMethod (sc:scs) isym msym - | hasTyp msym || isSymL msym = do + | hasTyp msym || Lens.is SymbolT._L msym = do g <- getST case sc.env.lookupS (view SymbolT.name msym).key of Nothing -> tcInstMethod scs isym msym @@ -781,8 +781,6 @@ tcInstMethod (sc:scs) isym msym E.fatal (view SymbolT.pos other) (text (other.nice g ++ " in " ++ sc.nice g)) where hasTyp = isJust . preview SymbolT.typ - isSymL (SymbolT.L _) = true - isSymL _ = false tcInstMethod _ _ (msym@SymbolT.V (SymV{pos, typ=s})) | not (isPSigma s) = do g <- getST diff --git a/frege/compiler/common/Resolve.fr b/frege/compiler/common/Resolve.fr index 1735f8ce..5c0a8055 100644 --- a/frege/compiler/common/Resolve.fr +++ b/frege/compiler/common/Resolve.fr @@ -130,9 +130,7 @@ private resolve3 fname pos (Simple Token{value=qs}) = do where more :: [String] -> Symtab -> [String] more acc env = foldr (:) acc [ (view SymbolT.name v).base | v <- values env, - not (isSymI v) ] - isSymI (SymbolT.I _) = true - isSymI _ = false + not (Lens.is SymbolT._I v) ] -- T.v T.C N.v N.C N.T private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do g <- getST diff --git a/frege/compiler/gen/java/DataCode.fr b/frege/compiler/gen/java/DataCode.fr index d5ef241d..43adad1e 100644 --- a/frege/compiler/gen/java/DataCode.fr +++ b/frege/compiler/gen/java/DataCode.fr @@ -337,9 +337,7 @@ subDecls ∷ Symbol → StG [JDecl] subDecls (SymbolT.T sym) = do g ← getST E.logmsg TRACEG sym.pos (text ("subDecls for " ++ nicer sym g)) - let isSymD (SymbolT.D _) = true - isSymD _ = false - let subdefs = filter (not . isSymD) (values sym.env) -- no constructors + let subdefs = filter (not . Lens.is SymbolT._D) (values sym.env) -- no constructors concat <$> mapM (varCode emptyTree) subdefs subDecls sym = do g ← getST diff --git a/frege/compiler/passes/Enter.fr b/frege/compiler/passes/Enter.fr index a9322cbc..c5b5db8f 100644 --- a/frege/compiler/passes/Enter.fr +++ b/frege/compiler/passes/Enter.fr @@ -225,9 +225,7 @@ enter1ClaDcl fname (d@ClaDcl {pos}) = do define a method with the same name.) -} g <- getST - let isSymL (SymbolT.L _) = true - isSymL _ = false - let vs = (filter (maybe true (not . isSymL) + let vs = (filter (maybe true (not . Lens.is SymbolT._L) . g.find . VName g.thisPack . QName.base . view SymbolT.name) . values . maybe empty (unsafePartialView SymbolT.env)) (g.findit tname) diff --git a/frege/compiler/passes/Imp.fr b/frege/compiler/passes/Imp.fr index c1c4d226..d61b70a7 100644 --- a/frege/compiler/passes/Imp.fr +++ b/frege/compiler/passes/Imp.fr @@ -245,15 +245,13 @@ importEnv pos env ns pack (imp@Imports {except=true, items}) = do g <- getST let xs = [ withNS ns.unNS (ImportItem.name e) | e <- items ] exss <- mapSt (resolve (VName g.thisPack) pos) xs - let isSymD (SymbolT.D _) = true - isSymD _ = false let exs = fold (++) [] exss nitems = [ protoItem.{ name = Simple pos.first.{tokid=VARID, value=(view SymbolT.name sym).base}, members = nomem csym, alias = (view SymbolT.name sym).base} | sym <- sortBy (comparing constructor) (values env), -- place SymL before SymC csym <- g.findit (view SymbolT.name sym), - not (isSymD csym) -- no constructors + not (Lens.is SymbolT._D csym) -- no constructors || (view SymbolT.name sym).base != (view SymbolT.name csym).base, -- except renamed ones view SymbolT.name csym `notElem` exs, view SymbolT.vis sym == Public diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 99a6b7d3..2b9ec2b2 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -3,7 +3,7 @@ module frege.compiler.types.Symbols where import frege.data.TreeMap as TM(TreeMap, each, values) import frege.control.monad.State -import frege.compiler.common.Lens (preview, view) +import frege.compiler.common.Lens (Choice, preview, prism', view) import frege.compiler.enums.RFlag(RState, RFlag) import frege.compiler.types.Positions import frege.compiler.types.Strictness @@ -212,6 +212,29 @@ data SymbolT global = vis f (V s) = (\vis -> V s.{vis}) <$> f s.vis vis f (A s) = (\vis -> A s.{vis}) <$> f s.vis + -- _T :: Prism' (SymbolT g) (SymT g) + _T :: (Choice p, Applicative f) => p (SymT g) (f (SymT g)) -> p (SymbolT g) (f (SymbolT g)) + _T = prism' T (\s -> case s of { SymbolT.T x -> Just x; _ -> Nothing; }) + -- _L :: Prism' (SymbolT g) (SymL g) + _L :: (Choice p, Applicative f) => p (SymL g) (f (SymL g)) -> p (SymbolT g) (f (SymbolT g)) + _L = prism' L (\s -> case s of { SymbolT.L x -> Just x; _ -> Nothing; }) + -- _D :: Prism' (SymbolT g) (SymD g) + _D :: (Choice p, Applicative f) => p (SymD g) (f (SymD g)) -> p (SymbolT g) (f (SymbolT g)) + _D = prism' D (\s -> case s of { SymbolT.D x -> Just x; _ -> Nothing; }) + -- _C :: Prism' (SymbolT g) (SymC g) + _C :: (Choice p, Applicative f) => p (SymC g) (f (SymC g)) -> p (SymbolT g) (f (SymbolT g)) + _C = prism' C (\s -> case s of { SymbolT.C x -> Just x; _ -> Nothing; }) + -- _I :: Prism' (SymbolT g) (SymI g) + _I :: (Choice p, Applicative f) => p (SymI g) (f (SymI g)) -> p (SymbolT g) (f (SymbolT g)) + _I = prism' I (\s -> case s of { SymbolT.I x -> Just x; _ -> Nothing; }) + -- _V :: Prism' (SymbolT g) (SymV g) + _V :: (Choice p, Applicative f) => p (SymV g) (f (SymV g)) -> p (SymbolT g) (f (SymbolT g)) + _V = prism' V (\s -> case s of { SymbolT.V x -> Just x; _ -> Nothing; }) + -- _A :: Prism' (SymbolT g) (SymA g) + _A :: (Choice p, Applicative f) => p (SymA g) (f (SymA g)) -> p (SymbolT g) (f (SymbolT g)) + _A = prism' A (\s -> case s of { SymbolT.A x -> Just x; _ -> Nothing; }) + + instance Ord (SymT g) where sym1 <=> sym2 = SymbolT.T sym1 <=> SymbolT.T sym2 diff --git a/frege/ide/Utilities.fr b/frege/ide/Utilities.fr index c4aa2733..0c831446 100644 --- a/frege/ide/Utilities.fr +++ b/frege/ide/Utilities.fr @@ -611,11 +611,9 @@ proposeContent !global root !offset !tokens !index = propose ] -- standardFilter standardFilter = [notPrivate, notTuple, notInstance, notOverloaded] - isSymL (SymbolT.L _) = true - isSymL _ = false notPrivate sym = view SymbolT.vis sym != Private || global.our (view SymbolT.name sym) - || isSymL sym + || Lens.is SymbolT._L sym notTuple = not . (flip String.startsWith "(") . QName.base . view SymbolT.name notInstance = (Just "instance" !=) . fmap (flip Nice.category global) . global.follow diff --git a/frege/tools/Doc.fr b/frege/tools/Doc.fr index ea890c71..6b51189e 100644 --- a/frege/tools/Doc.fr +++ b/frege/tools/Doc.fr @@ -318,15 +318,13 @@ mkLinks ns pack = do link :: Symbol -> StG () link (sym::Symbol) = do g <- getST - let isSymI (SymbolT.I _) = true - isSymI _ = false case g.thisTab.lookupS (view SymbolT.name sym).key of Just _ -> return () Nothing -> let rsym = fromMaybe sym (g.findit (view SymbolT.name sym)) in I.linkHere (ns.unNS) pack protoItem.{name=Simple (view SymbolT.pos sym).first.{value=(view SymbolT.name sym).base}, - members = if isJust (preview SymbolT.env rsym) && not (isSymI rsym) + members = if isJust (preview SymbolT.env rsym) && not (Lens.is SymbolT._I rsym) then Just [] else Nothing, alias=(view SymbolT.name sym).base} sym @@ -433,11 +431,9 @@ continueNamespaces fp = do links = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.L SymL{alias}) <- values g.thisTab, g.our alias, other <- g.findit alias, - not (isSymD other), -- no constructor aliases + not (Lens.is SymbolT._D other), -- no constructor aliases noclassmember g $ view SymbolT.name other] where - isSymD (SymbolT.D _) = true - isSymD _ = false noclassmember g (MName tname _) = case g.findit tname of Just (SymbolT.C _) -> false other -> true From cdcb6dbae7e2475c34e1ce1a2c74e40a52ae32f1 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 23 Oct 2019 15:15:37 +0900 Subject: [PATCH 35/95] Introduce SymVal to constrain the return type of findVD SymVal is a sum type of SymV and SymD. --- frege/compiler/Typecheck.fr | 4 ++-- frege/compiler/Utilities.fr | 9 +++++---- frege/compiler/classes/Nice.fr | 5 +++++ frege/compiler/common/Trans.fr | 6 +++--- frege/compiler/passes/Easy.fr | 2 +- frege/compiler/types/Symbols.fr | 15 +++++++++++++++ 6 files changed, 31 insertions(+), 10 deletions(-) diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index a560acb3..03fd05c3 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -931,8 +931,8 @@ tcRho' (x@Vbl{name}) (ety@Check erho) tcRho' (x@Vbl {name}) ety = do sym <- findVD name case sym of - SymbolT.D _ -> tcRho' Con{pos=x.pos, name=x.name, typ=x.typ} ety - SymbolT.V symv -> case isPSigma symv.typ of + SymVal.D _ -> tcRho' Con{pos=x.pos, name=x.name, typ=x.typ} ety + SymVal.V symv -> case isPSigma symv.typ of false -> if symv.state != Typechecked then do sig ← fst <$> K.kiSigma [] [] symv.typ diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index 2be46ba3..f70fa60f 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -160,11 +160,12 @@ findV qname = do Nothing -> E.fatal Position.null (fill (break ("looked for function " ++ qname.nice g ++ ", found Nothing"))) +findVD :: QName -> StG (SymVal Global) findVD qname = do g <- getST case g.findit qname of - Just (symc@(SymbolT.V _)) -> stio symc - Just (symc@(SymbolT.D _)) -> stio symc + Just (SymbolT.V sym) -> stio (SymVal.V sym) + Just (SymbolT.D sym) -> stio (SymVal.D sym) Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for function or constructor " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for function " ++ qname.nice g ++ ", found Nothing"))) @@ -922,8 +923,8 @@ ourGlobalFuns mtree ex = foldEx true collect empty ex where | otherwise = do sym <- findVD name case sym of - SymbolT.V _ -> stio (Left (acc `including` sym)) - sonst -> stio (Left acc) + SymVal.V _ -> stio (Left (acc `including` sym.toSymbol)) + _ -> stio (Left acc) collect acc (Mem {member}) | Just list <- TreeMap.lookupS mtree member.value = stio (Left (fold including acc list)) diff --git a/frege/compiler/classes/Nice.fr b/frege/compiler/classes/Nice.fr index 1d664ebe..525fa2c6 100644 --- a/frege/compiler/classes/Nice.fr +++ b/frege/compiler/classes/Nice.fr @@ -114,6 +114,11 @@ instance Nice (SymA Global) where nicer sym = nicer $ SymbolT.A sym +instance Nice (SymVal Global) where + nice = nice . SymVal.toSymbol + nicer = nicer . SymVal.toSymbol + + instance Nice Symbol where nice (sym@(SymbolT.L SymL{alias})) g = category sym g ++ " `" ++ alias.nice g ++ "`" nice sym g = category sym g ++ " `" ++ (view SymbolT.name sym).nice g ++ "`" diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index 39f9021b..c4ec369c 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -46,7 +46,7 @@ references sids x = U.foldEx true refs 0 x -- g <- getST -- E.logmsg TRACE7 pos ("references " ++ show n ++ " " ++ show sids ++ " " ++ nice name g) sym <- U.findVD name - if view SymbolT.sid sym `elem` sids then stio (Right (n+1)) else stio (Left n) + if view SymVal.sid sym `elem` sids then stio (Right (n+1)) else stio (Left n) refs n (Ifte c t e _) = do crefs <- references sids c trefs <- references sids t @@ -114,7 +114,7 @@ replSid sid r ex = U.mapEx true action ex where action (v@Vbl {name=Local {}}) = do sym <- U.findVD v.name - if view SymbolT.sid sym == sid then stio (Right r) else stio (Right v) + if view SymVal.sid sym == sid then stio (Right r) else stio (Right v) action x = stio (Left x) @@ -123,7 +123,7 @@ replName sid nm ex = U.mapEx true action ex where action (v@Vbl {name,pos}) = do sym <- U.findVD name - if view SymbolT.sid sym == sid then do + if view SymVal.sid sym == sid then do changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk pos.first) (Right nm)}} stio (Right v.{name=nm}) diff --git a/frege/compiler/passes/Easy.fr b/frege/compiler/passes/Easy.fr index 90b917e8..4a4406d0 100644 --- a/frege/compiler/passes/Easy.fr +++ b/frege/compiler/passes/Easy.fr @@ -119,7 +119,7 @@ checkDepth (SymbolT.L (vsym@SymL {pos, alias, name = MName inst base})) = do let unsafeToSymV s = case s of { SymbolT.V x -> x; } cmeth <- unsafeToSymV <$> classMethodOfInstMethod pos inst base rmeth <- U.findVD alias - let d = case rmeth of { SymbolT.V SymV{depth} -> depth; _ -> U.arity rmeth; } + let d = case rmeth of { SymVal.V SymV{depth} -> depth; _ -> U.arity rmeth.toSymbol; } when (cmeth.depth != d) do E.error pos (msgdoc ( nicer rmeth g ++ " is not a suitable implementation for " diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 2b9ec2b2..93501d48 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -88,6 +88,21 @@ data SymA global = !SymA kind::Kind, typ::Sigma, vars::[Tau] } +--- generalized value +--- variable, function, or data constructor +data SymVal global + = protected D (SymD global) + | protected V (SymV global) + where + toSymbol :: SymVal g -> SymbolT g + toSymbol (D s) = SymbolT.D s + toSymbol (V s) = SymbolT.V s + + -- sid :: Lens' (SymVal g) Int + sid :: Functor f => (Int -> f Int) -> SymVal g -> f (SymVal g) + sid f (D s) = (\sid -> D s.{sid}) <$> f s.sid + sid f (V s) = (\sid -> V s.{sid}) <$> f s.sid + {-- The information stored in the 'Symtab' nodes. -} From 86364a5fe835010cad11e1ab33d3571a6bf554da Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 23 Oct 2019 16:05:42 +0900 Subject: [PATCH 36/95] Modify Classes.implemented to take SymVal Because it can only take SymD and SymV. --- frege/compiler/Classes.fr | 18 +++++++++--------- frege/compiler/types/Symbols.fr | 8 ++++++++ 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index a7e734d6..871f270e 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -544,7 +544,7 @@ funForCIT cname iname tname (mname@MName _ base) = do inherit xname = do mem <- U.findV xname E.logmsg TRACE6 isym.pos (text ("inheriting " ++ mem.nice g)) - if implemented $ SymbolT.V mem + if implemented $ SymVal.V mem then do -- use default implementation mex <- U.maybeST mem.expr id mbx <- U.maybeST mex (U.copyExpr (Just isym.pos) empty) @@ -569,7 +569,7 @@ funForCIT cname iname tname (mname@MName _ base) = do linkq (MName tname base) $ SymbolT.V imem case ivmb of Just (SymbolT.V (ivsym@SymV{name})) - | implemented (SymbolT.V ivsym) || not (g.our iname) = case tvmb of + | implemented (SymVal.V ivsym) || not (g.our iname) = case tvmb of Just (SymbolT.L (tvsym@SymL{alias})) | alias == name = changeSym $ SymbolT.V ivsym.{op=msym.op} -- copy op | MName yname _ <- alias, @@ -597,7 +597,7 @@ funForCIT cname iname tname (mname@MName _ base) = do ++ "` given as implementation of instance member `" ++ nicer member g ++ "` must be annotated.")) changeSym $ SymbolT.I isym.{ env <- delete member.key } - Just osym | not (g.ourSym osym) || implemented osym = case tvmb of + Just osym | not (g.ourSym osym) || implemented (unsafePartialView SymbolT._Val osym) = case tvmb of Just (SymbolT.L (tsym@SymL{alias=same})) | same == alias = changeSym $ set SymbolT.op msym.op osym -- copy op | same == member = do @@ -625,7 +625,7 @@ funForCIT cname iname tname (mname@MName _ base) = do E.logmsg TRACE6 isym.pos (text (mname.nice g ++ " implemented in imported type.")) linkq (MName iname base) $ SymbolT.V tvsym changeSym $ SymbolT.V tvsym.{op=msym.op} - | implemented (SymbolT.V tvsym) = do + | implemented (SymVal.V tvsym) = do E.logmsg TRACE6 tvsym.pos (text (mname.nice g ++ " not yet implemented in " ++ isym.nice g)) let ivsym = tvsym.{name=MName iname base, sid = 0, op = msym.op} enter $ SymbolT.V ivsym @@ -644,7 +644,7 @@ funForCIT cname iname tname (mname@MName _ base) = do | MName yname other ← alias, yname == tname, Just impl <- g.follow (SymbolT.L ali) = do - if implemented impl + if implemented $ unsafePartialView SymbolT._Val impl then do E.logmsg TRACE6 (view SymbolT.pos impl) (text (mname.nice g ++ " not yet implemented in " ++ isym.nice g)) E.logmsg TRACE6 isym.pos (text ("copy implementation from " ++ impl.nice g)) @@ -697,10 +697,10 @@ funForCIT cname iname tname (mname@MName _ base) = do Just osym -> E.fatal (view SymbolT.pos osym) (text ("funForCIT: expected type member, found " ++ osym.nice g)) funForCIT cname iname tname mname = error "funForCIT: not a member" ---- check if 'Symbol' is an implemented function -implemented :: Symbol -> Bool -implemented (SymbolT.D _) = true -implemented (SymbolT.V vsym) = isJust vsym.expr || isJust vsym.nativ +--- check if 'SymVal' is an implemented function +implemented :: SymVal Global -> Bool +implemented (SymVal.D _) = true +implemented (SymVal.V vsym) = isJust vsym.expr || isJust vsym.nativ {-- check for each method in an instance if the type is more specific than the class type diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 93501d48..1ad46775 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -97,6 +97,10 @@ data SymVal global toSymbol :: SymVal g -> SymbolT g toSymbol (D s) = SymbolT.D s toSymbol (V s) = SymbolT.V s + fromSymbol :: SymbolT g -> Maybe (SymVal g) + fromSymbol (SymbolT.D s) = Just (D s) + fromSymbol (SymbolT.V s) = Just (V s) + fromSymbol _ = Nothing -- sid :: Lens' (SymVal g) Int sid :: Functor f => (Int -> f Int) -> SymVal g -> f (SymVal g) @@ -249,6 +253,10 @@ data SymbolT global = _A :: (Choice p, Applicative f) => p (SymA g) (f (SymA g)) -> p (SymbolT g) (f (SymbolT g)) _A = prism' A (\s -> case s of { SymbolT.A x -> Just x; _ -> Nothing; }) + -- _Val :: Prism' (SymbolT g) (SymVal g) + _Val :: (Choice p, Applicative f) => p (SymVal g) (f (SymVal g)) -> p (SymbolT g) (f (SymbolT g)) + _Val = prism' SymVal.toSymbol SymVal.fromSymbol + instance Ord (SymT g) where From 63a8efc50dc731e59727af0dd73e17ff633000a2 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 23 Oct 2019 16:21:48 +0900 Subject: [PATCH 37/95] Remove a non-exhaustive case from passC.mkanno Non-exhaustive case analysis was done on a parameter 'msym :: Symbol' but that was done just before returning a value. So it was moved out of the function to the caller site, removing the need to match on Symbol. Also the parameter was changed to 'mpos :: Position' because 'mkanno' was only interested in 'pos' field. --- frege/compiler/Classes.fr | 22 ++++++++-------------- 1 file changed, 8 insertions(+), 14 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index 871f270e..00f90452 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -229,8 +229,8 @@ passC = do T.subsCheck (SymbolT.V msym) msym.typ osym.typ case g.findit osym.name.tynm of Just (SymbolT.C ssym) -> do - mkanno symc (SymbolT.V msym) osym ssym - return () + memtyp <- mkanno symc msym.pos osym ssym + changeSym $ SymbolT.V msym.{typ = memtyp, anno = true} nothing -> E.fatal pos (text ("methodcheck: class " ++ osym.name.tynm.nice g ++ " vanished.")) _ -> E.fatal pos (text (msym.name.nice g ++ " occurs in more than one super class of " ++ symc.name.nice g)) methodcheck symc (SymbolT.L (msym@SymL{pos})) = do @@ -245,7 +245,7 @@ passC = do ali.anno, -- symc.name == same, Just (SymbolT.C ssym) <- g.findit osym.name.tynm = do - sig <- mkanno symc (SymbolT.L msym) osym ssym + sig <- mkanno symc msym.pos osym ssym T.subsCheck (SymbolT.V ali) ali.typ sig | otherwise = E.error pos (msgdoc (nicer msym g ++ " may only point to a value whose type is known through annotation or import.")) @@ -262,11 +262,11 @@ passC = do * t is the class variable of this class and n is a new name * that replaces accidental occurrences of t in the annotation of the super method -} - mkanno :: SymC Global -> Symbol -> SymV Global -> SymC Global -> StG Sigma - mkanno csym msym osym ssym = do + mkanno :: SymC Global -> Position -> SymV Global -> SymC Global -> StG Sigma + mkanno csym mpos osym ssym = do g <- getST i <- uniqid - let newvar = TVar {pos=view SymbolT.pos msym, var=noClashIdent ("t" ++ show i), kind = KVar} + let newvar = TVar {pos=mpos, var=noClashIdent ("t" ++ show i), kind = KVar} oldvar = ssym.tau.var thsvar = csym.tau.var tree1 = TreeMap.insert empty oldvar csym.tau @@ -277,18 +277,12 @@ passC = do let rho1 = substRho tree osym.typ.rho rep (ctx@Ctx {cname, tau = TVar {var=x}}) - | cname == ssym.name, x == thsvar = ctx.{pos=view SymbolT.pos msym, cname=csym.name} + | cname == ssym.name, x == thsvar = ctx.{pos=mpos, cname=csym.name} rep ctx = ctx rho = rho1.{context <- map rep} repv tv = TM.lookupDefault tv tv.var tree memtyp = ForAll (map repv osym.typ.bound) rho - case msym of - SymbolT.V msymv -> - changeSym $ SymbolT.V msymv.{typ = memtyp, anno = true} - SymbolT.L _ -> pure () - -- msym can only be SymT or SymV - -- TODO express this in type - return memtyp + pure memtyp true -> E.fatal osym.pos (text ("mkanno:: untyped " ++ osym.nice g)) From 43de55b20a03a1b35fce64d71a1d7e18c842d7bc Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 23 Oct 2019 16:41:17 +0900 Subject: [PATCH 38/95] Remove unsafeToSymC from passC.methodcheck The symbols must be SymCs because they are looked up by QNames which belong to SymC.supers. --- frege/compiler/Classes.fr | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index 00f90452..b084e332 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -202,14 +202,13 @@ passC = do methodcheck :: SymC Global -> Symbol -> StG () methodcheck symc (SymbolT.V (msym@SymV {pos})) = do g <- getST - let unsafeToSymC s = case s of { SymbolT.C x -> x; } let jprevs = [ g.findit (MName sup msym.name.base) | sup <- symc.supers ] xprevs = [ symv | Just (SymbolT.V symv) <- jprevs, symv.anno || isJust symv.nativ ] prevs = if null xprevs then [] else [maximumBy first xprevs] first SymV{name=MName c1 _} SymV{name=MName c2 _} - | Just sym1 <- unsafeToSymC <$> g.findit c1 - , Just sym2 <- unsafeToSymC <$> g.findit c2 + | Just (SymbolT.C sym1) <- g.findit c1 + , Just (SymbolT.C sym2) <- g.findit c2 = if sym1.name `elem` sym2.supers then Lt else if sym2.name `elem` sym1.supers then Gt else Eq From eaaae98bec9e9f3c3e6e971d94ccc59e7e1ec16d Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 23 Oct 2019 16:45:25 +0900 Subject: [PATCH 39/95] Remove a redundant pattern of tcInstMethod SymbolT.V is always matched by the second pattern because of 'Lens.has SymbolT.typ msym', rendering the third one redundant. --- frege/compiler/Classes.fr | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index b084e332..f7d547a0 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -710,7 +710,7 @@ tcInstMethod [] isym msym = do E.error (view SymbolT.pos msym) (msgdoc (msym.nice g ++ " is not a class member function")) tcInstMethod (sc:scs) isym msym - | hasTyp msym || Lens.is SymbolT._L msym = do + | Lens.has SymbolT.typ msym || Lens.is SymbolT._L msym = do g <- getST case sc.env.lookupS (view SymbolT.name msym).key of Nothing -> tcInstMethod scs isym msym @@ -772,12 +772,6 @@ tcInstMethod (sc:scs) isym msym Just (SymbolT.L _) -> tcInstMethod scs isym msym Just other -> do E.fatal (view SymbolT.pos other) (text (other.nice g ++ " in " ++ sc.nice g)) - where - hasTyp = isJust . preview SymbolT.typ - -tcInstMethod _ _ (msym@SymbolT.V (SymV{pos, typ=s})) | not (isPSigma s) = do - g <- getST - E.fatal pos (text ("tcInstMethod: " ++ msym.nice g ++ " annotated with " ++ s.nicer g)) tcInstMethod _ _ msym = do g <- getST From a3f51fd3c4ea1e615a8159227191af92c17c13e6 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 23 Oct 2019 23:12:58 +0900 Subject: [PATCH 40/95] Assume tcInstMethod takes either SymV or SymL Under that assumption, the non-exhaustive case was rewritten so that it becomes noop on uninterested cases. --- frege/compiler/Classes.fr | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index f7d547a0..844961e4 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -710,7 +710,7 @@ tcInstMethod [] isym msym = do E.error (view SymbolT.pos msym) (msgdoc (msym.nice g ++ " is not a class member function")) tcInstMethod (sc:scs) isym msym - | Lens.has SymbolT.typ msym || Lens.is SymbolT._L msym = do + | Lens.is SymbolT._V msym || Lens.is SymbolT._L msym = do g <- getST case sc.env.lookupS (view SymbolT.name msym).key of Nothing -> tcInstMethod scs isym msym @@ -752,18 +752,13 @@ tcInstMethod (sc:scs) isym msym -- E.logmsg TRACE6 msym.pos ("sigmaInst: " ++ show (map (flip nice g) inst)) -- let mfinal = msig.{bound = [ var | TVar {var} <- inst]} -- E.logmsg TRACE6 msym.pos (msym.nice g ++ " instance type " ++ mfinal.nicer g) - case isPSigma sig of - true -> do - case msym of - SymbolT.V msymv -> - changeSym $ SymbolT.V msymv.{typ = msig, anno = true} - false -> do - T.subsCheck msym sig msig - T.checkConstraints msym sig msig - T.checkConstraints msym msig sig - case msym of - SymbolT.V msymv -> changeSym $ SymbolT.V msymv.{typ = msig, anno = true} - _ -> pure () + unless (isPSigma sig) do + T.subsCheck msym sig msig + T.checkConstraints msym sig msig + T.checkConstraints msym msig sig + case msym of + SymbolT.V msymv -> changeSym $ SymbolT.V msymv.{typ = msig, anno = true} + _ -> pure () other -> E.fatal isym.pos (msgdoc ("RhoTau expected, got " ++ rhotau.nicer g)) Just (SymbolT.V (symv@SymV {typ=sig})) | isPSigma sig -> do E.fatal symv.pos (text (symv.nice g ++ " of " ++ sc.nice g ++ " is not annotated")) From 037f1a8f5f8b677ac09bfd292c24c4b4614acdb5 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 00:16:25 +0900 Subject: [PATCH 41/95] Change the type of SymI.env to SymMeth SymMeth is a new data type which is a sum of SymL and SymV. SymI.env was renamed to SymI.meth and can now accept SymL and SymV only. The following functions now take SymMeth instead of Symbol. This change is considered safe because they threw runtime errors when receiving other than SymL or SymV. - frege.compiler.Classes.tcInstMethod - frege.compiler.gen.java.VarCode.varCode - frege.compiler.passes.Easy.checkDepth SymbolT.env' which is a generalization of .env and .meth is added and uses of SymbolT.env are replaced with SymbolT.env' where applicable. --- frege/compiler/Classes.fr | 40 +++++++++------------- frege/compiler/GenMeta.fr | 36 ++++++++++---------- frege/compiler/Main.fr | 8 ++--- frege/compiler/Typecheck.fr | 2 +- frege/compiler/Utilities.fr | 4 +-- frege/compiler/classes/Nice.fr | 9 +++-- frege/compiler/common/Lens.fr | 14 ++++++++ frege/compiler/common/Resolve.fr | 8 ++--- frege/compiler/common/SymbolTable.fr | 8 +++++ frege/compiler/gen/java/DataCode.fr | 2 +- frege/compiler/gen/java/InstanceCode.fr | 4 +-- frege/compiler/gen/java/MethodCall.fr | 8 ++--- frege/compiler/gen/java/VarCode.fr | 26 +++++++------- frege/compiler/passes/Easy.fr | 9 ++--- frege/compiler/passes/Enter.fr | 8 ++--- frege/compiler/passes/Final.fr | 3 +- frege/compiler/passes/GenCode.fr | 2 +- frege/compiler/passes/Imp.fr | 2 +- frege/compiler/types/Global.fr | 2 +- frege/compiler/types/Symbols.fr | 45 +++++++++++++++++++++++-- frege/ide/Utilities.fr | 8 ++--- frege/tools/Splitter.fr | 2 +- frege/tools/doc/Utilities.fr | 8 ++--- 23 files changed, 158 insertions(+), 100 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index 844961e4..5c9dde72 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -531,7 +531,7 @@ funForCIT cname iname tname (mname@MName _ base) = do ++ ", inst: " ++ nicer iname g ++ ", type: " ++ nicer tname g ++ ", member: " ++ nicer mname g)) - let ivmb = isym.env.lookup mname.key + let ivmb = isym.meth.lookup mname.key tvmb = tsym.env.lookup mname.key -- implemented vsym = isJust (Symbol.expr vsym) || isJust (Symbol.nativ vsym) inherit xname = do @@ -561,7 +561,7 @@ funForCIT cname iname tname (mname@MName _ base) = do enter $ SymbolT.V imem linkq (MName tname base) $ SymbolT.V imem case ivmb of - Just (SymbolT.V (ivsym@SymV{name})) + Just (SymMeth.V (ivsym@SymV{name})) | implemented (SymVal.V ivsym) || not (g.our iname) = case tvmb of Just (SymbolT.L (tvsym@SymL{alias})) | alias == name = changeSym $ SymbolT.V ivsym.{op=msym.op} -- copy op @@ -582,14 +582,14 @@ funForCIT cname iname tname (mname@MName _ base) = do linkq (MName tname base) $ SymbolT.V ivsym changeSym $ SymbolT.V ivsym.{op=msym.op} -- copy op | otherwise = E.error isym.pos (msgdoc ("implementation missing for " ++ ivsym.nice g)) - Just (Symbol.L SymL{pos=ipos, name=member, alias}) -- imported instance with links to type methods? + Just (SymMeth.L SymL{pos=ipos, name=member, alias}) -- imported instance with links to type methods? | not (g.our iname), alias.{tynm?}, alias.tynm == tname = stio () | otherwise = case g.findit alias of Just symv' | SymbolT.V symv <- symv', not symv.anno && not (maybe false (const true) symv.nativ) = do E.error ipos (msgdoc ("function `" ++ nicer alias g ++ "` given as implementation of instance member `" ++ nicer member g ++ "` must be annotated.")) - changeSym $ SymbolT.I isym.{ env <- delete member.key } + changeSym $ SymbolT.I isym.{ meth <- delete member.key } Just osym | not (g.ourSym osym) || implemented (unsafePartialView SymbolT._Val osym) = case tvmb of Just (SymbolT.L (tsym@SymL{alias=same})) | same == alias = changeSym $ set SymbolT.op msym.op osym -- copy op @@ -608,7 +608,6 @@ funForCIT cname iname tname (mname@MName _ base) = do Just osym -> E.error ipos (text (nicer osym g ++ " is not implemented.")) Nothing -> do E.fatal ipos (msgdoc (nicer member g ++ " links to " ++ alias.nicer g ++ ", but the latter doesn't exist.")) - Just osym -> E.fatal isym.pos (text ("expected instance member, found " ++ osym.nice g)) Nothing -> case tvmb of Nothing -> inherit mname Just (SymbolT.V tvsym) @@ -699,29 +698,28 @@ implemented (SymVal.V vsym) = isJust vsym.expr || isJust vsym.nativ check for each method in an instance if the type is more specific than the class type -} tcInstMethods :: [SymC Global] -> SymI Global -> StG () -tcInstMethods supers inst = foreach (values inst.env) (tcInstMethod supers inst) +tcInstMethods supers inst = foreach (values inst.meth) (tcInstMethod supers inst) {-- check if the type of an instance method is more specific than the type of the class method -} -tcInstMethod :: [SymC Global] -> SymI Global -> Symbol -> StG () -tcInstMethod [] isym msym = do +tcInstMethod :: [SymC Global] -> SymI Global -> SymMeth Global -> StG () +tcInstMethod [] _ msym = do g <- getST - E.error (view SymbolT.pos msym) (msgdoc (msym.nice g ++ " is not a class member function")) + E.error (view SymMeth.pos msym) (msgdoc (msym.nice g ++ " is not a class member function")) -tcInstMethod (sc:scs) isym msym - | Lens.is SymbolT._V msym || Lens.is SymbolT._L msym = do +tcInstMethod (sc:scs) isym msym = do g <- getST - case sc.env.lookupS (view SymbolT.name msym).key of + case sc.env.lookupS (view SymMeth.name msym).key of Nothing -> tcInstMethod scs isym msym Just (SymbolT.V SymV{typ=(s@ForAll sbnd srho)}) | not (isPSigma s) = do g <- getST let !mtnice = case isPSigma sig of true -> "None"; false -> sig.nicer g !csig = ForAll (filter ((sc.tau.var!=) . _.var) sbnd) srho - !sig = case g.findit (view SymbolT.name msym) of + !sig = case g.findit (view SymMeth.name msym) of Just xsym | Just typ <- preview SymbolT.typ xsym -> typ other -> error ("tcInstMethod: link to nothing: " ++ nice msym g) - E.logmsg TRACE6 (view SymbolT.pos msym) (text (msym.nice g + E.logmsg TRACE6 (view SymMeth.pos msym) (text (msym.nice g ++ " class: " ++ sc.nice g ++ " class method type: " ++ s.nicer g ++ " own type: " ++ mtnice)) @@ -745,19 +743,15 @@ tcInstMethod (sc:scs) isym msym -- of Eq.== for Int adapt = filter (not • T.sameCtx (Ctx Position.null sc.name tau)) -- msig1 = msig - E.logmsg TRACE6 (view SymbolT.pos msym) (text (msym.nice g ++ " adapted type " ++ msig.nicer g)) + E.logmsg TRACE6 (view SymMeth.pos msym) (text (msym.nice g ++ " adapted type " ++ msig.nicer g)) msig <- T.canonicSignature msig - E.logmsg TRACE6 (view SymbolT.pos msym) (text (msym.nice g ++ " instance type " ++ msig.nicer g)) - -- let inst = U.sigmaInst g csig msig - -- E.logmsg TRACE6 msym.pos ("sigmaInst: " ++ show (map (flip nice g) inst)) - -- let mfinal = msig.{bound = [ var | TVar {var} <- inst]} - -- E.logmsg TRACE6 msym.pos (msym.nice g ++ " instance type " ++ mfinal.nicer g) + E.logmsg TRACE6 (view SymMeth.pos msym) (text (msym.nice g ++ " instance type " ++ msig.nicer g)) unless (isPSigma sig) do T.subsCheck msym sig msig T.checkConstraints msym sig msig T.checkConstraints msym msig sig case msym of - SymbolT.V msymv -> changeSym $ SymbolT.V msymv.{typ = msig, anno = true} + SymMeth.V msymv -> changeSym $ SymbolT.V msymv.{typ = msig, anno = true} _ -> pure () other -> E.fatal isym.pos (msgdoc ("RhoTau expected, got " ++ rhotau.nicer g)) Just (SymbolT.V (symv@SymV {typ=sig})) | isPSigma sig -> do @@ -767,7 +761,3 @@ tcInstMethod (sc:scs) isym msym Just (SymbolT.L _) -> tcInstMethod scs isym msym Just other -> do E.fatal (view SymbolT.pos other) (text (other.nice g ++ " in " ++ sc.nice g)) - -tcInstMethod _ _ msym = do - g <- getST - E.fatal (view SymbolT.pos msym) (text ("tcInstMethod: strange symbol " ++ msym.nice g)) diff --git a/frege/compiler/GenMeta.fr b/frege/compiler/GenMeta.fr index cac6605b..31c1551d 100644 --- a/frege/compiler/GenMeta.fr +++ b/frege/compiler/GenMeta.fr @@ -154,8 +154,8 @@ genmeta = do let tsyms = [sym | SymbolT.T sym <- values g.thisTab, sym.vis!=Private] symts <- liftStG $ mapSt annoSymT tsyms - symvs <- liftStG $ envValues g.thisTab - symls <- liftStG $ envLinks g.thisTab + symvs <- liftStG $ envValues $ values g.thisTab + symls <- liftStG $ envLinks $ values g.thisTab g <- getSTT ctime <- liftIO (System.currentTimeMillis()) @@ -200,23 +200,23 @@ genmeta = do --- create annotations for all SymV in an environment -envValues :: Symtab -> StG [DOCUMENT] -envValues env = do - let vsyms = [sym | SymbolT.V sym <- values env, sym.vis != Private] +envValues :: [Symbol] -> StG [DOCUMENT] +envValues envsyms = do + let vsyms = [sym | SymbolT.V sym <- envsyms, sym.vis != Private] symvs <- mapSt annoSymV vsyms stio symvs --- create annotations for all SymL in an environment -envLinks :: Symtab -> StG [DOCUMENT] -envLinks env = do +envLinks :: [Symbol] -> StG [DOCUMENT] +envLinks envsyms = do g <- getST - let syms = [ sym | SymbolT.L sym <- values env, sym.vis != Private] + let syms = [ sym | SymbolT.L sym <- envsyms, sym.vis != Private] mapM annoSymL syms --- create annotations for all SymD in an environment -envCons :: Symtab -> StG [DOCUMENT] -envCons env = do - let syms = [sym | SymbolT.D sym <- values env] +envCons :: [Symbol] -> StG [DOCUMENT] +envCons envsyms = do + let syms = [sym | SymbolT.D sym <- envsyms] mapSt annoSymD syms @@ -630,8 +630,8 @@ annoSymC :: SymC Global -> StG DOCUMENT annoSymC sym = do g ← getST tau <- tauIndex sym.tau - meml <- envLinks sym.env - memv <- envValues sym.env + meml <- envLinks $ values sym.env + memv <- envValues $ values sym.env let a = meta g "SymC" [ ("offset", anno sym.pos.first.offset), ("name", annoG g sym.name), @@ -649,8 +649,8 @@ annoSymI :: SymI Global -> StG DOCUMENT annoSymI sym = do g ← getST typ <- sigIndex sym.typ - meml <- envLinks sym.env - memv <- envValues sym.env + meml <- envLinks $ map _.toSymbol $ values sym.meth + memv <- envValues $ map _.toSymbol $ values sym.meth let a = meta g "SymI" [ ("offset", anno sym.pos.first.offset), ("name", annoG g sym.name), @@ -665,9 +665,9 @@ annoSymT :: SymT Global -> StG DOCUMENT annoSymT sym = do g ← getST typ <- sigIndex sym.typ - memc <- envCons sym.env - meml <- envLinks sym.env - memv <- envValues sym.env + memc <- envCons $ values sym.env + meml <- envLinks $ values sym.env + memv <- envValues $ values sym.env kind <- kindIndex sym.kind gargs ← mapM tauIndex sym.gargs let a = meta g "SymT" [ diff --git a/frege/compiler/Main.fr b/frege/compiler/Main.fr index 9588e9ca..5c3372ed 100644 --- a/frege/compiler/Main.fr +++ b/frege/compiler/Main.fr @@ -267,15 +267,15 @@ makeFile glob sts = do Just _ → return () none → do u ← uniqid - case preview SymbolT.env sym of - Just _ -> enter $ set SymbolT.sid u $ set SymbolT.env empty $ sym - Nothing -> enter $ set SymbolT.sid u $ sym + enter $ set SymbolT.sid u $ case sym of + SymbolT.I symi -> SymbolT.I symi.{meth=empty} + _ -> set SymbolT.env empty $ sym E.logmsg TRACEZ Position.null ( text "makeFile: entered" <+> (text (sym.nice g)) <+> (text (show u)) ) - for_ (preview SymbolT.env sym) mergeSymtab + for_ sym.env' mergeSymtab --- make filename from package name @x.y.z.Packet@ => @dest/x/y/z/Packet.java@ targetPath :: Global -> String -> String diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index 03fd05c3..b9d62637 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -123,7 +123,7 @@ post = stio true --- construct a tree of all our member functions memberTree = do g <- getST - let envs = g.thisTab : mapMaybe (preview SymbolT.env) (values g.thisTab) + let envs = g.thisTab : mapMaybe SymbolT.env' (values g.thisTab) mems = fold ins empty [ sy | env <- envs, sy@(SymbolT.V SymV{name=MName _ _}) <- values env, g.ourSym sy] ins :: TreeMap String [Symbol] -> Symbol -> TreeMap String [Symbol] ins t sy diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index f70fa60f..38e9f002 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -955,14 +955,14 @@ fundep (SymV{name, expr=Nothing}) = stio (name, []) --- find all our 'SymV' symbols allourvars :: Global -> [SymV Global] allourvars g = - let collectedenvs = g.thisTab : mapMaybe (preview SymbolT.env) (values g.thisTab) + let collectedenvs = g.thisTab : mapMaybe SymbolT.env' (values g.thisTab) in [ v | env <- collectedenvs, SymbolT.V v <- values env, g.our v.name ] --- find all 'SymV' symbols, be they ours or not allvars :: Global -> [SymV Global] allvars g = - let envEnvs env = env : mapMaybe (preview SymbolT.env) (values g.thisTab) + let envEnvs env = env : mapMaybe SymbolT.env' (values g.thisTab) packEnvs = values g.packages collectedenvs = fold (++) [] (map envEnvs packEnvs) in [ v | env::Symtab <- collectedenvs, SymbolT.V v <- values env ] diff --git a/frege/compiler/classes/Nice.fr b/frege/compiler/classes/Nice.fr index 525fa2c6..730391ac 100644 --- a/frege/compiler/classes/Nice.fr +++ b/frege/compiler/classes/Nice.fr @@ -115,8 +115,13 @@ instance Nice (SymA Global) where instance Nice (SymVal Global) where - nice = nice . SymVal.toSymbol - nicer = nicer . SymVal.toSymbol + nice = nice . _.toSymbol + nicer = nicer . _.toSymbol + + +instance Nice (SymMeth Global) where + nice = nice . _.toSymbol + nicer = nicer . _.toSymbol instance Nice Symbol where diff --git a/frege/compiler/common/Lens.fr b/frege/compiler/common/Lens.fr index ae387558..59c5360e 100644 --- a/frege/compiler/common/Lens.fr +++ b/frege/compiler/common/Lens.fr @@ -124,6 +124,20 @@ over l f = Identity.run . l (Identity . f) set :: ASetter s t a b -> b -> s -> t set l b = Identity.run . l (\_ -> Identity b) +-- some concrete prisms + +_Left :: Prism (Either a c) (Either b c) a b +_Left = prism Left $ either Right (Left . Right) + +_Right :: Prism (Either c a) (Either c b) a b +_Right = prism Right $ either (Left . Left) Right + +_Just :: Prism (Maybe a) (Maybe b) a b +_Just = prism Just $ maybe (Left Nothing) Right + +_Nothing :: Prism' (Maybe a) () +_Nothing = prism' (const Nothing) $ maybe (Just ()) (const Nothing) + --- warning: this function is partial -- TODO eliminate the uses of these functions unsafePartialView :: Getting (First a) s a -> s -> a diff --git a/frege/compiler/common/Resolve.fr b/frege/compiler/common/Resolve.fr index 5c0a8055..4e848b8b 100644 --- a/frege/compiler/common/Resolve.fr +++ b/frege/compiler/common/Resolve.fr @@ -6,7 +6,7 @@ import frege.Prelude hiding(break, <+>) import frege.data.TreeMap as TM(TreeMap, lookup, each, insert, union, including, contains, keys, values, fromKeys) import frege.data.List as DL(partitioned, sortBy, minimumBy) import frege.lib.PP(break, fill, text, nest, msgdoc, <+>, <>, DOCUMENT) -import frege.compiler.common.Lens (preview, set, unsafePartialView, view) +import frege.compiler.common.Lens (_Just, preview, set, unsafePartialView, view) import frege.compiler.enums.Flags import frege.compiler.enums.Visibility import frege.compiler.types.Positions @@ -124,7 +124,7 @@ private resolve3 fname pos (Simple Token{value=qs}) = do rs -> stio rs where scope g (MName t _) | Just sym <- g.findit t - = scopefrom [unsafePartialView SymbolT.env sym, g.thisTab] + = scopefrom [unsafePartialView _Just sym.env', g.thisTab] scope g _ = scopefrom [g.thisTab] scopefrom envs = fold more [] envs where @@ -194,7 +194,7 @@ private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do tsns g = [ n | NSX n <- keys g.namespaces ] ++ [ (view SymbolT.name s).base | (s::Symbol) <- values g.thisTab, isTName (view SymbolT.name s)] ms :: Symbol -> [String] - ms s | Just env <- preview SymbolT.env s = map (QName.base . view SymbolT.name) (values env) + ms s | Just env <- s.env' = map (QName.base . view SymbolT.name) (values env) | otherwise = [] es :: Symtab -> [String] es e = map (QName.base . view SymbolT.name) (values e) @@ -239,7 +239,7 @@ private resolve3 _ pos (snm@With2 Token{value=n} Token{value=t} Token{value=qm}) ns :: Global -> [String] ns g = [ n | NSX n <- keys g.namespaces ] ms :: Symbol -> [String] - ms s | Just env <- preview SymbolT.env s = map (QName.base . view SymbolT.name) (values env) + ms s | Just env <- s.env' = map (QName.base . view SymbolT.name) (values env) | otherwise = [] ts :: Symtab -> [String] ts e = [ x | TName _ x <- map (view SymbolT.name) (values e) ] diff --git a/frege/compiler/common/SymbolTable.fr b/frege/compiler/common/SymbolTable.fr index 5ba8506e..985cbf5d 100644 --- a/frege/compiler/common/SymbolTable.fr +++ b/frege/compiler/common/SymbolTable.fr @@ -142,6 +142,10 @@ changeSym sym = do Nothing -> do let qn = t.nice g E.error (view SymbolT.pos sym) (fill ([text "namespace", text "`" <> text qn <> text "`"] ++ break "does not exist")) + Just (SymbolT.I typi) -> case SymMeth.fromSymbol sym of + Just ameth -> do + meth <- updateSym SymMeth.toSymbol typi.meth name.key ameth + updateGlobal t.pack t.key $ SymbolT.I typi.{meth} Just typ -> case preview SymbolT.env typ of Just typEnv -> do env <- updateSym id typEnv name.key sym @@ -178,6 +182,10 @@ private enterByName sym = do Nothing -> do let qn = t.nice g E.error pos (msgdoc("namespace `" ++ qn ++ "` does not exist")) + Just (SymbolT.I typi) -> case SymMeth.fromSymbol sym of + Just ameth -> do + meth <- insertSym SymMeth.toSymbol typi.meth name.key ameth + updateGlobal t.pack t.key $ SymbolT.I typi.{meth} Just typ -> case preview SymbolT.env typ of Just typEnv -> do env <- insertSym id typEnv name.key sym diff --git a/frege/compiler/gen/java/DataCode.fr b/frege/compiler/gen/java/DataCode.fr index 43adad1e..0bad61fb 100644 --- a/frege/compiler/gen/java/DataCode.fr +++ b/frege/compiler/gen/java/DataCode.fr @@ -337,7 +337,7 @@ subDecls ∷ Symbol → StG [JDecl] subDecls (SymbolT.T sym) = do g ← getST E.logmsg TRACEG sym.pos (text ("subDecls for " ++ nicer sym g)) - let subdefs = filter (not . Lens.is SymbolT._D) (values sym.env) -- no constructors + let subdefs = mapMaybe SymMeth.fromSymbol (values sym.env) -- no constructors concat <$> mapM (varCode emptyTree) subdefs subDecls sym = do g ← getST diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index 40f9e45f..a2326681 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -222,7 +222,7 @@ instanceCode (SymbolT.I sym) = do -- instance definition SymbolT.C SymC{supers} <- g.findit clas, -- of a class that is in our hierarchy clas `elem` classes || any (`elem` classes) supers] _ -> error "unexpected result from instTSym" - methods1 = map (view SymbolT.name) (values sym.env) + methods1 = map (view SymMeth.name) (values sym.meth) -- methods of super classes that are implemented in the type itself methods3 = case instTSym sym.typ g of Just (SymbolT.T tsym) -> [ view SymbolT.name sym | @@ -233,7 +233,7 @@ instanceCode (SymbolT.I sym) = do -- instance definition _ -> error "unexpected result from instTSym" methods = methods1 ++ methods2 ++ methods3 - let vals = values sym.env + let vals = values sym.meth let constraints = zipWith (constraintDef g) sym.typ.rho.context (getCtxs g) constrargs = zipWith (constraintArg g) sym.typ.rho.context (getArgs g) diff --git a/frege/compiler/gen/java/MethodCall.fr b/frege/compiler/gen/java/MethodCall.fr index a5cdd06b..be1b7a32 100644 --- a/frege/compiler/gen/java/MethodCall.fr +++ b/frege/compiler/gen/java/MethodCall.fr @@ -4,7 +4,7 @@ module frege.compiler.gen.java.MethodCall where import Data.TreeMap(TreeMap, values) import Data.List(elemBy) -import frege.compiler.common.Lens (unsafePartialView, view) +import frege.compiler.common.Lens (_Just, unsafePartialView, view) import Compiler.Utilities as U() @@ -110,13 +110,13 @@ nativeCall g (SymbolT.V (symv@SymV{nativ = Just item, gargs})) subst aexs = newB si <- symInfo $ SymbolT.V symv let name = (head si.argSigs).rho.tau.name irsym = unJust $ g.findit name - nms = mapMaybe (_.name) [ fld | SymbolT.D x <- values (unsafePartialView SymbolT.env irsym), fld <- x.flds ] + nms = mapMaybe (_.name) [ fld | SymbolT.D x <- values (unsafePartialView _Just irsym.env'), fld <- x.flds ] return $ flip mapMaybe nms $ \fldnm -> do nativrsym <- g.findit $ si.retSig.rho.tau.name - nativsym <- TreeMap.lookup fldnm (unsafePartialView SymbolT.env nativrsym) + nativsym <- TreeMap.lookup fldnm (unsafePartialView _Just nativrsym.env') nativnm <- unsafePartialView SymbolT.nativ nativsym let nativsi = evalStG g $ symInfo nativsym - fldsym <- TreeMap.lookup fldnm (unsafePartialView SymbolT.env irsym) + fldsym <- TreeMap.lookup fldnm (unsafePartialView _Just irsym.env') pure $ wrapIRMethod g (head args) (head si.argJTs) nativsi nativnm fldnm fldsym in JNewClass jrty [] (evalStG g x) NICast -> case args of diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index 2e2ae131..9c1756f3 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -23,7 +23,7 @@ import Compiler.instances.Nicer(nicerctx, nicectx) import Compiler.types.Global(Symbol, StG, Global(), getST, changeST, uniqid) -import Compiler.types.Symbols(SymV, SymL, SymD, SymT, SymC, SymI, SymbolT) +import Compiler.types.Symbols(SymV, SymL, SymD, SymT, SymC, SymI, SymMeth, SymbolT) import Compiler.types.Expression(Expr, ExprT, CAlt, CAltT, flatx) import Compiler.types.Patterns(Pattern, PatternT) import Compiler.types.Positions(Positioned) @@ -60,23 +60,23 @@ import Compiler.gen.java.Constants(findConst, staticConst) import Compiler.gen.java.Instantiation(instPatternBound, resolveConstraint, envCtxs, resolvableCtxs) import Compiler.gen.java.PrettyJava(lambda7, thunkMarker) -varCode ∷ TreeMap Int Binding → Symbol → StG [JDecl] -varCode _ (SymbolT.L SymL{sid, pos, vis, name, alias}) = do +varCode :: TreeMap Int Binding -> SymMeth Global -> StG [JDecl] +varCode _ (SymMeth.L SymL{sid, pos, vis, name, alias}) = do g ← getST pure [JComment ("alias " ++ name.base ++ " for " ++ show (javaName g alias))] -varCode binds sym = do +varCode binds (SymMeth.V symv) = do g <- getST - E.logmsg TRACEG (view SymbolT.pos sym) (text ("varCode for " ++ nicer sym g)) - si <- symInfo sym - case sym of - SymbolT.V (symv@SymV{expr = Just _}) + E.logmsg TRACEG symv.pos (text ("varCode for " ++ nicer symv g)) + si <- symInfo $ SymbolT.V symv + case symv of + SymV{expr = Just _} | null si.argSigs = cafCode symv binds -- nust be CAF | otherwise = funDef symv binds - SymbolT.V (symv@SymV{nativ = Just _, over}) + SymV{nativ = Just _, over} | null over = do g ← getST E.logmsg TRACEG symv.pos (text "native var:" @@ -84,12 +84,12 @@ varCode binds sym = do <+> text (nicer symv.typ.rho g) <> text ", depth=" <> anno symv.depth <> text ", rstate=" <> (text • show) symv.rkind) - si ← symInfo sym - return (comment : methCode g sym si) + si <- symInfo (SymbolT.V symv) + return (comment : methCode g (SymbolT.V symv) si) | otherwise = return [] -- there is no code for overloads where - comment = JComment (nicer sym g) - _ = error ("varCode: no SymV? " ++ nicer sym g) + comment = JComment (nicer symv g) + _ -> error ("varCode: bad SymV " ++ nicer symv g) --- Generate code for a function with arguments funDef :: SymV Global -> TreeMap Int Binding -> StG [JDecl] diff --git a/frege/compiler/passes/Easy.fr b/frege/compiler/passes/Easy.fr index 4a4406d0..6c5571f1 100644 --- a/frege/compiler/passes/Easy.fr +++ b/frege/compiler/passes/Easy.fr @@ -70,7 +70,7 @@ pass = do g <- getST let imembers = [ imem | SymbolT.I inst <- values g.thisTab, g.our inst.name, - imem <- values inst.env ] + imem <- values inst.meth ] foreach imembers checkDepth -- make all expressions easy g <- getST @@ -102,7 +102,8 @@ easySym (vsym@SymV {pos}) _ -> false -checkDepth (SymbolT.V (vsym@SymV {pos, name = MName inst base})) = do +checkDepth :: SymMeth Global -> StG () +checkDepth (SymMeth.V (vsym@SymV {pos, name = MName inst base})) = do g <- getST let unsafeToSymV s = case s of { SymbolT.V x -> x; } cmeth <- unsafeToSymV <$> classMethodOfInstMethod pos inst base @@ -114,7 +115,7 @@ checkDepth (SymbolT.V (vsym@SymV {pos, name = MName inst base})) = do when (cmeth.depth < vsym.depth) do changeSym $ SymbolT.V vsym.{depth = cmeth.depth} return () -checkDepth (SymbolT.L (vsym@SymL {pos, alias, name = MName inst base})) = do +checkDepth (SymMeth.L (vsym@SymL {pos, alias, name = MName inst base})) = do g <- getST let unsafeToSymV s = case s of { SymbolT.V x -> x; } cmeth <- unsafeToSymV <$> classMethodOfInstMethod pos inst base @@ -130,7 +131,7 @@ checkDepth (SymbolT.L (vsym@SymL {pos, alias, name = MName inst base})) = do return () checkDepth bad = do g <- getST - E.fatal (view SymbolT.pos bad) (text(nicer bad g ++ " must not occur in instances.")) + E.fatal (view SymMeth.pos bad) (text(nicer bad g ++ " must not occur in instances.")) depthSym (vsym@SymV {pos}) diff --git a/frege/compiler/passes/Enter.fr b/frege/compiler/passes/Enter.fr index c5b5db8f..74e2c684 100644 --- a/frege/compiler/passes/Enter.fr +++ b/frege/compiler/passes/Enter.fr @@ -5,7 +5,7 @@ import frege.Prelude hiding (<+>) import frege.data.TreeMap as TM(TreeMap, keys, values, insert) import frege.data.List as DL(uniqBy, sort, sortBy) -import frege.compiler.common.Lens (preview, unsafePartialView, view) +import frege.compiler.common.Lens (_Just, preview, unsafePartialView, view) import frege.compiler.enums.Flags as Compilerflags(TRACE3, TRACE4, isOn, isOff) import frege.compiler.enums.TokenID(defaultInfix) @@ -51,7 +51,7 @@ symbols tree = fold (+) 0 (map oneSym (values tree)) oneSym :: Symbol -> Int -oneSym sym = 1 + maybe 0 symbols (preview SymbolT.env sym) +oneSym sym = 1 + maybe 0 symbols sym.env' isInstOrDerive :: DefinitionS -> Bool @@ -228,7 +228,7 @@ enter1ClaDcl fname (d@ClaDcl {pos}) = do let vs = (filter (maybe true (not . Lens.is SymbolT._L) . g.find . VName g.thisPack . QName.base . view SymbolT.name) - . values . maybe empty (unsafePartialView SymbolT.env)) (g.findit tname) + . values . maybe empty (unsafePartialView _Just . _.env')) (g.findit tname) E.logmsg TRACE3 pos (text ("enter1: ClaDcl: vs=" ++ show (map (flip nice g) vs))) foreach (vs) link @@ -239,7 +239,7 @@ enter1InsDcl !fname (!d@InsDcl {pos = !pos}) = do let tname = TName g.thisPack (insName d) ST.enter $ SymbolT.I (SymI {pos=d.pos, vis=d.vis, doc=d.doc, name=tname, - sid=0, clas=fname "", typ=pSigma, env=empty}) + sid=0, clas=fname "", typ=pSigma, meth=empty}) enter (MName tname) d.defs !typ <- U.transSigma d.typ diff --git a/frege/compiler/passes/Final.fr b/frege/compiler/passes/Final.fr index c5d2761c..fd8b3e10 100644 --- a/frege/compiler/passes/Final.fr +++ b/frege/compiler/passes/Final.fr @@ -1,7 +1,7 @@ --- The final compiler pass module frege.compiler.passes.Final where -import frege.compiler.common.Lens (over) +import frege.compiler.common.Lens (over, unsafePartialView) import Data.TreeMap as TM(TreeMap, insert, each) import Compiler.types.Global @@ -49,6 +49,7 @@ cleanSymtab = do -> SymbolT.V symv.{expr = Just (exprFromA sarray eAarray eAarray.[e])} | otherwise -> SymbolT.V symv.{expr = Nothing} + SymbolT.I symi -> SymbolT.I symi.{meth <- fmap (unsafePartialView SymbolT._Meth . symbol . SymMeth.toSymbol)} _ -> over SymbolT.env (fmap symbol) sym swap :: (a,b) -> (b,a) swap (a,b) = (b,a) diff --git a/frege/compiler/passes/GenCode.fr b/frege/compiler/passes/GenCode.fr index af24db43..f434ebb3 100644 --- a/frege/compiler/passes/GenCode.fr +++ b/frege/compiler/passes/GenCode.fr @@ -173,7 +173,7 @@ pass = do liftStG ( mapSt U.fundep vars >>= mapSt U.findV . concat . tsort - >>= mapSt (varCode TreeMap.empty . SymbolT.V)) + >>= mapSt (varCode TreeMap.empty . SymMeth.V)) >>= liftIO . ppDecls g . concat -- generate the class for constants diff --git a/frege/compiler/passes/Imp.fr b/frege/compiler/passes/Imp.fr index d61b70a7..92c1f386 100644 --- a/frege/compiler/passes/Imp.fr +++ b/frege/compiler/passes/Imp.fr @@ -573,7 +573,7 @@ importClassData pos why pack = do name = rebuildQN sym.name, clas = rebuildQN sym.clas, typ = nSigma sym.typ, - env = empty} + meth = empty} rebuildInst n = do let sym = elemAt fp.symis n enter (rbSymI sym) diff --git a/frege/compiler/types/Global.fr b/frege/compiler/types/Global.fr index 523703aa..d0c28a93 100644 --- a/frege/compiler/types/Global.fr +++ b/frege/compiler/types/Global.fr @@ -213,7 +213,7 @@ data Global = !Global { --- find a member of a type, type class or instance findm ∷ Global → QName → String → Maybe Symbol findm g t s = case findit g t of - Just sy | Just env <- preview SymbolT.env sy = env.lookupS s + Just sy | Just env <- sy.env' = env.lookupS s Just (SymbolT.A SymA{typ}) = case instTSym typ g of Just sym | Just r <- findm g (view SymbolT.name sym) s = Just r diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 1ad46775..50a8bdf1 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -56,7 +56,7 @@ data SymC global = !SymC data SymI global = !SymI { sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name ::QName, clas::QName, typ::Sigma, - env::TreeMap String (SymbolT global) + meth::TreeMap String (SymMeth global) } --- variable or function @@ -107,6 +107,31 @@ data SymVal global sid f (D s) = (\sid -> D s.{sid}) <$> f s.sid sid f (V s) = (\sid -> V s.{sid}) <$> f s.sid +--- the type of 'SymI.env' +--- method of a class +data SymMeth global + = --- inherited by super classes + protected L (SymL global) + | --- ordinary members (methods) + protected V (SymV global) + where + toSymbol :: SymMeth g -> SymbolT g + toSymbol (L s) = SymbolT.L s + toSymbol (V s) = SymbolT.V s + fromSymbol :: SymbolT g -> Maybe (SymMeth g) + fromSymbol (SymbolT.L s) = Just (L s) + fromSymbol (SymbolT.V s) = Just (V s) + fromSymbol _ = Nothing + + -- name :: Lens' (SymMeth g) QName + name :: Functor f => (QName -> f QName) -> SymMeth g -> f (SymMeth g) + name f (L s) = (\name -> L s.{name}) <$> f s.name + name f (V s) = (\name -> V s.{name}) <$> f s.name + -- pos :: Lens' (SymMeth g) Position + pos :: Functor f => (Position -> f Position) -> SymMeth g -> f (SymMeth g) + pos f (L s) = (\pos -> L s.{pos}) <$> f s.pos + pos f (V s) = (\pos -> V s.{pos}) <$> f s.pos + {-- The information stored in the 'Symtab' nodes. -} @@ -137,7 +162,7 @@ data SymbolT global = env _ (sym@(L _)) = pure sym env _ (sym@(D _)) = pure sym env f (C s) = (\env -> C s.{env}) <$> f s.env - env f (I s) = (\env -> I s.{env}) <$> f s.env + env _ (sym@(I _)) = pure sym env _ (sym@(V _)) = pure sym env _ (sym@(A _)) = pure sym -- kind :: Traversal' (SymbolT g) Kind @@ -231,6 +256,13 @@ data SymbolT global = vis f (V s) = (\vis -> V s.{vis}) <$> f s.vis vis f (A s) = (\vis -> A s.{vis}) <$> f s.vis + --- a generalized read-only view of 'env' + env' :: SymbolT g -> Maybe (TreeMap String (SymbolT g)) + env' (I s) = Just $ fmap SymMeth.toSymbol s.meth + env' s = preview env s + -- TODO add for performance? + -- envValues' :: SymbolT g -> Maybe [SymbolT g] + -- _T :: Prism' (SymbolT g) (SymT g) _T :: (Choice p, Applicative f) => p (SymT g) (f (SymT g)) -> p (SymbolT g) (f (SymbolT g)) _T = prism' T (\s -> case s of { SymbolT.T x -> Just x; _ -> Nothing; }) @@ -256,6 +288,9 @@ data SymbolT global = -- _Val :: Prism' (SymbolT g) (SymVal g) _Val :: (Choice p, Applicative f) => p (SymVal g) (f (SymVal g)) -> p (SymbolT g) (f (SymbolT g)) _Val = prism' SymVal.toSymbol SymVal.fromSymbol + -- _Meth :: Prism' (SymbolT g) (SymMeth g) + _Meth :: (Choice p, Applicative f) => p (SymMeth g) (f (SymMeth g)) -> p (SymbolT g) (f (SymbolT g)) + _Meth = prism' SymMeth.toSymbol SymMeth.fromSymbol @@ -303,11 +338,15 @@ instance Ord (SymbolT g) where sym1 != sym2 = view SymbolT.sid sym1 != view SymbolT.sid sym2 +instance Positioned (SymMeth g) where + is = is . _.toSymbol + getpos = getpos . _.toSymbol + getrange = getrange . _.toSymbol instance Positioned (SymbolT g) where is x = "" getpos = view SymbolT.pos getrange sym = - case preview SymbolT.env sym of + case sym.env' of Just env -> fold Position.merge (view SymbolT.pos sym) (map getrange (values env)) Nothing -> getpos sym diff --git a/frege/ide/Utilities.fr b/frege/ide/Utilities.fr index 0c831446..4feb563f 100644 --- a/frege/ide/Utilities.fr +++ b/frege/ide/Utilities.fr @@ -10,7 +10,7 @@ import frege.compiler.passes.Imp as I(getFP) import frege.compiler.tc.Util as TC import frege.compiler.Typecheck as TY hiding(pass, post) -import frege.compiler.common.Lens (preview, unsafePartialView, view) +import frege.compiler.common.Lens (_Just, preview, unsafePartialView, view) import Compiler.enums.TokenID(TokenID, defaultInfix) import Compiler.enums.Visibility(Private, Public) @@ -474,7 +474,7 @@ proposeContent !global root !offset !tokens !index = propose [] -> if view SymbolT.name sym == TName pPreludeBase "Bool" then ["true", "false"] else ["_"] - where cons = [ con | SymbolT.D con <- values (unsafePartialView SymbolT.env sym)] + where cons = [ con | SymbolT.D con <- values (unsafePartialView _Just sym.env')] Nothing -> ["_"] -- null cons = ["_"] @@ -515,7 +515,7 @@ proposeContent !global root !offset !tokens !index = propose Just s | ss <- s:U.supersOfNativ s global, -- the supertypes of s (including s) -- traceLn("supertypes are " ++ show ss) || true, - envs <- [ unsafePartialView SymbolT.env sym | s <- ss, + envs <- [ unsafePartialView _Just sym.env' | s <- ss, q <- U.typesOfNativ s global, sym <- global.findit q ] = (true, concatMap (flip envProposal prop) envs) @@ -564,7 +564,7 @@ proposeContent !global root !offset !tokens !index = propose -- get the environment of a symbol, follow type aliases getEnv (Just sym) - | Just env <- preview SymbolT.env sym = Just env + | Just env <- sym.env' = Just env | SymbolT.A (SymA{typ}) <- sym, ForAll bs (RhoTau _ tau) <- typ, TCon{name}:ts <- tau.flat diff --git a/frege/tools/Splitter.fr b/frege/tools/Splitter.fr index 2bc24ee2..219cf39e 100644 --- a/frege/tools/Splitter.fr +++ b/frege/tools/Splitter.fr @@ -551,7 +551,7 @@ symDep g (SymbolT.L SymL{name, alias}) | false = case g.findit alias of Just sym -> nameDep g (symDep g sym) alias Nothing -> empty -symDep g (SymbolT.I SymI{clas, typ, env}) = fold L.union tree (map (symDep g) (values env)) +symDep g (SymbolT.I SymI{clas, typ, meth}) = fold L.union tree (map (symDep g . _.toSymbol) (values meth)) where tree = nameDep g sigt clas sigt = sigmaDep g typ diff --git a/frege/tools/doc/Utilities.fr b/frege/tools/doc/Utilities.fr index 820ef961..592a0bb5 100644 --- a/frege/tools/doc/Utilities.fr +++ b/frege/tools/doc/Utilities.fr @@ -219,18 +219,18 @@ docSym g (SymbolT.C SymC{name,tau,doc,supers,insts,env}) = (code title, content) DL (Just "func") (map (docSym g) members)]], p <- d ] -docSym g (SymbolT.I SymI{pos, name, doc, clas, typ=ForAll _ rho, env}) = (code title, content) where +docSym g (SymbolT.I SymI{pos, name, doc, clas, typ=ForAll _ rho, meth}) = (code title, content) where title = (bold • text $ "instance ") :- dCtx g rho.context :- Label name (text " ") :- dTau g (TApp TCon{pos, name=clas} (TH.tauRho rho).tau) -- tref clas g :- text " " -- dRho g rho [] - members = sortBy (comparing $ view SymbolT.name) (values env) + members = sortBy (comparing $ view SymMeth.name) (values meth) content = [ p | d <- [docit g doc, if null members then [] else [h3 (text "Member Functions"), - DL (Just "func") (map (docSym g) members)]], + DL (Just "func") (map (docSym g . _.toSymbol) members)]], p <- d ] docSym g (SymbolT.T SymT{name, doc, typ=ForAll _ rho, env, nativ, pur}) = (code title, content) where @@ -326,7 +326,7 @@ overloadOf g sym = [ SymbolT.V o ] where symvs sym - | Just env <- preview SymbolT.env sym = [ sv | SymbolT.V sv <- values env ] + | Just env <- sym.env' = [ sv | SymbolT.V sv <- values env ] | SymbolT.V sv <- sym = [sv] | otherwise = [] From 58b9af739e8a08ac498fb112f7342250062e4e4d Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 16:56:46 +0900 Subject: [PATCH 42/95] Change the return type of classMethodOfInstMethod to SymV All of the call sites assume that. --- frege/compiler/common/Trans.fr | 6 +++--- frege/compiler/passes/Easy.fr | 6 ++---- frege/compiler/passes/Strict.fr | 3 +-- 3 files changed, 6 insertions(+), 9 deletions(-) diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index c4ec369c..a16c3dce 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -376,15 +376,15 @@ patsComplete g ps -classMethodOfInstMethod :: Position -> QName -> String -> StG Symbol +classMethodOfInstMethod :: Position -> QName -> String -> StG (SymV Global) classMethodOfInstMethod pos inst base = do g <- getST case g.findit inst of Just isym | SymbolT.I SymI{clas} <- isym = case g.findit clas of Just csym | SymbolT.C SymC{supers} <- csym = do let sym = head [ sym | c <- clas:supers, SymbolT.C SymC{env} <- g.findit c, - sym <- values env, - (view SymbolT.name sym).base == base ] + SymbolT.V sym <- values env, + sym.name.base == base ] return sym other -> E.fatal pos (text ("classMethodOfInstMethod: " ++ nice clas g ++ " not a type class.")) other -> E.fatal pos (text ("classMethodOfInstMethod: " ++ nice inst g ++ " not an instance.")) diff --git a/frege/compiler/passes/Easy.fr b/frege/compiler/passes/Easy.fr index 6c5571f1..5045dba0 100644 --- a/frege/compiler/passes/Easy.fr +++ b/frege/compiler/passes/Easy.fr @@ -105,8 +105,7 @@ easySym (vsym@SymV {pos}) checkDepth :: SymMeth Global -> StG () checkDepth (SymMeth.V (vsym@SymV {pos, name = MName inst base})) = do g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - cmeth <- unsafeToSymV <$> classMethodOfInstMethod pos inst base + cmeth <- classMethodOfInstMethod pos inst base when (cmeth.depth > vsym.depth) do U.symWarning E.hint (SymbolT.V vsym) (msgdoc ( nicer vsym g ++ " has depth " ++ show vsym.depth @@ -117,8 +116,7 @@ checkDepth (SymMeth.V (vsym@SymV {pos, name = MName inst base})) = do return () checkDepth (SymMeth.L (vsym@SymL {pos, alias, name = MName inst base})) = do g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - cmeth <- unsafeToSymV <$> classMethodOfInstMethod pos inst base + cmeth <- classMethodOfInstMethod pos inst base rmeth <- U.findVD alias let d = case rmeth of { SymVal.V SymV{depth} -> depth; _ -> U.arity rmeth.toSymbol; } when (cmeth.depth != d) do diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index e6e893e7..278769ae 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -230,8 +230,7 @@ returnKind syms (sym@SymV {expr = Just dx}) = do let nkind = classMemberState changeSym $ SymbolT.V sym.{rkind=nkind} SymbolT.I _ -> do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - cm <- unsafeToSymV <$> classMethodOfInstMethod sym.pos inst base + cm <- classMethodOfInstMethod sym.pos inst base if cm.rkind.null then do returnKind [] cm returnKind syms sym From e16d1775a6f159c65675ccb758cf265d7ad48682 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 18:37:07 +0900 Subject: [PATCH 43/95] Modify strictReturn to return SymVal strictReturn now uses SymVal (i.e. SymV|SymD) instead of Symbol, removing uses of partial functions. --- frege/compiler/passes/Strict.fr | 50 ++++++++++++++++----------------- frege/compiler/types/Symbols.fr | 12 ++++++++ 2 files changed, 37 insertions(+), 25 deletions(-) diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index 278769ae..9a905624 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -473,7 +473,7 @@ strictName sids nm = do E.logmsg TRACES v.pos (text ("strictness for " ++ v.name.nice g ++ " is " ++ show (S s) ++ " ignoring " - ++ joined ", " (map (flip nice g . view SymbolT.name) syms))) + ++ joined ", " (map (flip nice g . view SymVal.name) syms))) changeSym $ SymbolT.V v.{expr = Just (return x), strsig = S s, state = StrictChecked} stio syms SymV {expr = Just x} | ari >= 0 = do @@ -540,20 +540,20 @@ strictName sids nm = do * the lambda strictness for the arguments * 6. if g is checked recursively, all arguments are strict -} -strictReturn :: Bool -> [Int] -> Expr -> StG (Expr, [Symbol]) +strictReturn :: Bool -> [Int] -> Expr -> StG (Expr, [SymVal Global]) strictReturn notLazy sids x = strictness sids x where - strictness :: [Int] -> Expr -> StG (Expr, [Symbol]) + strictness :: [Int] -> Expr -> StG (Expr, [SymVal Global]) strictness sids x = do g <- getST E.logmsg TRACES (getpos x) (text ("strictness for: " ++ nice x g)) let mine = if x.{env?} then map QName.uid x.env else if x.{pat?} then map Pattern.uid (patVars x.pat) else [] - my = filter ((`elem` mine) . view SymbolT.sid) - them = filter ((`notElem` mine) . view SymbolT.sid) + my = filter ((`elem` mine) . view SymVal.sid) + them = filter ((`notElem` mine) . view SymVal.sid) case x of Vbl {name=Local{}} -> do - v <- fmap SymbolT.V $ U.findV x.name + v <- fmap SymVal.V $ U.findV x.name E.logmsg TRACES (getpos x) (text ("strictness " ++ nice x g ++ " :: " ++ names g [v])) stio (x, if notLazy then [v] else []) Vbl {name} -> do @@ -575,7 +575,7 @@ strictReturn notLazy sids x = strictness sids x where (filter ((`notElem` sids) • QName.uid) env) (ex, syms) <- strictness sids ex let strictSyms = my syms - sSsids = map (view SymbolT.sid) strictSyms + sSsids = map (view SymVal.sid) strictSyms upper = [ sres | (loc, sres) <- zip env results, QName.uid loc `elem` sSsids ] result = fold uni (them syms) upper @@ -620,10 +620,10 @@ strictReturn notLazy sids x = strictness sids x where E.fatal (getpos x) (text ("no strictness rule, turn on -xs -xr " ++ show (getpos x))) stio (x, []) where - names g = show . map (flip QName.nice g . view SymbolT.name) - inter as = filter (\b -> elemBy (using $ view SymbolT.sid) b as) - uni :: [Symbol] -> [Symbol] -> [Symbol] - uni as bs = as ++ [ b | b <- bs, not (elemBy (using $ view SymbolT.sid) b as)] + names g = show . map (flip QName.nice g . view SymVal.name) + inter as = filter (\b -> elemBy (using $ view SymVal.sid) b as) + uni :: [SymVal Global] -> [SymVal Global] -> [SymVal Global] + uni as bs = as ++ [ b | b <- bs, not (elemBy (using $ view SymVal.sid) b as)] maxss (S s1) (S s2) = S (zipWith maxss s1 s2) maxss U s = s maxss s _ = s @@ -638,10 +638,11 @@ strictReturn notLazy sids x = strictness sids x where -- mark a symbol as strict + mark :: SymVal Global -> StG () mark sym = do g <- getST - E.logmsg TRACES (view SymbolT.pos sym) (text (nice (view SymbolT.name sym) g ++ " marked as strict")) - when (unsafePartialView SymbolT.strsig sym == U) do changeSym $ set SymbolT.strsig (S[]) sym + E.logmsg TRACES (view SymVal.pos sym) (text (nice (view SymVal.name sym) g ++ " marked as strict")) + when (view SymVal.strsig sym == U) do changeSym $ SymVal.toSymbol $ set SymVal.strsig (S[]) sym -- strictness for case alternative, same as in lambda strictAlt (alt@CAlt {pat,ex}) = do (lam, syms) <- strictness sids (Lam {pat,ex,typ=Nothing}) @@ -676,18 +677,18 @@ strictReturn notLazy sids x = strictness sids x where appstr (app@((f,mbt):as)) = do g <- getST v <- case f of - Con {name} -> fmap SymbolT.D $ U.findD name - Vbl {name} -> fmap SymbolT.V $ U.findV name + Con {name} -> fmap SymVal.D $ U.findD name + Vbl {name} -> fmap SymVal.V $ U.findV name _ -> E.fatal (getpos f) (text ("Can't handle " ++ nice f g ++ " applications")) - let fsym | Local {} <- view SymbolT.name v = [v] + let fsym | Local {} <- view SymVal.name v = [v] | otherwise = [] mkAll = do fapp <- mapSt (strictness sids) (map fst app) let napp = zip (map fst fapp) (map snd app) stio (napp, fsym) case v of - SymbolT.V (SymV{state = Typechecked, expr = Nothing}) = mkAll - SymbolT.V (symv@SymV{state = Typechecked, expr = Just _}) + SymVal.V (SymV{state = Typechecked, expr = Nothing}) = mkAll + SymVal.V (symv@SymV{state = Typechecked, expr = Just _}) | Just (Lam{}) <- symv.gExpr g = if symv.sid `elem` sids then do -- assume all are strict @@ -696,7 +697,7 @@ strictReturn notLazy sids x = strictness sids x where else do strictName sids symv.name appstr app -- repeat - Symbol.V (symv@SymV{state = Typechecked, expr = Just dx}) + SymVal.V (symv@SymV{state = Typechecked, expr = Just dx}) | symv.sid `notElem` sids = do -- inline pointless x <- dx @@ -705,22 +706,21 @@ strictReturn notLazy sids x = strictness sids x where let as = drop (length fx) fxas stio ((f,mbt):as, fsym ++ syms) | otherwise = mkAll - SymbolT.D SymD{strsig = U} -> mkAll - SymbolT.D SymD{strsig = S ss} -> do + SymVal.D SymD{strsig = U} -> mkAll + SymVal.D SymD{strsig = S ss} -> do let xss = take (length as) (ss ++ repeat U) -- make sure enough exsyms <- mapSt subapp (zip (map fst as) xss) stio ((f,mbt):zip (map fst exsyms) (map snd as), fold uni fsym (map snd exsyms)) - SymbolT.V SymV{state = StrictChecked, strsig = U} -> mkAll - SymbolT.V (symv@SymV{state = StrictChecked, strsig = S ss}) -> do + SymVal.V SymV{state = StrictChecked, strsig = U} -> mkAll + SymVal.V (symv@SymV{state = StrictChecked, strsig = S ss}) -> do let xss = take (length as) (ss ++ repeat U) -- make sure enough E.logmsg TRACES (getpos f) (text ("appstr: xss=" ++ show xss ++ " for " ++ symv.name.nice g)) exsyms <- mapSt subapp (zip (map fst as) xss) stio ((f,mbt):zip (map fst exsyms) (map snd as), fold uni fsym (map snd exsyms)) - SymbolT.V symv -> do + SymVal.V symv -> do E.fatal symv.pos (text ("appstr: unexpected symbol " ++ nice v g ++ ", state=" ++ show symv.state ++ ", expr=" ++ show (isJust symv.expr))) - _ -> error "appstr: no appropriate sym" appstr _ = error "appstr: []" diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 50a8bdf1..670f01f3 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -102,10 +102,22 @@ data SymVal global fromSymbol (SymbolT.V s) = Just (V s) fromSymbol _ = Nothing + -- name :: Lens' (SymVal g) QName + name :: Functor f => (QName -> f QName) -> SymVal g -> f (SymVal g) + name f (D s) = (\name -> D s.{name}) <$> f s.name + name f (V s) = (\name -> V s.{name}) <$> f s.name + -- pos :: Lens' (SymVal g) Position + pos :: Functor f => (Position -> f Position) -> SymVal g -> f (SymVal g) + pos f (D s) = (\pos -> D s.{pos}) <$> f s.pos + pos f (V s) = (\pos -> V s.{pos}) <$> f s.pos -- sid :: Lens' (SymVal g) Int sid :: Functor f => (Int -> f Int) -> SymVal g -> f (SymVal g) sid f (D s) = (\sid -> D s.{sid}) <$> f s.sid sid f (V s) = (\sid -> V s.{sid}) <$> f s.sid + -- strsig :: Lens' (SymVal g) Strictness + strsig :: Functor f => (Strictness -> f Strictness) -> SymVal g -> f (SymVal g) + strsig f (D s) = (\strsig -> D s.{strsig}) <$> f s.strsig + strsig f (V s) = (\strsig -> V s.{strsig}) <$> f s.strsig --- the type of 'SymI.env' --- method of a class From cab842a5c079a5f8821a801fd5731a12ab2eb87f Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 18:45:16 +0900 Subject: [PATCH 44/95] Add findMain, specialized to find the main function The call sites assumed (VName g.thisPack "main") pointed to a SymV (as it should be). It is now guaranteed by the type. --- frege/compiler/Typecheck.fr | 30 +++++++++++++++++++++--------- 1 file changed, 21 insertions(+), 9 deletions(-) diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index b9d62637..31d7fac7 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -199,6 +199,16 @@ mainSigma = ForAll [] mainSimple (ForAll xs RhoFun{rho}) = ForAll xs rho mainSimple sigma = sigma +findMain :: StG (Maybe (SymV Global)) +findMain = do + g <- getST + case g.findit (VName g.thisPack "main") of + Just (SymbolT.V symv) -> pure $ Just symv + Nothing -> pure Nothing + -- main must be SymV, so this always throws an error. + -- reuse the error message + Just sym -> fmap Just $ findV (VName g.thisPack "main") + {-- * make sure that, for example, @main _ = return ()@ is not rejected later because of * inferred type @forall a m Monad m . a -> m ()@ @@ -213,8 +223,9 @@ mainSimple sigma = sigma -} annotateMain = do g <- getST - case g.findit (VName g.thisPack "main") of - Just (SymbolT.V sym) + msym <- findMain + case msym of + Just sym | sym.name.pack == g.thisPack , Just dx <- sym.expr , not sym.anno -> do @@ -228,18 +239,19 @@ annotateMain = do checkMain = do g <- getST tau <- Util.newMeta2 ("a", KType) - case g.findit (VName g.thisPack "main") of - Just sym | (view SymbolT.name sym).pack == g.thisPack -> do - let m = Vbl {pos = view SymbolT.pos sym, name = view SymbolT.name sym, typ = Just pSigma} + msym <- findMain + case msym of + Just sym | sym.name.pack == g.thisPack -> do + let m = Vbl {pos = sym.pos, name = sym.name, typ = Just pSigma} sigma - | RhoFun{} <- (unsafePartialView SymbolT.typ sym).rho = mainSigmaA tau + | RhoFun{} <- sym.typ.rho = mainSigmaA tau | otherwise = mainSimple (mainSigmaA tau) checkAnnotated m sigma gnew <- getST when (g.errors < gnew.errors) do - E.error (view SymbolT.pos sym) (msgdoc ("The main function must have type " ++ nicer sigma g)) - when (g.errors == gnew.errors && not (null (unsafePartialView SymbolT.typ sym).rho.context)) do - E.error (view SymbolT.pos sym) (msgdoc ("The main function type must not have type class constraints.")) + E.error sym.pos (msgdoc ("The main function must have type " ++ nicer sigma g)) + when (g.errors == gnew.errors && not (null sym.typ.rho.context)) do + E.error sym.pos (msgdoc ("The main function type must not have type class constraints.")) _ -> stio () -- type check one group after the other as long as there are fewer than 7 errors -- checkgroups [] = stio () From e31e3d2e674c902390e11db1182cf029cc4be48b Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 19:09:02 +0900 Subject: [PATCH 45/95] Use SymVal in substInst --- frege/compiler/Typecheck.fr | 24 +++++++++++------------- frege/compiler/types/Symbols.fr | 4 ++++ 2 files changed, 15 insertions(+), 13 deletions(-) diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index 31d7fac7..ff788124 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -480,30 +480,28 @@ substInst (vbl@Vbl {pos, name = MName tn bs, typ = Just (ForAll [] rho)}) {- | MName iname bs != qname -} -> do mem <- findV vbl.name case g.findit (MName iname bs) of - Just imem -> do + Just imem' | Just imem <- SymVal.fromSymbol imem' -> do let nrho = rho.{context <- filter (not • sameCtx ctx)} strho = substRho - (unifySigma g (unsafePartialView SymbolT.typ imem) ForAll{bound=[], rho=nrho}) - (unsafePartialView SymbolT.typ imem).rho - !repl | SymbolT.V _ <- imem = vbl.{name=view SymbolT.name imem, - typ = Just (ForAll [] strho)} - | SymbolT.D _ <- imem = Con{pos=vbl.pos, - name=view SymbolT.name imem, - typ = Just (ForAll [] strho)} - | otherwise = error ("substInst WTF??? : " ++ nicer imem g) + (unifySigma g (view SymVal.typ imem) ForAll{bound=[], rho=nrho}) + (view SymVal.typ imem).rho + !repl = case imem of + SymVal.V _ -> vbl.{name=view SymVal.name imem, typ = Just (ForAll [] strho)} + SymVal.D _ -> Con{pos=vbl.pos, name=view SymVal.name imem, typ = Just (ForAll [] strho)} E.logmsg TRACEO pos ( text ("replace " ++ vbl.name.nice g) nest 4 ( text (":: " ++ vbl.typ.nicer g) text ("sigma :: " ++ mem.typ.nicer g) - text ("with " ++ (view SymbolT.name imem).nice g) - <+> text (" :: " ++ (unsafePartialView SymbolT.typ imem).nicer g) + text ("with " ++ (view SymVal.name imem).nice g) + <+> text (" :: " ++ (view SymVal.typ imem).nicer g) text ("@@ " ++ nrho.nicer g) text ("?? " ++ strho.nicer g))) changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk vbl.pos.first) (Right (view SymbolT.name imem))}} - weUse (view SymbolT.name imem) + idKind <- insert (KeyTk vbl.pos.first) (Right (view SymVal.name imem))}} + weUse (view SymVal.name imem) stio (Left repl) + Just wtf -> error ("substInst WTF??? : " ++ nicer wtf g) Nothing -> E.fatal vbl.pos (msgdoc ("substInst: trying " ++ nice vbl g ++ ", but " ++ nice (MName iname bs) g diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 670f01f3..2617997d 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -118,6 +118,10 @@ data SymVal global strsig :: Functor f => (Strictness -> f Strictness) -> SymVal g -> f (SymVal g) strsig f (D s) = (\strsig -> D s.{strsig}) <$> f s.strsig strsig f (V s) = (\strsig -> V s.{strsig}) <$> f s.strsig + -- typ :: Lens' (SymVal g) Sigma + typ :: Functor f => (Sigma -> f Sigma) -> SymVal g -> f (SymVal g) + typ f (D s) = (\typ -> D s.{typ}) <$> f s.typ + typ f (V s) = (\typ -> V s.{typ}) <$> f s.typ --- the type of 'SymI.env' --- method of a class From 23933ec0e4ed116694fff82f725294d77d32f480 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 19:33:06 +0900 Subject: [PATCH 46/95] Use SymV in rHas --- frege/compiler/Typecheck.fr | 42 ++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index ff788124..e6cebe0d 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -1396,10 +1396,10 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do sym <- U.findV name case sym.over of [] -> return (Right v) - _ -> resolveOver v $ SymbolT.V sym + _ -> resolveOver v sym where -- resolve overloaded variable - resolveOver :: Expr -> Symbol -> StG (Expr|Expr) + resolveOver :: Expr -> SymV Global -> StG (Expr|Expr) resolveOver v sym = do g <- getST let sigma = (unJust v.typ) @@ -1408,11 +1408,11 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do let candidates = overloads g sym groups - | MName{} <- view SymbolT.name sym = groupBy (using (QName.tynm . view SymbolT.name)) candidates + | MName{} <- sym.name = groupBy (using (QName.tynm . _.name)) candidates | otherwise = [candidates] E.logmsg TRACET v.pos (text ("by " - ++ joined ", " (map (flip nice g . view SymbolT.name) candidates))) + ++ joined ", " (map (flip nice g . _.name) candidates))) checked <- mapM (resolve v.pos sigma) groups case filter (not . null) checked of @@ -1426,36 +1426,36 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do <+> text " cannot be resolved at type " <+/> text (nicer sigma g)) return (Right v) - ms:_ -> case sortBy (comparing arity) ms of -- compare b arity to find + ms:_ -> case sortBy (comparing arityV) ms of -- compare b arity to find -- the one that fits - cs → case filter ((arity (head cs) ==) . arity) cs of -- remove the ones that don't + cs -> case filter ((arityV (head cs) ==) . arityV) cs of -- remove the ones that don't some -> do when (length some > 1) do E.warn v.pos (text "overloaded `" <> text (nicer v g) <> text "´ is ambiguous at type " <+/> text (nicer sigma g) text "It could mean one of " - stack [ text (nicer (view SymbolT.name s) g) + stack [ text (nicer s.name g) <+> text " :: " - <+> text (nicer (unsafePartialView SymbolT.typ s) g) + <+> text (nicer s.typ g) | s <- some ]) let s = head some diag = if length some > 1 then E.warn else E.explain diag v.pos (msgdoc ("overloaded " ++ nicer v.name g ++ " :: " ++ nicer sigma g ++ " resolved to " - ++ nicer (view SymbolT.name s) g)) - x <- checkSigma Vbl{pos=v.pos, name=view SymbolT.name s, typ=Nothing} sigma + ++ nicer s.name g)) + x <- checkSigma Vbl{pos=v.pos, name=s.name, typ=Nothing} sigma changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk v.pos.first) (Right (view SymbolT.name s))}} + idKind <- insert (KeyTk v.pos.first) (Right s.name)}} return (Right x) where - resolve ∷ Position → Sigma → [Symbol] → StG [Symbol] - resolve pos sigma [] = return [] + resolve :: Position -> Sigma -> [SymV Global] -> StG [SymV Global] + resolve _ _ [] = return [] resolve pos sigma (sym:syms) = do g1 <- getST changeST Global.{options <- Options.{flags <- flagSet OVERLOADING}} - x <- checkSigma Vbl{pos, name=view SymbolT.name sym, typ=Nothing} sigma + x <- checkSigma Vbl{pos, name=sym.name, typ=Nothing} sigma g <- getST putST g1 if (g.errors > g1.errors) @@ -1463,19 +1463,19 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do else do rs <- resolve pos sigma syms return (sym:rs) - overloads ∷ Global → Symbol → [Symbol] + overloads :: Global -> SymV Global -> [SymV Global] overloads g sym = case sym of - SymbolT.V SymV{over=[]} -> [sym] - SymbolT.V SymV{name = MName{tynm, base}, over=over@(_:_)} + SymV{over=[]} -> [sym] + SymV{name = MName{tynm, base}, over=over@(_:_)} | Just (SymbolT.T SymT{nativ = Just this}) <- g.findit tynm, - ov <- [ sy | m <- over, sy <- g.findit m ], + ov <- [ sy | m <- over, SymbolT.V sy <- g.findit m ], syms <- [ sy | s <- U.supersOfNativ this g, q <- U.typesOfNativ s g, - h <- g.findit (MName q base), + SymbolT.V h <- g.findit (MName q base), sy <- overloads g h] = ov++syms - SymbolT.V SymV{over} -> [ sy | m <- over, sy <- g.findit m] - _ -> [] + SymV{over} -> [ sy | m <- over, SymbolT.V sy <- g.findit m ] + arityV = arity . SymbolT.V rHas _ x = pure (Left x) From aaf425ddc45154fe3b5f4735dc884b0e424e25ef Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 19:39:25 +0900 Subject: [PATCH 47/95] Modify passC.methodcheck to take SymMeth Its partialness remains same. --- frege/compiler/Classes.fr | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index 5c9dde72..6582d4c4 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -157,7 +157,7 @@ passC = do changeSym $ SymbolT.C symc.{tau <- Tau.{kind = newkind}} -- update class var symc <- U.findC symc.name foreach symc.supers (supercheck $ SymbolT.C symc) - foreach (values symc.env) (methodcheck symc) + foreach (values symc.env) (methodcheck symc . unsafePartialView SymbolT._Meth) nothing -> E.fatal Position.null (text ("lost class " ++ QName.nice qcls g)) superKind symc ka (SymbolT.C supb) = do case K.unifyKind ka supb.tau.kind of @@ -199,8 +199,8 @@ passC = do Nothing -> return kind -- no class var? will be flagged later sigmaKind _ _ _ = error "sigmaKind: no SymV" - methodcheck :: SymC Global -> Symbol -> StG () - methodcheck symc (SymbolT.V (msym@SymV {pos})) = do + methodcheck :: SymC Global -> SymMeth Global -> StG () + methodcheck symc (SymMeth.V (msym@SymV {pos})) = do g <- getST let jprevs = [ g.findit (MName sup msym.name.base) | sup <- symc.supers ] xprevs = [ symv | Just (SymbolT.V symv) <- jprevs, symv.anno || isJust symv.nativ ] @@ -232,7 +232,7 @@ passC = do changeSym $ SymbolT.V msym.{typ = memtyp, anno = true} nothing -> E.fatal pos (text ("methodcheck: class " ++ osym.name.tynm.nice g ++ " vanished.")) _ -> E.fatal pos (text (msym.name.nice g ++ " occurs in more than one super class of " ++ symc.name.nice g)) - methodcheck symc (SymbolT.L (msym@SymL{pos})) = do + methodcheck symc (SymMeth.L (msym@SymL{pos})) = do g <- getST let jprevs = [ g.findit (MName sup msym.name.base) | sup <- symc.supers ] prevs = [ p | Just (SymbolT.V p) <- jprevs, p.anno ] @@ -251,9 +251,6 @@ passC = do _ -> E.fatal pos (text (msym.name.nice g ++ " occurs in more than one super class of " ++ symc.name.nice g)) - methodcheck symc other = do - g <- getST - E.error (view SymbolT.pos other) (text (other.nice g ++ " not allowed in " ++ symc.nice g)) {- mkanno class method supermethod superclass * replace forall c . Super c => c -> t * with forall t.This t => t -> n From 1fdcc0c7d91ed745786f4de85808e7b6eba0f91e Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 19:41:39 +0900 Subject: [PATCH 48/95] Assume SymV in isEasy.Let I'm pretty sure that (Let.env :: [QName]) points to SymVs only. --- frege/compiler/common/Trans.fr | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index a16c3dce..dbcbcaa5 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -99,8 +99,7 @@ isEasy :: Global -> Expr -> Bool isEasy g (App a b _) = isSimple g a && isSimple g b isEasy g (Let {env,ex}) = isEasy g ex && all (isEasy g) xprs where - xprs = [ ex | q <- env, sym <- g.findit q, ex <- (unsafeToSymV sym).gExpr g] - unsafeToSymV s = case s of { SymbolT.V x -> x; } + xprs = [ ex | q <- env, SymbolT.V sym <- g.findit q, ex <- sym.gExpr g ] isEasy g (Case {ex,alts}) = isSimple g ex && all (isEasy g • _.ex) alts isEasy g (Ifte a b c _) = isSimple g a && isEasy g b && isEasy g c From d698fae7ac9a0f23425a2c5ad58e6524fd0ff626 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 19:45:06 +0900 Subject: [PATCH 49/95] Assume SymV in etaExpand.cleanVarType I think Vbl.name refers to a SymV. --- frege/compiler/common/Trans.fr | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index dbcbcaa5..06379aae 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -467,10 +467,10 @@ etaExpand x = case x.typ of -- all other expressions -- see also #294 cleanVarType g (v@Vbl{pos, name, typ = Just sigma}) | not (null sigma.rho.context) = case g.findit name of - Just sym → v.{typ = Just vtyp} + Just (SymbolT.V sym) -> v.{typ = Just vtyp} where - subst = unifySigma g (unsafePartialView SymbolT.typ sym) sigma - vtyp = ForAll [b | b ← (unsafePartialView SymbolT.typ sym).bound, not (TM.member b.var subst)] (T.substRho subst (unsafePartialView SymbolT.typ sym).rho) + subst = unifySigma g sym.typ sigma + vtyp = ForAll [b | b <- sym.typ.bound, not (TM.member b.var subst)] (T.substRho subst sym.typ.rho) other → error ("etaExpand: variable not found:" ++ nicer name g) cleanVarType g novar = novar From 17905bdaf79e4585aeae836368a6fd411b2b9337 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 19:54:07 +0900 Subject: [PATCH 50/95] Change the type of Global.genEnv to [SymV Global] Only SymV were pushed into genEnv. Partial functions at some of the call sites were eliminated. --- frege/compiler/gen/java/Common.fr | 5 ++--- frege/compiler/gen/java/InstanceCode.fr | 2 +- frege/compiler/gen/java/Instantiation.fr | 7 +++---- frege/compiler/gen/java/VarCode.fr | 24 ++++++++++++------------ frege/compiler/types/Global.fr | 2 +- 5 files changed, 19 insertions(+), 21 deletions(-) diff --git a/frege/compiler/gen/java/Common.fr b/frege/compiler/gen/java/Common.fr index 3d40a6f1..cc33e77a 100644 --- a/frege/compiler/gen/java/Common.fr +++ b/frege/compiler/gen/java/Common.fr @@ -655,15 +655,14 @@ memNames = xxxNames "mem" getArgs ∷ Global → [String] getArgs g = drop used argNames where - used = sum (map unsafeGetDepth g.genEnv) - unsafeGetDepth (SymbolT.V SymV{depth}) = depth + used = sum (map _.depth g.genEnv) --- Compute a list of context names we can use for a new function --- This drops the ones from 'ctxNames' that are currently used in outer scopes. getCtxs ∷ Global -> [String] getCtxs g = drop used ctxNames where - used = sum . map (length . _.context . _.rho . unsafePartialView SymbolT.typ) $ g.genEnv + used = sum . map (length . _.context . _.rho . _.typ) $ g.genEnv {-- @makeConstraintDef (Ctx cname tau) "ctx3"@ = final Ccname ctx3 diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index a2326681..e283f82f 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -504,7 +504,7 @@ instFun symc symi mname = do | (uid, sig, atom, jt) ← zip4 uids sigs atoms rgargs, ex = JCast (lazy jt) (JCast Something atom) ] | otherwise = binds - result ← compiling (SymbolT.V sym.{typ=fakety}) (genExpr true retJT ex rawbinds) + result <- compiling sym.{typ=fakety} (genExpr true retJT ex rawbinds) let rex | special, retJTr != retJT = JCast retJTr (JCast Something result.jex) | otherwise = result.jex diff --git a/frege/compiler/gen/java/Instantiation.fr b/frege/compiler/gen/java/Instantiation.fr index ef2f9b81..2ed1c2d7 100644 --- a/frege/compiler/gen/java/Instantiation.fr +++ b/frege/compiler/gen/java/Instantiation.fr @@ -3,8 +3,6 @@ module frege.compiler.gen.java.Instantiation where import frege.Prelude hiding(<+>) -import frege.compiler.common.Lens (unsafePartialView) - import Lib.PP(text, <+>, <>, <+>, <+/>) import Data.TreeMap(member) @@ -34,8 +32,9 @@ import Compiler.gen.java.Common import Compiler.gen.java.Bindings -envCtxs g = [ ctx | s <- reverse (Global.genEnv g), - ctx <- (unsafePartialView SymbolT.typ s).rho.context ] +envCtxs :: Global -> [Context] +envCtxs g = [ ctx | s <- reverse g.genEnv + , ctx <- s.typ.rho.context ] --- takes a list of contexts and returns the ones that are resolvable resolvableCtxs ∷ Global → [Context] → [Context] diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index 9c1756f3..4864a4c8 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -150,7 +150,7 @@ topFun (sym@SymV {expr = Just dx}) binds = do -- abinds = map (arg2Bind g) strictArgs -- ctxs = map (\(_,_,_,ctx) -> JAtom ctx) ctxArgs - stmts ← compiling (SymbolT.V sym) (genFunction sym si.returnJT methArgs binds) + stmts ← compiling sym (genFunction sym si.returnJT methArgs binds) let worker = JMethod {attr, gvars = targs g sym.typ, @@ -207,7 +207,7 @@ localFun (sym@SymV {expr = Just dx}) binds = do methArgs = argDefs argAttr si argNames methName = (javaName g sym.name).base - stmts ← compiling (SymbolT.V sym) (genFunction sym si.returnJT methArgs binds) + stmts ← compiling sym (genFunction sym si.returnJT methArgs binds) let worker = JMethod {attr = attrs [JFinal, JPublic], gvars = targs g sym.typ, @@ -268,7 +268,7 @@ innerFun (SymbolT.V (sym@SymV {expr = Just dx})) binds = do text "This is probably a compiler error you should report." ) ex ← dx - stmts ← compiling (SymbolT.V symx) (genLambda (lazy . last . _.gargs $ funcjt) ex methArgs binds) + stmts ← compiling symx (genLambda (lazy . last . _.gargs $ funcjt) ex methArgs binds) let !lambda = JLambda{fargs=methArgs, code=Right JBlock{stmts}} !member = JMember{attr = attrFinal, @@ -327,7 +327,7 @@ cafCode (sym@SymV {name, depth = 0, expr = Just dx}) binds = do if not inmethod && rsimple && not self then do - ecode ← compiling (SymbolT.V sym) (genExpr false rtype x binds) + ecode ← compiling sym (genExpr false rtype x binds) pure (comments ++ [ -- T foo = .... JMember { attr = attrTop, jtype = rtype, name = name.base, @@ -339,7 +339,7 @@ cafCode (sym@SymV {name, depth = 0, expr = Just dx}) binds = do jthrow = [JThrow (JNew (Ref (JName "frege.runtime" "GuardFailed") []) [ JAtom (show (nicer sym g)), JAtom (show sym.pos)])] - code <- compiling (SymbolT.V sym) (genReturn stype x binds) + code <- compiling sym (genReturn stype x binds) case badguard of Just (Left x) -> do E.warn (getpos x) (text "guard (" <> (nicest g x) <> text ") may evaluate to false.") @@ -405,7 +405,7 @@ innerCaf sym binds mutual = do run @action@ with @symbol@ in the current compiling environment -} -compiling ∷ Symbol → StG 𝖆 → StG 𝖆 +compiling :: SymV Global -> StG a -> StG a compiling sym action = do changeST Global.{genEnv ← (sym:)} r ← action @@ -452,7 +452,7 @@ genLambda rm (Lam {pat, ex}) ((arg@(_, _, _, s)) : args) binds = do badguard = openCaseWhen g ex assert = isNothing komplett -- mustthrow = not assert && isNothing badguard - margs = map JAtom [show ((view SymbolT.name (last g.genEnv)).nice g), + margs = map JAtom [show ((last g.genEnv).name.nice g), show (getpos pat)] ++ [JAtom s] -- construct new NoMatch("Module.foo", 42, arg$1) jthrow = [JThrow (JNew jtNoMatch margs)] @@ -546,7 +546,7 @@ genStmts jret rm ex binds App _ _ _ | Vbl {name}:args <- map fst (flatx ex), Just (SymbolT.V (sym@SymV{sid})) <- g.findit name, - sid == view SymbolT.sid (head g.genEnv), + sid == (head g.genEnv).sid, length args == sym.depth = do -- tail call let argNames = map (++"f") @@ -707,7 +707,7 @@ genCaseStmt jret rm (x@Case {ckind,ex=cex,alts=calts}) binds = do pure (jthrow arg) | otherwise = pure [] -- no throw needed - throwargs exb = map JAtom [show ((view SymbolT.name (Prelude.last g.genEnv)).nice g), + throwargs exb = map JAtom [show ((Prelude.last g.genEnv).name.nice g), show (getpos x)] ++ [Binding.jex exb] jthrow exb = [JThrow (JNew jtNoMatch (throwargs exb))] @@ -1042,7 +1042,7 @@ etaWrap ex sigs binds (rm@Func{gargs}) = do gs -> Func gs fake = (U.patLocal (getpos ex) 0 "\\lambda").{depth=a,typ=ft} mapM_ (SymTab.enter . SymbolT.V) syms - call ← compiling (SymbolT.V fake) (genExpr false subrm nex newbinds) + call ← compiling fake (genExpr false subrm nex newbinds) let lambda = JCast (boxed rm) JLambda{fargs = cargs ++ fargs, code} apply | n > a+length cargs = JInvoke (JX.xmem "apply" call.jex) (drop (n-a-length cargs) atoms) @@ -1095,7 +1095,7 @@ wrapHigher rflg ex binds tctxs sigma = do <+/> text " :: " <+> text (nice sigma g) <+/> text " @@ " <+> text (show jfunc) <+/> text (nicerctx tctxs g)) - body <- compiling (SymbolT.V fakesym) (genExpr rflg innerjt ex binds) + body <- compiling fakesym (genExpr rflg innerjt ex binds) let eval = JLambda{fargs, code = Right JBlock{stmts=map JLocal assigns ++ [JReturn body.jex]}} pure (newBind g sigma (JCast jfunc eval)).{jtype = jfunc} @@ -1703,7 +1703,7 @@ genExpr rflg rm ex binds = do grm = lazy $ case drop n gargs of [x] → x ys → Func ys - stmts <- compiling (SymbolT.V fake) (genLambda grm ex args binds) + stmts <- compiling fake (genLambda grm ex args binds) let jlam = JLambda{fargs=args, code = Right JBlock{stmts}} result (newBind g ft (JCast (boxed rm) jlam)).{jtype = boxed rm} diff --git a/frege/compiler/types/Global.fr b/frege/compiler/types/Global.fr index d0c28a93..25fede0a 100644 --- a/frege/compiler/types/Global.fr +++ b/frege/compiler/types/Global.fr @@ -136,7 +136,7 @@ data Global = !Global { packages :: TreeMap Pack Symtab --- map packages to symbol table namespaces :: TreeMap NSName Pack --- map namespaces to packages javaEnv :: TreeMap String ([String],[QName]) --- names of supertypes and types that implement a certain java type - genEnv :: [Symbol] --- symbols of function that is being compiled + genEnv :: [SymV Global] --- symbols of function that is being compiled locals :: TreeMap Int (SymV Global) --- local ids identified by name typEnv :: [QName] --- names of functions being type checked tySubst :: TreeMap Int Tau --- substitutions for type variables From e868594c1a530e2bec7db605083c98eb83424d4f Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 21:45:08 +0900 Subject: [PATCH 51/95] Assume the return type of instTSym and instTauSym to be SymT AFAICS almost all of the calling sites assume the return value is SymT. --- frege/compiler/Classes.fr | 4 ++-- frege/compiler/Typecheck.fr | 4 ++-- frege/compiler/Utilities.fr | 2 +- frege/compiler/gen/java/InstanceCode.fr | 4 ++-- frege/compiler/passes/Enter.fr | 4 +--- frege/compiler/passes/Instances.fr | 4 ++-- frege/compiler/tc/Methods.fr | 8 ++++---- frege/compiler/types/Global.fr | 14 +++++++------- frege/ide/Utilities.fr | 22 +++++++++++----------- 9 files changed, 32 insertions(+), 34 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index 6582d4c4..bfd6bf7e 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -392,7 +392,7 @@ instForClass alien c iname = do isym <- U.findI iname case instTSym isym.typ g of - Just (SymbolT.T (tsym@SymT{pos})) -> do + Just tsym -> do E.logmsg TRACE6 isym.pos (text (isym.nice g ++ " " ++ tsym.nice g)) when (not alien || g.our isym.name) do @@ -403,7 +403,7 @@ instForClass alien c iname = do csyms <- mapSt U.findC (csym.name:csym.supers) isym <- U.findI isym.name when (not alien || g.our isym.name) do tcInstMethods csyms isym - mu -> E.fatal isym.pos (text ("instForClass: bad instance type " ++ isym.typ.nice g)) + Nothing -> E.fatal isym.pos (text ("instForClass: bad instance type " ++ isym.typ.nice g)) {-- When we have diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index e6cebe0d..c4f45247 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -474,7 +474,7 @@ substInst (vbl@Vbl {pos, name = MName tn bs, typ = Just (ForAll [] rho)}) case instTauSym tau g of Just symt -> do -- we have a type name symc <- findC tn -- must be a class because it appears in a contexts cname - case filter ((view SymbolT.name symt ==) • fst) symc.insts of -- find instance + case filter ((symt.name ==) • fst) symc.insts of -- find instance [] -> E.fatal pos (text (symc.nice g ++ " has no instance for " ++ symt.nice g)) [(_,iname)] {- | MName iname bs != qname -} -> do @@ -1079,7 +1079,7 @@ tcRho' (x@Mem {ex,member}) ety = do else member case instTauSym tau g of - Just (SymbolT.T SymT{name, env, nativ, newt}) + Just (SymT{name, env, nativ, newt}) | Just (SymbolT.V (SymV{name})) <- env.lookup member.value = do changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk original) (Right name)}} diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index 38e9f002..bc0dafa8 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -1073,7 +1073,7 @@ isException g _ = Nothing type _ty_ denotes a sub type of @java.lang.Throwable@ -} isThrowable g ty = case instTauSym ty g of - Just (SymbolT.T SymT{nativ=Just x}) -> x == "java.lang.Throwable" + Just (SymT{nativ=Just x}) -> x == "java.lang.Throwable" || "java.lang.Throwable" `elem` supersOfNativ x g other -> false diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index e283f82f..2d929928 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -212,7 +212,7 @@ instanceCode (SymbolT.I sym) = do -- instance definition -- links in types that point to instance members of this class and its superclasses -- The goal is to have (links to) implementations of all super class methods. methods2 = case instTSym sym.typ g of - Just (SymbolT.T tsym) -> [ alias | + Just tsym -> [ alias | SymbolT.L SymL{name, alias} <- values tsym.env, alias.{tynm?}, -- links alias `notElem` methods1, -- avoid duplicates @@ -225,7 +225,7 @@ instanceCode (SymbolT.I sym) = do -- instance definition methods1 = map (view SymMeth.name) (values sym.meth) -- methods of super classes that are implemented in the type itself methods3 = case instTSym sym.typ g of - Just (SymbolT.T tsym) -> [ view SymbolT.name sym | + Just tsym -> [ view SymbolT.name sym | sym <- values tsym.env, (view SymbolT.name sym).base `elem` superMethods, (view SymbolT.name sym).base `notElem` methods] where diff --git a/frege/compiler/passes/Enter.fr b/frege/compiler/passes/Enter.fr index 74e2c684..9368f0b1 100644 --- a/frege/compiler/passes/Enter.fr +++ b/frege/compiler/passes/Enter.fr @@ -246,7 +246,7 @@ enter1InsDcl !fname (!d@InsDcl {pos = !pos}) = do !clas <- defaultXName (Pos d.clas.id d.clas.id) (TName pPreludeBase "Eq") d.clas case instTSym typ g of - Just (SymbolT.T SymT{name=typnm}) -> do + Just SymT{name=typnm} -> do foreach d.defs (mklinkd typnm (MName tname)) case g.findit clas of Just (SymbolT.C _) -> do @@ -254,8 +254,6 @@ enter1InsDcl !fname (!d@InsDcl {pos = !pos}) = do -- let cmeths = [ sym.name.base | sym@SymV{anno=true} <- values env ] -- foreach (map (QName.base • Symbol.name) (values env)) (mklink typnm (MName name)) _ -> E.error pos (msgdoc ("`" ++ clas.nice g ++ "` does not name a class.")) - Just sym -> E.error pos (msgdoc ("can't make instance for " ++ sym.nice g - ++ ", it's not a type at all.")) Nothing -> E.error pos (msgdoc ("can't make instance for " ++ typ.nicer g ++ ", there is no type constructor.")) where diff --git a/frege/compiler/passes/Instances.fr b/frege/compiler/passes/Instances.fr index 4b1cf955..1efbd234 100644 --- a/frege/compiler/passes/Instances.fr +++ b/frege/compiler/passes/Instances.fr @@ -60,7 +60,7 @@ deriveInst (d@DrvDcl{pos}) = do clas <- defaultXName pos (TName pPreludeBase "Eq") d.clas typ <- U.transSigma d.typ case instTSym typ g of - Just (SymbolT.T (sym@SymT{env})) | ctrs <- U.envConstructors env, + Just (sym@SymT{env}) | ctrs <- U.envConstructors env, not (null ctrs) || inPrelude clas.pack g && clas.base == "ArrayElement" || inPrelude clas.pack g && clas.base == "JavaType" @@ -68,7 +68,7 @@ deriveInst (d@DrvDcl{pos}) = do dcls <- deriveDcls pos clas sym ctrs d.typ.rho -- dtyp <- withDerivedContext pos d.typ d.clas return idcl.{defs=dcls, typ=withDerivedContext pos d.typ d.clas clas} - Just sym -> do + Just _ -> do E.error pos (msgdoc ("Can't derive " ++ clas.nice g ++ " (" ++ typ.nice g ++ "), type has no constructors")) stio idcl diff --git a/frege/compiler/tc/Methods.fr b/frege/compiler/tc/Methods.fr index 58ae9284..bfdcd05f 100644 --- a/frege/compiler/tc/Methods.fr +++ b/frege/compiler/tc/Methods.fr @@ -266,7 +266,7 @@ sanity (SymbolT.V (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, o ++ " could modify it.")) other = return () Nothing -> case instTauSym tau g of - Just (SymbolT.T SymT{nativ = Just nt, pur = pureType}) + Just (SymT{nativ = Just nt, pur = pureType}) | !pureType = case phantom of Just ph -> E.error (getpos tau) ( text "Non pure native type " @@ -339,7 +339,7 @@ sanity (SymbolT.V (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, o E.error (getpos tau) (msgdoc ("`Int` expected.")) return () -- already in error, or ok | otherwise = case instTauSym tau g of - Just (SymbolT.T SymT{nativ = Just nt, pur = pureType}) + Just (SymT{nativ = Just nt, pur = pureType}) | !pureType = case phantom of Just ph -> E.error (getpos tau) (msgdoc ( "Non pure native type " ++ nicer tau g @@ -399,7 +399,7 @@ sanity (SymbolT.V (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, o text "A pure native function may not consume or produce mutable data.") return Nothing | Just sym <- instTauSym r g = do - case unsafePartialView SymbolT.nativ sym of + case sym.nativ of Nothing -> do E.error (getpos r) ( text "The type " @@ -409,7 +409,7 @@ sanity (SymbolT.V (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, o <+> text " is not a native type.") return Nothing -- it is at least a native one - _ | unsafePartialView SymbolT.pur sym = do + _ | sym.pur -> do E.error (getpos r) ( text "The type " <+> text (nicer tau g) diff --git a/frege/compiler/types/Global.fr b/frege/compiler/types/Global.fr index 25fede0a..41b4e0bf 100644 --- a/frege/compiler/types/Global.fr +++ b/frege/compiler/types/Global.fr @@ -8,7 +8,7 @@ import frege.data.TreeMap as TM(TreeMap, each) import frege.java.Net(URLClassLoader) import frege.control.monad.State (State, StateT) -import frege.compiler.common.Lens (preview, view) +import frege.compiler.common.Lens (preview, unsafePartialView, view) import frege.compiler.enums.Flags as Compilerflags(Flag, Flags, isOn, isOff) import frege.compiler.enums.TokenID(TokenID) import frege.compiler.types.Positions @@ -216,11 +216,11 @@ data Global = !Global { Just sy | Just env <- sy.env' = env.lookupS s Just (SymbolT.A SymA{typ}) = case instTSym typ g of Just sym - | Just r <- findm g (view SymbolT.name sym) s = Just r + | Just r <- findm g sym.name s = Just r | ForAll _ (RhoTau{tau=tau1}) <- typ, -- look if its [TCon{name}, _, tau2] <- tau1.flat, -- type T = Mutable s X name == TName pPreludeIO "Mutable", -- and look into X - Just other <- instTauSym tau2 g = findm g (view SymbolT.name other) s + Just other <- instTauSym tau2 g = findm g other.name s | otherwise = Nothing Nothing -> Nothing _ -> Nothing @@ -258,19 +258,19 @@ inPrelude p g = (p `elem` map fst preludePacks) --- Determine type symbol of some type --- This is either a function, or basically a 'Tau' type -instTSym ∷ Sigma → Global → Maybe Symbol +instTSym :: Sigma -> Global -> Maybe (SymT Global) instTSym (ForAll _ (RhoTau _ tau)) g = instTauSym tau g -- no need to deconstruct this again -instTSym _ {- (ForAll _ (RhoFun{})) -} g = g.findit (TName pPreludeBase "->") +instTSym _ {- (ForAll _ (RhoFun{})) -} g = fmap (unsafePartialView SymbolT._T) $ g.findit (TName pPreludeBase "->") -- instTSym _ g = Nothing --- return type symbol for constructor of tau, if any -instTauSym ∷ Tau → Global → Maybe Symbol +instTauSym :: Tau -> Global -> Maybe (SymT Global) instTauSym tau g = case tau of - TCon {name} -> Global.findit g name + TCon {name} -> fmap (unsafePartialView SymbolT._T) $ Global.findit g name TApp a _ -> instTauSym a g _ -> Nothing diff --git a/frege/ide/Utilities.fr b/frege/ide/Utilities.fr index 4feb563f..a55c1a82 100644 --- a/frege/ide/Utilities.fr +++ b/frege/ide/Utilities.fr @@ -348,7 +348,7 @@ proposeContent !global root !offset !tokens !index = propose | !inside, Token{tokid=CONID, value} <- token, traceLn ("rule case " ++ value ++ "¦") || true, - Just (symbol@SymbolT.T _) <- global.findit TName{pack=global.thisPack, base=value}, + Just (SymbolT.T symbol) <- global.findit TName{pack=global.thisPack, base=value}, traceLn (value ++ " is a type") || true -- cons <- [ con | con@SymD{} <- values symtab ], -- traceLn (value ++ " has " ++ show (length cons) ++ " constructors.") || true @@ -363,7 +363,7 @@ proposeContent !global root !offset !tokens !index = propose RhoTau{tau} <- (unsafePartialView SymbolT.typ sym).rho, tau <- TC.reduced tau global, traceLn ("type is " ++ nicer tau global) || true, - Just (symbol@SymbolT.T _) <- instTauSym tau global + Just symbol <- instTauSym tau global = caseProposal false (Just symbol) | !inside, Token{tokid=VARID, value} <- token, @@ -375,7 +375,7 @@ proposeContent !global root !offset !tokens !index = propose (tau,_) <- U.returnType (unsafePartialView SymbolT.typ sym).rho, tau <- TC.reduced tau global, traceLn ("return type is " ++ nicer tau global) || true, - Just (symbol@SymbolT.T _) <- instTauSym tau global + Just symbol <- instTauSym tau global = caseProposal false (Just symbol) | direct, token.tokid == VARID = localProposal directProposal @@ -430,7 +430,7 @@ proposeContent !global root !offset !tokens !index = propose -- make a case statement -- given the symbol for a type, produce a proposal -- - caseProposal :: Bool -> Maybe Symbol -> [Proposal] + caseProposal :: Bool -> Maybe (SymT Global) -> [Proposal] caseProposal conid tsym = if !direct then [proposal] -- sym ¦ @@ -445,8 +445,8 @@ proposeContent !global root !offset !tokens !index = propose forWhat = case tsym of Nothing -> "for some type" Just t -> if conid - then "for type " ++ (view SymbolT.name t).base - else "for value of type " ++ (view SymbolT.name t).base + then "for type " ++ t.name.base + else "for value of type " ++ t.name.base disp = 5 + (if conid then 0 else token.length + 1) proposal = Proposal{ proposal = "case " ++ forWhat, @@ -467,14 +467,14 @@ proposeContent !global root !offset !tokens !index = propose texts = map (spaces ++) (map (++ " → undefined -- TODO: complete code\n") (conts false tsym)) - conts ∷ Bool → Maybe Symbol → [String] + conts :: Bool -> Maybe (SymT Global) -> [String] conts parens tsym = case tsym of Just sym -> case cons of (_:_) -> (map (conText parens) . sortBy (comparing _.cid)) cons - [] -> if view SymbolT.name sym == TName pPreludeBase "Bool" + [] -> if sym.name == TName pPreludeBase "Bool" then ["true", "false"] else ["_"] - where cons = [ con | SymbolT.D con <- values (unsafePartialView _Just sym.env')] + where cons = [ con | SymbolT.D con <- values sym.env ] Nothing -> ["_"] -- null cons = ["_"] @@ -510,7 +510,7 @@ proposeContent !global root !offset !tokens !index = propose tauProposal tau prop | traceLn ("tauProposal: " ++ nicer tau global) = undefined | tau <- TC.reduced tau global, - Just (SymbolT.T SymT{env, nativ=mbs}) <- instTauSym tau global + Just (SymT{env, nativ=mbs}) <- instTauSym tau global = case mbs of Just s | ss <- s:U.supersOfNativ s global, -- the supertypes of s (including s) @@ -570,7 +570,7 @@ proposeContent !global root !offset !tokens !index = propose TCon{name}:ts <- tau.flat = if name == TName{pack=pPreludeIO, base="Mutable"} then case ts of - [_, tau] -> getEnv (instTauSym tau global) + [_, tau] -> getEnv (fmap SymbolT.T $ instTauSym tau global) _ -> getEnv (global.findit name) else getEnv (global.findit name) getEnv other = Nothing From c973f5c9ee1e5cdeafb2d22c0ef390ea2c149040 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 21:56:15 +0900 Subject: [PATCH 52/95] Modify methCode and related functions to take SymV MethodCall.methCode assumed its Symbol parameter to be SymV. The other related functions, which could handle / were called with SymV only, were modified as well. --- frege/compiler/gen/java/Common.fr | 4 +- frege/compiler/gen/java/MethodCall.fr | 67 +++++++++++++-------------- frege/compiler/gen/java/VarCode.fr | 10 ++-- 3 files changed, 39 insertions(+), 42 deletions(-) diff --git a/frege/compiler/gen/java/Common.fr b/frege/compiler/gen/java/Common.fr index cc33e77a..3018dca0 100644 --- a/frege/compiler/gen/java/Common.fr +++ b/frege/compiler/gen/java/Common.fr @@ -871,8 +871,8 @@ needsUnchecked which cmem jty = case cmem `lookup` haveDoubleCast of Nothing = false --- check if this is an implementation for a class method, and must suppress unsafe cast warnings -unsafeCast :: Global -> Symbol -> Bool -unsafeCast g sym = case (view SymbolT.name sym) of +unsafeCast :: Global -> SymV Global -> Bool +unsafeCast g sym = case sym.name of MName{tynm, base} | Just (SymbolT.I SymI{clas}) <- g.findit tynm , Just (SymbolT.C SymC{supers}) <- g.findit clas diff --git a/frege/compiler/gen/java/MethodCall.fr b/frege/compiler/gen/java/MethodCall.fr index be1b7a32..75623748 100644 --- a/frege/compiler/gen/java/MethodCall.fr +++ b/frege/compiler/gen/java/MethodCall.fr @@ -39,16 +39,14 @@ niSpecial g ty --- Tells if a native symbol is wrapped -wrapped :: Global -> Symbol -> Bool -wrapped g (SymbolT.V (sym@SymV{nativ = Just item, throwing})) = +wrapped :: Global -> SymV Global -> Bool +wrapped g (sym@SymV{nativ = Just item, throwing}) = not (null throwing) || niSpecial g rty - || not (null (wildReturn g $ SymbolT.V sym)) + || not (null (wildReturn g sym)) where (rty, _) = U.returnType sym.typ.rho -wrapped _ (SymbolT.V _) = false -wrapped _ (SymbolT.D _) = false -wrapped _ _ = error "wrapped: no symv" +wrapped _ _ = false {-- Tell if a native function must be called through its wrapper. @@ -59,14 +57,14 @@ wrapped _ _ = error "wrapped: no symv" wrappedOnly g (SymbolT.V (symv@SymV {nativ = Just _, throwing})) = not (null throwing) || niSpecial g rty && isNothing (U.isMaybe rty) - || not (null (wildReturn g $ SymbolT.V symv)) + || not (null (wildReturn g symv)) where (rty, _) = U.returnType symv.typ.rho wrappedOnly _ sym = error "wrappedOnly - no native function" --- returns a binding for a direct call of a native method -nativeCall ∷ Global → Symbol → TreeMap String Tau → [JExpr] → Binding -nativeCall g (SymbolT.V (symv@SymV{nativ = Just item, gargs})) subst aexs = newBind g bsig (call jrty args) +nativeCall :: Global -> SymV Global -> TreeMap String Tau -> [JExpr] -> Binding +nativeCall g (symv@SymV{nativ = Just item, gargs}) subst aexs = newBind g bsig (call jrty args) where (rty, sigmas) = U.returnType symv.typ.rho taus = [ tau | Just tau <- map U.sigmaAsTau sigmas ] @@ -150,12 +148,12 @@ nativeCall g (SymbolT.V (symv@SymV{nativ = Just item, gargs})) subst aexs = newB NIArraySet -> case args of [a,b,c] -> JBin (JArrayGet a b) "=" c _ -> JAtom "bad array set" -- error was flagged before -nativeCall g sym subst aexs = error ("nativeCall: no function " - ++ show (view SymbolT.pos sym).first.line +nativeCall g sym subst aexs = error ("nativeCall: no function " + ++ show sym.pos.first.line ++ ", " ++ nicer sym g) -wrapCode :: Global -> (JExpr -> JStmt) -> Tau -> Symbol -> TreeMap String Tau -> [JExpr] -> [JStmt] -wrapCode g jreturn rtau (sym@(SymbolT.V SymV{nativ = Just item, throwing})) subst aexs +wrapCode :: Global -> (JExpr -> JStmt) -> Tau -> SymV Global -> TreeMap String Tau -> [JExpr] -> [JStmt] +wrapCode g jreturn rtau (sym@SymV{nativ = Just item, throwing}) subst aexs | Just (stau, atau) <- unST rtau = let sjt = tauJT g stau -- type #1 for parameterization of ST s a ajt = tauJT g atau -- return type of the ST action @@ -221,42 +219,42 @@ wrapCode g jreturn rtau (sym@(SymbolT.V SymV{nativ = Just item, throwing})) subs catch rty = case tauJT g rty of Nativ{typ, gargs} -> "catch (" ++ typ ++ " ex)" other -> error ("bad exception type " ++ show other) -wrapCode g jreturn rtau sym _ _ = error "wrapCode: no SymV" - - +wrapCode _ _ _ _ _ _ = error "wrapCode: non-native SymV" + + {-- code for native functions and/or members -} -methCode :: Global -> Symbol -> SymInfo8 -> [JDecl] -methCode g (sym@(SymbolT.V (symv@SymV {nativ = Just item}))) si = [ - JComment ((nice sym g) ++ " " ++ show symv.strsig ++ " " ++ show symv.rkind), +methCode :: Global -> SymV Global -> SymInfo8 -> [JDecl] +methCode g (symv@SymV {nativ = Just item}) si = [ + JComment ((nice symv g) ++ " " ++ show symv.strsig ++ " " ++ show symv.rkind), JComment (nicer symv.typ g), JComment ("the following type variables are probably wildcards: " ++ joined ", " (map _.var wildr)), JComment item] ++ (if arity then defs - else if wrapped g sym || niKind item != NIStatic + else if wrapped g symv || niKind item != NIStatic then [member] else []) where rjt = tauJT g rty rArgs = lambdaArgDef g attrFinal si.argSigs (getArgs g) wArgs = argDefs attrFinal si (getArgs g) - wildr = wildReturn g sym - name = symJavaName g sym -- X.foo + wildr = wildReturn g symv + name = symJavaName g (SymbolT.V symv) -- X.foo ftargs = targs g symv.typ -- args = if haswrapper then wArgs else rArgs - haswrapper = arity && wrapped g sym -- (not (null bnds)) + haswrapper = arity && wrapped g symv -- (not (null bnds)) jreturn = if arity then JReturn else JEx bndWcode x = newBind g (ForAll [] (RhoTau [] rty)) x attr - | not (null wildr) = attrs [JUnchecked, JPublic, JStatic, JFinal] - | unsafeCast g sym = attrs [JUnchecked, JPublic, JStatic, JFinal] - | otherwise = attrTop + | not (null wildr) = attrs [JUnchecked, JPublic, JStatic, JFinal] + | unsafeCast g symv = attrs [JUnchecked, JPublic, JStatic, JFinal] + | otherwise = attrTop - wcode = if wrapped g sym - then wrapCode g jreturn rty sym TreeMap.empty (map (_.jex . instArg g) args) + wcode = if wrapped g symv + then wrapCode g jreturn rty symv TreeMap.empty (map (_.jex . instArg g) args) else let - bind = nativeCall g sym TreeMap.empty (map (_.jex . instArg g) args) + bind = nativeCall g symv TreeMap.empty (map (_.jex . instArg g) args) in [jreturn bind.jex] wrappers = if haswrapper then [{- inst, -} wrapper] else [{-inst-}] wrapper = JMethod {attr, @@ -268,13 +266,13 @@ methCode g (sym@(SymbolT.V (symv@SymV {nativ = Just item}))) si = [ member = JMember {attr = attrTop, jtype = rjt, - name = (symJavaName g sym).base, + name = (symJavaName g (SymbolT.V symv)).base, init = Just (unex wcode)} (rty, atys) = U.returnType symv.typ.rho arity = not (null atys) || not (null symv.typ.bound) - -methCode g sym _ = Prelude.error ("line " ++ show (view SymbolT.pos sym).first.line + +methCode g sym _ = Prelude.error ("line " ++ show sym.pos.first.line ++ ": can not compile " ++ nice sym g) {-- @@ -287,8 +285,8 @@ methCode g sym _ = Prelude.error ("line " ++ show (view SymbolT.pos sym).first.l and we need to cast the result. -} -wildReturn ∷ Global → Symbol → [Tau] -wildReturn g (SymbolT.V symv) = +wildReturn :: Global -> SymV Global -> [Tau] +wildReturn g symv = [ v | v@TVar{} ← values (U.freeTauTVars [] TreeMap.empty ret) , not (stvar v.var) , not (elemBy (using _.var) v sigvars) @@ -302,7 +300,6 @@ wildReturn g (SymbolT.V symv) = other → const false sigvars = concatMap (values . U.freeRhoTVars [] TreeMap.empty . _.rho) sigs itemvars = concatMap (values . U.freeTauTVars [] TreeMap.empty) symv.gargs -wildReturn _ _ = [] wrapIRMethod :: Global -> JExpr -> JType -> SymInfo8 -> String -> String -> Symbol -> JDecl diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index 4864a4c8..ee806875 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -85,7 +85,7 @@ varCode binds (SymMeth.V symv) = do <> text ", depth=" <> anno symv.depth <> text ", rstate=" <> (text • show) symv.rkind) si <- symInfo (SymbolT.V symv) - return (comment : methCode g (SymbolT.V symv) si) + return (comment : methCode g symv si) | otherwise = return [] -- there is no code for overloads where comment = JComment (nicer symv g) @@ -118,7 +118,7 @@ topFun (sym@SymV {expr = Just dx}) binds = do return () -- check if we are an implementation for a class method, and must suppress unsafe cast warnings - let unsafe = unsafeCast g (SymbolT.V sym) + let unsafe = unsafeCast g sym let argNames = getArgs g ctxNames = getCtxs g @@ -1314,7 +1314,7 @@ genExpr rflg rm ex binds = do (JInvoke stref []) bind = if isStrictJT rm then call else delayBind call result bind - else result (nativeCall g (SymbolT.V sym) subst []) + else result (nativeCall g sym subst []) else do let contexts = map (reducedCtx g) rhoctx.context kret = kArity (sigmaKind sym.typ) @@ -1670,10 +1670,10 @@ genExpr rflg rm ex binds = do appResult true call else do let call0 - | wrapped g (SymbolT.V symv) = case wrapCode g JEx res (SymbolT.V symv) subst arguments of + | wrapped g symv = case wrapCode g JEx res symv subst arguments of (JEx ex:_) -> newBind g ret ex _ -> error "unexpected wrapCode result" - | otherwise = nativeCall g (SymbolT.V symv) subst arguments + | otherwise = nativeCall g symv subst arguments call = call0.{jtype = retjt} appResult true call From 38021a1947b698e7cbbc1a5e096fcfe3da9f5d73 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 22:03:58 +0900 Subject: [PATCH 53/95] Modify wrapIRMethod to take SymVal The partialness couldn't removed. It was moved to the call site. --- frege/compiler/gen/java/MethodCall.fr | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/frege/compiler/gen/java/MethodCall.fr b/frege/compiler/gen/java/MethodCall.fr index 75623748..861d56df 100644 --- a/frege/compiler/gen/java/MethodCall.fr +++ b/frege/compiler/gen/java/MethodCall.fr @@ -12,7 +12,7 @@ import Compiler.classes.Nice(nice, nicer) import Compiler.types.AbstractJava import Compiler.types.Types(unST, Sigma, Tau, TauT, ForAll, RhoTau, RhoFun) -import Compiler.types.Symbols(SymD, SymV, SymbolT) +import Compiler.types.Symbols(SymD, SymV, SymVal, SymbolT) import Compiler.types.Global import Compiler.types.JNames(JName, memberOf) import Compiler.types.Strictness() @@ -115,7 +115,7 @@ nativeCall g (symv@SymV{nativ = Just item, gargs}) subst aexs = newBind g bsig ( nativnm <- unsafePartialView SymbolT.nativ nativsym let nativsi = evalStG g $ symInfo nativsym fldsym <- TreeMap.lookup fldnm (unsafePartialView _Just irsym.env') - pure $ wrapIRMethod g (head args) (head si.argJTs) nativsi nativnm fldnm fldsym + pure $ wrapIRMethod g (head args) (head si.argJTs) nativsi nativnm fldnm (unsafePartialView Symbol._Val fldsym) in JNewClass jrty [] (evalStG g x) NICast -> case args of [a] -> JInvoke (JAtom item) args -- was: JCast (Ref (JName "" item) []) a @@ -302,10 +302,10 @@ wildReturn g symv = itemvars = concatMap (values . U.freeTauTVars [] TreeMap.empty) symv.gargs -wrapIRMethod :: Global -> JExpr -> JType -> SymInfo8 -> String -> String -> Symbol -> JDecl +wrapIRMethod :: Global -> JExpr -> JType -> SymInfo8 -> String -> String -> SymVal Global -> JDecl wrapIRMethod g this irjt nativsi nativnm fldnm fldsym = let nativargs = argDefs attrFinal (nativsi.{ argSigs <- tail, argJTs <- tail }) (getArgs g) - fldstri = case unsafePartialView SymbolT.strsig fldsym of + fldstri = case view SymVal.strsig fldsym of Strictness.S xs -> tail xs _ -> [] -- how to detect strictness of result value? From 379359c635de10f2471b5c38e1a7c9a3a811c94b Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 22:10:33 +0900 Subject: [PATCH 54/95] Remove use of unsafePartialView in symWarning It seems pointless to crash the compiler when a symbol can't have a documentation (i.e. it's a SymL). Instead it is ignored. --- frege/compiler/Utilities.fr | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index bc0dafa8..6814aedb 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -630,10 +630,11 @@ appTauSigmas tau sigs = foldM appTauSig tau sigs >>= return . tauAsSigma does not start with "nowarn:" -} symWarning :: (Position -> DOCUMENT -> StG ()) -> Symbol -> DOCUMENT -> StG () -symWarning warn sym msg = do - case unsafePartialView SymbolT.doc sym of - Just ´^\s*nowarn:´ -> return () - other -> warn (view SymbolT.pos sym) msg +symWarning warn sym msg = + case preview SymbolT.doc sym of + Nothing -> pure () + Just (Just ´^\s*nowarn:´) -> pure () + Just _ -> warn (view SymbolT.pos sym) msg {- ################# functions introduced through Classes.fr ############## -} From 1d5d77822b597ef24277af7ab855cbfa20c8a294 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 22:19:03 +0900 Subject: [PATCH 55/95] Modify arity to take SymVal --- frege/compiler/Typecheck.fr | 2 +- frege/compiler/Utilities.fr | 7 ++++--- frege/compiler/passes/Easy.fr | 2 +- frege/compiler/passes/Strict.fr | 4 ++-- 4 files changed, 8 insertions(+), 7 deletions(-) diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index c4f45247..5ec715ca 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -1475,7 +1475,7 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do sy <- overloads g h] = ov++syms SymV{over} -> [ sy | m <- over, SymbolT.V sy <- g.findit m ] - arityV = arity . SymbolT.V + arityV = arity . SymVal.V rHas _ x = pure (Left x) diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index 6814aedb..6fb6917f 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -50,7 +50,7 @@ import Data.List as DL(partitioned, sortBy, minimumBy, \\) import Lib.PP(fill, break, pretty, text, nest, msgdoc, <+>, <>, DOCUMENT) -import frege.compiler.common.Lens (over, preview, set, unsafePartialView, view) +import frege.compiler.common.Lens (over, preview, set, view) -- import Compiler.enums.Flags import Compiler.enums.TokenID(defaultInfix, VARID) @@ -1036,8 +1036,9 @@ isJavaType (Meta tv) | tv.isFlexi = do isJavaType _ = stio false -{-- Arity of a 'Symbol' based on its type -} -arity sym = case returnType (unsafePartialView SymbolT.typ sym).rho of +{-- Arity of a 'SymVal' based on its type -} +arity :: SymVal Global -> Int +arity sym = case returnType (view SymVal.typ sym).rho of (_, xs) -> length xs diff --git a/frege/compiler/passes/Easy.fr b/frege/compiler/passes/Easy.fr index 5045dba0..425e36af 100644 --- a/frege/compiler/passes/Easy.fr +++ b/frege/compiler/passes/Easy.fr @@ -118,7 +118,7 @@ checkDepth (SymMeth.L (vsym@SymL {pos, alias, name = MName inst base})) = do g <- getST cmeth <- classMethodOfInstMethod pos inst base rmeth <- U.findVD alias - let d = case rmeth of { SymVal.V SymV{depth} -> depth; _ -> U.arity rmeth.toSymbol; } + let d = case rmeth of { SymVal.V SymV{depth} -> depth; _ -> U.arity rmeth; } when (cmeth.depth != d) do E.error pos (msgdoc ( nicer rmeth g ++ " is not a suitable implementation for " diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index 9a905624..a9c930ba 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -301,7 +301,7 @@ returnExprKind syms sym (ex@App a b typ) = do Vbl {name} -> do symf <- U.findV name g <- getST - let ari = if isJust symf.expr then symf.depth else U.arity $ SymbolT.V symf + let ari = if isJust symf.expr then symf.depth else U.arity $ SymVal.V symf rwa = defaultRKind.intersection symf.rkind rw | MName tname _ <- symf.name, Just (SymbolT.C _) <- g.findit tname @@ -448,7 +448,7 @@ strictName sids nm = do v <- U.findV nm when (v.state != StrictChecked) do E.logmsg TRACES v.pos (text ("strictness analysis for " ++ v.nice g)) - let ari = U.arity $ SymbolT.V v -- ... based on type + let ari = U.arity $ SymVal.V v -- ... based on type notLazy sym = RValue `member` sym.rkind case v of SymV {state = StrictChecked} = stio [] -- do nothing From f3992b8f5a8dd1922b044525aa9b6d16c07b8a30 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 22:28:53 +0900 Subject: [PATCH 56/95] Add a custom partial conversion SymbolT -> SymV in SymbolTable If a SymbolT's name is Local, it is converted to SymV. It is safe but it can't be proved by the type system until QName, the sum type, is split just like SymbolT. For now, the non-exclusive case analysis is replaced by a private unsafe conversion to supress unwanted compilation warnings. --- frege/compiler/common/SymbolTable.fr | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/frege/compiler/common/SymbolTable.fr b/frege/compiler/common/SymbolTable.fr index 985cbf5d..02e0960c 100644 --- a/frege/compiler/common/SymbolTable.fr +++ b/frege/compiler/common/SymbolTable.fr @@ -65,6 +65,12 @@ private updateSym toSymbol tab key value = case tab.lookupS key of E.error (view SymbolT.pos (toSymbol value)) (fill (break ("cannot update " ++ qn ++ " " ++ show (keys tab)))) stio (tab.insert key value) +--- Assume a Symbol is SymV because it's name is Local +--- It is caller's responsibility to ensure that +private toSymVBecauseLocal :: Symbol -> SymV Global +private toSymVBecauseLocal (SymbolT.V symv) = symv +private toSymVBecauseLocal _ = Prelude.error "thisIsSymVBecauseLocal: not SymV" + {-- * Enter symbol into appropriate symbol table. @@ -96,7 +102,7 @@ enter sym = case sym of Local{uid} -> do g <- getST uid <- if uid > 0 then return uid else uniqid - let symv = case sym of { SymbolT.V x -> x; } + let symv = toSymVBecauseLocal sym case g.find name of Nothing | uid == symv.sid-> do @@ -153,7 +159,7 @@ changeSym sym = do Nothing -> E.fatal (view SymbolT.pos sym) (text "no environment:" <+> text (t.nice g)) Local uid s -> do -- g <- getST - let symv = case sym of { SymbolT.V x -> x; } + let symv = toSymVBecauseLocal sym when (symv.sid != uid) do E.fatal symv.pos (text("changeSym: name =" ++ show name ++ ", sid=" ++ show symv.sid)) From 599465cf1e1512330d236597e5d84f1622f23ee8 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 24 Oct 2019 22:33:59 +0900 Subject: [PATCH 57/95] Remove use of unsafePartialView in docWarningSym The same reasoning as symWarning. It is pointless to crash the compiler if a symbol is known not to be able to have a doc. --- frege/compiler/common/Resolve.fr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/frege/compiler/common/Resolve.fr b/frege/compiler/common/Resolve.fr index 4e848b8b..6a580646 100644 --- a/frege/compiler/common/Resolve.fr +++ b/frege/compiler/common/Resolve.fr @@ -65,7 +65,7 @@ protected resolve fname pos sname = do docWarningSym :: Symbol -> StG () docWarningSym sym = do g <- getST - docWarning pos ((view SymbolT.name sym).nicer g) (unsafePartialView SymbolT.doc sym) + docWarning pos ((view SymbolT.name sym).nicer g) (join $ preview SymbolT.doc sym) traceSym :: SName -> Symbol -> StG () traceSym sname symbol = do From 1f5afaf4f741c122b941b6e3864596e06d2a9b4c Mon Sep 17 00:00:00 2001 From: matil019 Date: Fri, 25 Oct 2019 13:28:53 +0900 Subject: [PATCH 58/95] Remove uses of unsafePartialView from passes.Final A new local function 'mapEnvSymV' that traverses Symbol.env was added to solve the issue. --- frege/compiler/passes/Final.fr | 17 ++++++++--------- frege/compiler/types/Symbols.fr | 7 +++++++ 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/frege/compiler/passes/Final.fr b/frege/compiler/passes/Final.fr index fd8b3e10..3e168ca3 100644 --- a/frege/compiler/passes/Final.fr +++ b/frege/compiler/passes/Final.fr @@ -1,7 +1,7 @@ --- The final compiler pass module frege.compiler.passes.Final where -import frege.compiler.common.Lens (over, unsafePartialView) +import frege.compiler.common.Lens (over) import Data.TreeMap as TM(TreeMap, insert, each) import Compiler.types.Global @@ -43,14 +43,13 @@ cleanSymtab = do where maptab g = fmap symbol g.thisTab where - symbol sym = case sym of - SymbolT.V (symv@SymV{name}) - | Just e <- g.gen.expSym.lookup name - -> SymbolT.V symv.{expr = Just (exprFromA sarray eAarray eAarray.[e])} - | otherwise - -> SymbolT.V symv.{expr = Nothing} - SymbolT.I symi -> SymbolT.I symi.{meth <- fmap (unsafePartialView SymbolT._Meth . symbol . SymMeth.toSymbol)} - _ -> over SymbolT.env (fmap symbol) sym + symbol = mapEnvSymV $ \symv -> + symv.{expr = fmap (\e -> exprFromA sarray eAarray eAarray.[e]) $ g.gen.expSym.lookup symv.name} + mapEnvSymV :: (Symbols.SymV Global -> Symbols.SymV Global) -> Symbol -> Symbol + mapEnvSymV mapsymv sym = case sym of + SymbolT.V symv -> SymbolT.V $ mapsymv symv + SymbolT.I symi -> SymbolT.I $ symi.{meth <- fmap (over SymMeth._V mapsymv)} + _ -> over SymbolT.env (fmap (mapEnvSymV mapsymv)) sym swap :: (a,b) -> (b,a) swap (a,b) = (b,a) -- !kAarray = (arrayFromIndexList . map swap . each) empty -- g.gen.kTree diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 2617997d..f7073ee1 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -148,6 +148,13 @@ data SymMeth global pos f (L s) = (\pos -> L s.{pos}) <$> f s.pos pos f (V s) = (\pos -> V s.{pos}) <$> f s.pos + -- _L :: Prism' (SymMeth g) (SymL g) + _L :: (Choice p, Applicative f) => p (SymL g) (f (SymL g)) -> p (SymMeth g) (f (SymMeth g)) + _L = prism' L (\s -> case s of { SymMeth.L x -> Just x; _ -> Nothing; }) + -- _V :: Prism' (SymMeth g) (SymV g) + _V :: (Choice p, Applicative f) => p (SymV g) (f (SymV g)) -> p (SymMeth g) (f (SymMeth g)) + _V = prism' V (\s -> case s of { SymMeth.V x -> Just x; _ -> Nothing; }) + {-- The information stored in the 'Symtab' nodes. -} From 59847a3c086149b2444809e4faebb38ff83f7fd6 Mon Sep 17 00:00:00 2001 From: matil019 Date: Fri, 25 Oct 2019 13:34:38 +0900 Subject: [PATCH 59/95] Ignore missing SymbolT.env' in resolve3 The same reasoning as symWarning. It is pointless to crash the compiler if a symbol is known not to be able to have an env-like thing. --- frege/compiler/common/Resolve.fr | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/frege/compiler/common/Resolve.fr b/frege/compiler/common/Resolve.fr index 6a580646..3b9d152d 100644 --- a/frege/compiler/common/Resolve.fr +++ b/frege/compiler/common/Resolve.fr @@ -6,7 +6,7 @@ import frege.Prelude hiding(break, <+>) import frege.data.TreeMap as TM(TreeMap, lookup, each, insert, union, including, contains, keys, values, fromKeys) import frege.data.List as DL(partitioned, sortBy, minimumBy) import frege.lib.PP(break, fill, text, nest, msgdoc, <+>, <>, DOCUMENT) -import frege.compiler.common.Lens (_Just, preview, set, unsafePartialView, view) +import frege.compiler.common.Lens (_Just, preview, set, view) import frege.compiler.enums.Flags import frege.compiler.enums.Visibility import frege.compiler.types.Positions @@ -124,7 +124,8 @@ private resolve3 fname pos (Simple Token{value=qs}) = do rs -> stio rs where scope g (MName t _) | Just sym <- g.findit t - = scopefrom [unsafePartialView _Just sym.env', g.thisTab] + , Just env <- sym.env' + = scopefrom [env, g.thisTab] scope g _ = scopefrom [g.thisTab] scopefrom envs = fold more [] envs where From f3f0c3a02aa03468ab6bc6cf0a3a1e9ba039adac Mon Sep 17 00:00:00 2001 From: matil019 Date: Fri, 25 Oct 2019 22:25:58 +0900 Subject: [PATCH 60/95] Ignore missing SymbolT.env' in enter1ClaDcl The same reasoning as symWarning. It is pointless to crash the compiler if a symbol is known not to be able to have an env-like thing. --- frege/compiler/passes/Enter.fr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/frege/compiler/passes/Enter.fr b/frege/compiler/passes/Enter.fr index 9368f0b1..f6081e1f 100644 --- a/frege/compiler/passes/Enter.fr +++ b/frege/compiler/passes/Enter.fr @@ -228,7 +228,7 @@ enter1ClaDcl fname (d@ClaDcl {pos}) = do let vs = (filter (maybe true (not . Lens.is SymbolT._L) . g.find . VName g.thisPack . QName.base . view SymbolT.name) - . values . maybe empty (unsafePartialView _Just . _.env')) (g.findit tname) + . values . fromMaybe empty) (_.env' =<< g.findit tname) E.logmsg TRACE3 pos (text ("enter1: ClaDcl: vs=" ++ show (map (flip nice g) vs))) foreach (vs) link From 749d6cc538b862b2292896cd8862867e77b7cd56 Mon Sep 17 00:00:00 2001 From: matil019 Date: Fri, 25 Oct 2019 23:44:09 +0900 Subject: [PATCH 61/95] Remove uses of unsafePartialView in Transdef In transFunDcl, non-SymVals are just ignored. In ordInfix, non-SymVals will be treated as errors. (later) --- frege/compiler/passes/Transdef.fr | 24 ++++++++++++------------ frege/compiler/types/Symbols.fr | 4 ++++ 2 files changed, 16 insertions(+), 12 deletions(-) diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index 9bd385df..dce84515 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -44,7 +44,7 @@ import frege.Prelude hiding(<+>, break) import Data.TreeMap as TM(insert, lookup, values, keys, TreeMap, each, contains) import Data.List as DL(find, unique, sortBy, groupBy) -import frege.compiler.common.Lens (preview, set, unsafePartialView, view) +import frege.compiler.common.Lens (preview, set, view) import Compiler.enums.Flags as Compilerflags(TRACE5, isOn, flagClr, flagSet, NODOCWARNINGS) import Compiler.enums.TokenID @@ -253,9 +253,9 @@ transFunDcl env fname (d@FunDcl {positions}) = do | not symv.anno, not symv.name.isLocal, not (classMember aname g), - Just osym <- g.findit name, + Just osym <- SymVal.fromSymbol =<< g.findit name, -- make sure there is no precedence conflict - symv.op == unsafePartialView SymbolT.op osym || symv.op == defaultInfix || unsafePartialView SymbolT.op osym == defaultInfix, + symv.op == view SymVal.op osym || symv.op == defaultInfix || view SymVal.op osym == defaultInfix, -- no loops, please! name != symv.name = do let alias = SymL{sid=symv.sid, @@ -264,13 +264,13 @@ transFunDcl env fname (d@FunDcl {positions}) = do name=symv.name, alias=name} -- - when (unsafePartialView SymbolT.op osym != symv.op && symv.op != defaultInfix) do - when (unsafePartialView SymbolT.op osym != defaultInfix) do + when (view SymVal.op osym != symv.op && symv.op != defaultInfix) do + when (view SymVal.op osym != defaultInfix) do E.warn symv.pos (msgdoc ("This changes associativity/precedence for " - ++ nicer (view SymbolT.name osym) g + ++ nicer (view SymVal.name osym) g ++ " to the one given for " ++ nicer symv.name g)) - changeSym $ set SymbolT.op symv.op osym + changeSym $ SymVal.toSymbol $ set SymVal.op symv.op osym changeSym $ SymbolT.L alias othr -> changeSym $ SymbolT.V symv.{expr = Just (return x)} | otherwise = E.fatal pos (text ("expected function, found " ++ sym.nice g)) @@ -1101,12 +1101,12 @@ ordInfix fname (orig@Infx{name, left, right}) left <- ordInfix fname Infx{name, left, right=right.left} return Infx{name=right.name, left, right=right.right} bindright = return Infx{name, left, right} -- a $ x+1 == a $ (x+1) - case (g.findit op1, g.findit op2) of - (Just sym1, Just sym2) = - if prec (unsafePartialView SymbolT.op sym1) > prec (unsafePartialView SymbolT.op sym2) then bindleft - else if prec (unsafePartialView SymbolT.op sym1) < prec (unsafePartialView SymbolT.op sym2) then bindright + case (fmap SymVal.fromSymbol $ g.findit op1, fmap SymVal.fromSymbol $ g.findit op2) of + (Just (Just sym1), Just (Just sym2)) -> + if prec (view SymVal.op sym1) > prec (view SymVal.op sym2) then bindleft + else if prec (view SymVal.op sym1) < prec (view SymVal.op sym2) then bindright else -- equal precedence - case (assoc (unsafePartialView SymbolT.op sym1), assoc (unsafePartialView SymbolT.op sym2)) of + case (assoc (view SymVal.op sym1), assoc (view SymVal.op sym2)) of ("left", "left") -> bindleft ("right", "right") -> bindright (left, right) -> do diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index f7073ee1..384500ee 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -106,6 +106,10 @@ data SymVal global name :: Functor f => (QName -> f QName) -> SymVal g -> f (SymVal g) name f (D s) = (\name -> D s.{name}) <$> f s.name name f (V s) = (\name -> V s.{name}) <$> f s.name + -- op :: Lens' (SymVal g) TokenID + op :: Functor f => (TokenID -> f TokenID) -> SymVal g -> f (SymVal g) + op f (D s) = (\op -> D s.{op}) <$> f s.op + op f (V s) = (\op -> V s.{op}) <$> f s.op -- pos :: Lens' (SymVal g) Position pos :: Functor f => (Position -> f Position) -> SymVal g -> f (SymVal g) pos f (D s) = (\pos -> D s.{pos}) <$> f s.pos From 1a8fadef261284e7ddb739655beda2aa12fe758d Mon Sep 17 00:00:00 2001 From: matil019 Date: Mon, 28 Oct 2019 12:34:21 +0900 Subject: [PATCH 62/95] Move a common part in SymbolTable to a new function --- frege/compiler/common/SymbolTable.fr | 136 ++++++++++++++------------- 1 file changed, 72 insertions(+), 64 deletions(-) diff --git a/frege/compiler/common/SymbolTable.fr b/frege/compiler/common/SymbolTable.fr index 02e0960c..a5cffb00 100644 --- a/frege/compiler/common/SymbolTable.fr +++ b/frege/compiler/common/SymbolTable.fr @@ -20,22 +20,27 @@ import frege.compiler.common.Annotate(lit) import frege.compiler.common.Errors as E() import frege.compiler.instances.Nicer -private insertGlobal p n s = enterWith (insertSym id) p n s - -private updateGlobal p n s = enterWith (updateSym id) p n s +private data InsUpd = DoInsert | DoUpdate +private derive Show InsUpd +private enterWith :: InsUpd -> Pack -> String -> Symbol -> StG () private enterWith insupd p n s = do g <- getST -- give me the state case g.packages.lookup p of Just tab -> do - ntab <- insupd tab n s + ntab <- doInsUpd tab n s changeST Global.{packages <- insert p ntab} Nothing -> do let sp = g.unpack p E.error (view SymbolT.pos s) (fill ([text "module", text "`" <> text sp <> text "`"] ++ break "does not exist.")) + where + doInsUpd = case insupd of + DoInsert -> insertSym id + DoUpdate -> updateSym id + {-- insert symbol, but make sure it does not exist yet -} @@ -65,8 +70,11 @@ private updateSym toSymbol tab key value = case tab.lookupS key of E.error (view SymbolT.pos (toSymbol value)) (fill (break ("cannot update " ++ qn ++ " " ++ show (keys tab)))) stio (tab.insert key value) ---- Assume a Symbol is SymV because it's name is Local ---- It is caller's responsibility to ensure that +{-- + - Assume a Symbol is SymV because it's name is Local + - + - It is caller's responsibility to ensure that. + -} private toSymVBecauseLocal :: Symbol -> SymV Global private toSymVBecauseLocal (SymbolT.V symv) = symv private toSymVBecauseLocal _ = Prelude.error "thisIsSymVBecauseLocal: not SymV" @@ -128,78 +136,78 @@ enter sym = case sym of | otherwise = enterByName sym -- error message follows -changeSym :: Symbol -> StG () -changeSym sym | view SymbolT.sid sym == 0 = do - u <- uniqid - changeSym $ set SymbolT.sid u sym -changeSym sym = do - g <- getST - E.logmsg TRACE3 (view SymbolT.pos sym) (fill [text "changeSym", lit (view SymbolT.sid sym), text (sym.nice g ++ " :: " ++ - (maybe "" (\typ -> typ.nice g) $ preview SymbolT.typ sym) ++ ", " ++ - (case sym of { SymbolT.V SymV{state} -> show state; _ -> "" }))]) - let name = view SymbolT.name sym - case name of - TName p b -> updateGlobal p name.key sym - VName p b -> updateGlobal p name.key sym - MName t b -> do - g <- getST - let tsy = g.findit t - case tsy of - Nothing -> do - let qn = t.nice g - E.error (view SymbolT.pos sym) (fill ([text "namespace", text "`" <> text qn <> text "`"] ++ break "does not exist")) - Just (SymbolT.I typi) -> case SymMeth.fromSymbol sym of - Just ameth -> do - meth <- updateSym SymMeth.toSymbol typi.meth name.key ameth - updateGlobal t.pack t.key $ SymbolT.I typi.{meth} - Just typ -> case preview SymbolT.env typ of - Just typEnv -> do - env <- updateSym id typEnv name.key sym - updateGlobal t.pack t.key (set SymbolT.env env typ) - Nothing -> E.fatal (view SymbolT.pos sym) (text "no environment:" <+> text (t.nice g)) - Local uid s -> do - -- g <- getST - let symv = toSymVBecauseLocal sym - when (symv.sid != uid) do - E.fatal symv.pos (text("changeSym: name =" ++ show name - ++ ", sid=" ++ show symv.sid)) - changeST Global.{locals <- TreeMap.updatekvI uid symv} +changeSym :: Symbol -> StG () +changeSym = insUpdSymByName DoUpdate private enterByName :: Symbol -> StG () -private enterByName sym | view SymbolT.sid sym == 0 = do - u <- uniqid - enterByName $ set SymbolT.sid u sym -private enterByName sym = do +private enterByName = insUpdSymByName DoInsert + + +private insUpdSymByName :: InsUpd -> Symbol -> StG () +private insUpdSymByName insupd sym | view SymbolT.sid sym == 0 = do + u <- uniqid + insUpdSymByName insupd $ set SymbolT.sid u sym +private insUpdSymByName insupd sym = do g <- getST - E.logmsg TRACE3 (view SymbolT.pos sym) (fill (break ("enterByName " ++ sym.nice g ++ " " ++ show (view SymbolT.sid sym) ++ " " - ++ (case sym of - SymbolT.V symv | not (isPSigma symv.typ) -> " :: " ++ symv.typ.nicer g - _ -> "")))) + E.logmsg TRACE3 (view SymbolT.pos sym) $ logMessage g let name = view SymbolT.name sym - pos = view SymbolT.pos sym case name of - TName p b -> insertGlobal p name.key sym - VName p b -> insertGlobal p name.key sym + TName p b -> enterWith insupd p name.key sym + VName p b -> enterWith insupd p name.key sym MName t b -> do g <- getST - let tsy = g.findit t - case tsy of + case g.findit t of Nothing -> do let qn = t.nice g - E.error pos (msgdoc("namespace `" ++ qn ++ "` does not exist")) + E.error (view SymbolT.pos sym) $ msgdoc $ "namespace `" ++ qn ++ "` does not exist" Just (SymbolT.I typi) -> case SymMeth.fromSymbol sym of Just ameth -> do - meth <- insertSym SymMeth.toSymbol typi.meth name.key ameth - updateGlobal t.pack t.key $ SymbolT.I typi.{meth} + meth <- enterSym insupd SymMeth.toSymbol typi.meth name.key ameth + enterWith DoUpdate t.pack t.key $ SymbolT.I typi.{meth} Just typ -> case preview SymbolT.env typ of Just typEnv -> do - env <- insertSym id typEnv name.key sym - updateGlobal t.pack t.key (set SymbolT.env env typ) - Nothing -> E.fatal pos (msgdoc ("no environment: " ++ t.nice g)) - Local {} -> do - g <- getST - E.fatal pos (text ("local passed to enterbyname " ++ nice sym g)) + env <- enterSym insupd id typEnv name.key sym + enterWith DoUpdate t.pack t.key (set SymbolT.env env typ) + Nothing -> E.fatal (view SymbolT.pos sym) $ msgdoc $ "no environment: " ++ t.nice g + Local uid _ -> enterLocal insupd sym uid + where + logMessage g = fill $ case insupd of + DoUpdate -> + [ text $ "insUpdSymByName " ++ show insupd + , lit $ view SymbolT.sid sym + , text $ concat + [ sym.nice g + , " :: " + , maybe "" (\typ -> typ.nice g) $ preview SymbolT.typ sym + , ", " + , maybe "" (\SymV{state} -> show state) $ preview SymbolT._V sym + ]] + DoInsert -> break $ unwords $ + [ "insUpdSymByName" + , show insupd + , sym.nice g + , show (view SymbolT.sid sym) + ] ++ + case sym of + SymbolT.V SymV{typ} | not (isPSigma typ) -> ["::", typ.nicer g] + _ -> [] + + enterSym :: InsUpd -> (sym -> Symbol) -> TreeMap String sym -> String -> sym -> StG (TreeMap String sym) + enterSym DoInsert = insertSym + enterSym DoUpdate = updateSym + + +private enterLocal :: InsUpd -> Symbol -> Int -> StG () +private enterLocal DoInsert sym _ = do + g <- getST + E.fatal (view SymbolT.pos sym) (text ("local passed to enterbyname " ++ nice sym g)) +private enterLocal DoUpdate sym uid = do + let symv = toSymVBecauseLocal sym + when (symv.sid != uid) do + E.fatal symv.pos (text("changeSym: name =" ++ show symv.name + ++ ", sid=" ++ show symv.sid)) + changeST Global.{locals <- TreeMap.updatekvI uid symv} {-- create a symbolic link to given qname -} From 3ac3df80a1e043942dace326ad5116467320fbe9 Mon Sep 17 00:00:00 2001 From: matil019 Date: Sat, 26 Oct 2019 14:15:52 +0900 Subject: [PATCH 63/95] Change the type of SymC.env to SymMeth SymC.env was renamed to SymC.meth and can now accept SymL and SymV only. The lens SymbolT.env was removed because SymT is the only type that has an 'env'. --- frege/compiler/Classes.fr | 20 +++++++++--------- frege/compiler/GenMeta.fr | 4 ++-- frege/compiler/Main.fr | 4 ++-- frege/compiler/common/SymbolTable.fr | 16 +++++++-------- frege/compiler/common/Trans.fr | 4 ++-- frege/compiler/gen/java/Common.fr | 6 +++--- frege/compiler/gen/java/InstanceCode.fr | 27 ++++++++++++------------- frege/compiler/passes/Enter.fr | 2 +- frege/compiler/passes/Final.fr | 4 ++-- frege/compiler/passes/Imp.fr | 6 +++--- frege/compiler/passes/Strict.fr | 2 +- frege/compiler/types/Symbols.fr | 24 +++++++++++----------- frege/tools/Doc.fr | 6 +++--- frege/tools/Splitter.fr | 2 +- frege/tools/doc/Utilities.fr | 6 +++--- 15 files changed, 65 insertions(+), 68 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index bfd6bf7e..db1eab24 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -147,8 +147,8 @@ passC = do qn <- symc.supers, sym <- g.findit qn ] - kind <- foldM (sigmaKind symc.tau.var) superkind [ sym | - (sym@(SymbolT.V SymV{typ,anno,nativ})) <- values symc.env, + kind <- foldM (sigmaKind symc.tau.var) superkind [ sym.toSymbol | + (sym@(SymMeth.V SymV{typ,anno,nativ})) <- values symc.meth, anno || isJust nativ, not (isPSigma typ), ] @@ -157,7 +157,7 @@ passC = do changeSym $ SymbolT.C symc.{tau <- Tau.{kind = newkind}} -- update class var symc <- U.findC symc.name foreach symc.supers (supercheck $ SymbolT.C symc) - foreach (values symc.env) (methodcheck symc . unsafePartialView SymbolT._Meth) + foreach (values symc.meth) (methodcheck symc) nothing -> E.fatal Position.null (text ("lost class " ++ QName.nice qcls g)) superKind symc ka (SymbolT.C supb) = do case K.unifyKind ka supb.tau.kind of @@ -491,13 +491,13 @@ instForThisClass iname tname cname = do | otherwise = do E.logmsg TRACE6 isym.pos (text ("refresh " ++ tname.nice g ++ " instance of " ++ csym.nice g)) - foreach (map (view SymbolT.name) (values csym.env)) + foreach (map (view SymMeth.name) (values csym.meth)) (funForCIT cname iname tname) stio () Nothing -> do E.logmsg TRACE6 isym.pos (text ("make " ++ tname.nice g ++ " an instance of " ++ csym.nice g)) - foreach (map (view SymbolT.name) (values csym.env)) (funForCIT cname iname tname) + foreach (map (view SymMeth.name) (values csym.meth)) (funForCIT cname iname tname) csym <- U.findC cname changeSym $ SymbolT.C csym.{insts <- ((tsym.name, iname):)} @@ -707,9 +707,9 @@ tcInstMethod [] _ msym = do tcInstMethod (sc:scs) isym msym = do g <- getST - case sc.env.lookupS (view SymMeth.name msym).key of + case sc.meth.lookupS (view SymMeth.name msym).key of Nothing -> tcInstMethod scs isym msym - Just (SymbolT.V SymV{typ=(s@ForAll sbnd srho)}) | not (isPSigma s) = do + Just (SymMeth.V SymV{typ=(s@ForAll sbnd srho)}) | not (isPSigma s) = do g <- getST let !mtnice = case isPSigma sig of true -> "None"; false -> sig.nicer g !csig = ForAll (filter ((sc.tau.var!=) . _.var) sbnd) srho @@ -751,10 +751,8 @@ tcInstMethod (sc:scs) isym msym = do SymMeth.V msymv -> changeSym $ SymbolT.V msymv.{typ = msig, anno = true} _ -> pure () other -> E.fatal isym.pos (msgdoc ("RhoTau expected, got " ++ rhotau.nicer g)) - Just (SymbolT.V (symv@SymV {typ=sig})) | isPSigma sig -> do + Just (SymMeth.V (symv@SymV {typ=sig})) | isPSigma sig -> do E.fatal symv.pos (text (symv.nice g ++ " of " ++ sc.nice g ++ " is not annotated")) -- Some class has a default method that links somewhere else -- The method was introduced in a super class - Just (SymbolT.L _) -> tcInstMethod scs isym msym - Just other -> do - E.fatal (view SymbolT.pos other) (text (other.nice g ++ " in " ++ sc.nice g)) + Just (SymMeth.L _) -> tcInstMethod scs isym msym diff --git a/frege/compiler/GenMeta.fr b/frege/compiler/GenMeta.fr index 31c1551d..1d6e1208 100644 --- a/frege/compiler/GenMeta.fr +++ b/frege/compiler/GenMeta.fr @@ -630,8 +630,8 @@ annoSymC :: SymC Global -> StG DOCUMENT annoSymC sym = do g ← getST tau <- tauIndex sym.tau - meml <- envLinks $ values sym.env - memv <- envValues $ values sym.env + meml <- envLinks $ map _.toSymbol $ values sym.meth + memv <- envValues $ map _.toSymbol $ values sym.meth let a = meta g "SymC" [ ("offset", anno sym.pos.first.offset), ("name", annoG g sym.name), diff --git a/frege/compiler/Main.fr b/frege/compiler/Main.fr index 5c3372ed..2654b81f 100644 --- a/frege/compiler/Main.fr +++ b/frege/compiler/Main.fr @@ -268,8 +268,8 @@ makeFile glob sts = do none → do u ← uniqid enter $ set SymbolT.sid u $ case sym of - SymbolT.I symi -> SymbolT.I symi.{meth=empty} - _ -> set SymbolT.env empty $ sym + SymbolT.T symt -> SymbolT.T symt.{env=empty} + _ -> set SymbolT.meth empty $ sym E.logmsg TRACEZ Position.null ( text "makeFile: entered" <+> (text (sym.nice g)) diff --git a/frege/compiler/common/SymbolTable.fr b/frege/compiler/common/SymbolTable.fr index a5cffb00..62e0318f 100644 --- a/frege/compiler/common/SymbolTable.fr +++ b/frege/compiler/common/SymbolTable.fr @@ -161,14 +161,14 @@ private insUpdSymByName insupd sym = do Nothing -> do let qn = t.nice g E.error (view SymbolT.pos sym) $ msgdoc $ "namespace `" ++ qn ++ "` does not exist" - Just (SymbolT.I typi) -> case SymMeth.fromSymbol sym of - Just ameth -> do - meth <- enterSym insupd SymMeth.toSymbol typi.meth name.key ameth - enterWith DoUpdate t.pack t.key $ SymbolT.I typi.{meth} - Just typ -> case preview SymbolT.env typ of - Just typEnv -> do - env <- enterSym insupd id typEnv name.key sym - enterWith DoUpdate t.pack t.key (set SymbolT.env env typ) + Just (SymbolT.T typt) -> do + env <- enterSym insupd id typt.env name.key sym + enterWith DoUpdate t.pack t.key $ SymbolT.T typt.{env} + Just typ -> case preview SymbolT.meth typ of + Just typMeth -> case SymMeth.fromSymbol sym of + Just ameth -> do + meth <- enterSym insupd SymMeth.toSymbol typMeth name.key ameth + enterWith DoUpdate t.pack t.key $ set SymbolT.meth meth typ Nothing -> E.fatal (view SymbolT.pos sym) $ msgdoc $ "no environment: " ++ t.nice g Local uid _ -> enterLocal insupd sym uid where diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index 06379aae..68d88fc6 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -381,8 +381,8 @@ classMethodOfInstMethod pos inst base = do case g.findit inst of Just isym | SymbolT.I SymI{clas} <- isym = case g.findit clas of Just csym | SymbolT.C SymC{supers} <- csym = do - let sym = head [ sym | c <- clas:supers, SymbolT.C SymC{env} <- g.findit c, - SymbolT.V sym <- values env, + let sym = head [ sym | c <- clas:supers, SymbolT.C SymC{meth} <- g.findit c, + SymMeth.V sym <- values meth, sym.name.base == base ] return sym other -> E.fatal pos (text ("classMethodOfInstMethod: " ++ nice clas g ++ " not a type class.")) diff --git a/frege/compiler/gen/java/Common.fr b/frege/compiler/gen/java/Common.fr index 3018dca0..ad442472 100644 --- a/frege/compiler/gen/java/Common.fr +++ b/frege/compiler/gen/java/Common.fr @@ -27,7 +27,7 @@ import Compiler.types.Global(StIO, StG, Symbol, SymInfo8, Global(), GenSt(), isReserved) import Compiler.enums.TokenID(QUALIFIER) -import Compiler.types.Symbols(SymD, SymT, SymV, SymC, SymI, SymbolT) +import Compiler.types.Symbols(SymD, SymT, SymV, SymC, SymI, SymMeth, SymbolT) import Compiler.types.JNames(JName, memberOf) import Compiler.types.QNames(TName) import Compiler.types.Packs(pPreludeIO, pPreludeArrays, pPreludeList) @@ -877,8 +877,8 @@ unsafeCast g sym = case sym.name of | Just (SymbolT.I SymI{clas}) <- g.findit tynm , Just (SymbolT.C SymC{supers}) <- g.findit clas , mems <- [ cmem | Just (SymbolT.C symc) <- map g.findit (clas:supers) - , cmem <- symc.env.lookupS base - , needsUnchecked snd (view SymbolT.name cmem) Something] + , cmem <- symc.meth.lookupS base + , needsUnchecked snd (view SymMeth.name cmem) Something] = not (null mems) _ = false diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index 2d929928..8344d307 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -79,8 +79,7 @@ import Compiler.gen.java.VarCode(varCode, compiling, genExpression, genExpr) classCode :: Symbol -> StG [JDecl] classCode (SymbolT.C (sym@SymC{tau = TVar{var,kind}})) = do -- type class g <- getST - let unsafeToSymV s = case s of { SymbolT.V x -> x; } - let vals = map unsafeToSymV $ values sym.env + let vals = map (unsafePartialView SymMeth._V) $ values sym.meth special = isSpecialClass sym abstrFuns ← mapSt (abstractFun sym) vals let name = (symJavaName g (SymbolT.C sym)).base @@ -116,8 +115,8 @@ lowerKindSpecialClasses = do let unsafeToSymC s = case s of { SymbolT.C x -> x; } let items = [ (c,v) | n <- specialClassNames , c <- unsafeToSymC <$> g.findit (TName pPreludeList n) - , v <- Map.values c.env ] - mapM_ (uncurry lowerKindAbstractFun) items + , v <- Map.values c.meth ] + mapM_ (\(c, v) -> lowerKindAbstractFun c v.toSymbol) items return g lowerKindAbstractFun :: SymC Global -> Symbol -> StG () @@ -207,8 +206,8 @@ instanceCode (SymbolT.I sym) = do -- instance definition special = isSpecialClass csym -- the functions we must provide in the instance superMethods = [ m.name.base | c <- classes, - SymbolT.C SymC{env} <- g.findit c, - SymbolT.V m <- values env ] + SymbolT.C SymC{meth} <- g.findit c, + SymMeth.V m <- values meth ] -- links in types that point to instance members of this class and its superclasses -- The goal is to have (links to) implementations of all super class methods. methods2 = case instTSym sym.typ g of @@ -352,14 +351,14 @@ instFun symc symi mname = do let classnames = symc.name:symc.supers special = isSpecialClass symc cmems = [ m | cln <- classnames - , SymbolT.C SymC{env} <- g.findit cln - , m <- env.lookupS mname.base ] + , SymbolT.C SymC{meth} <- g.findit cln + , m <- meth.lookupS mname.base ] case cmems of [] → E.fatal symi.pos (text "trying to instFun " <+> text (nicer mname g) <+> text " but no class member found.") cmem:_ → do -- replace symc with class where method was introduced - symc <- findC (view SymbolT.name cmem).tynm + symc <- findC (view SymMeth.name cmem).tynm E.logmsg TRACEG symi.pos (text "instFun" <+> text (nicer sym g) <+> text "for" <+> text (nicer cmem g)) -- We need to tweek the types a bit so that java type variables won't conflict. @@ -380,14 +379,14 @@ instFun symc symi mname = do -- op :: forall a b y c. (Y b, X y) => T a b -> y -> c E.logmsg TRACEG symi.pos ( text (nicer sym.name g) <+> text " :: " <+> text (nicer sym.typ g) - text (nicer (view SymbolT.name cmem) g) <+> text " :: " <+> text (nicer (unsafePartialView SymbolT.typ cmem) g) + text (nicer (view SymMeth.name cmem) g) <+> text " :: " <+> text (nicer (unsafePartialView SymbolT.typ cmem.toSymbol) g) ) - let otvs = filter ((`elem` symi.typ.vars) . Tau.var) (unsafePartialView SymbolT.typ cmem).tvars - orep = filter (`notElem` ((unsafePartialView SymbolT.typ cmem).vars)) (allBinders g) + let otvs = filter ((`elem` symi.typ.vars) . Tau.var) (unsafePartialView SymbolT.typ cmem.toSymbol).tvars + orep = filter (`notElem` ((unsafePartialView SymbolT.typ cmem.toSymbol).vars)) (allBinders g) substBound :: TreeMap String Tau -> [Tau] -> [Tau] substBound subst xs = map (\tv -> maybe tv _.{kind=tv.kind} (lookup tv.var subst)) xs subst1 = Map.fromList [ (tv.var, tv.{var=s}) | (s,tv) ← zip orep otvs] - typ1 = ForAll (substBound subst1 (unsafePartialView SymbolT.typ cmem).bound) (substRho subst1 (unsafePartialView SymbolT.typ cmem).rho) + typ1 = ForAll (substBound subst1 (unsafePartialView SymbolT.typ cmem.toSymbol).bound) (substRho subst1 (unsafePartialView SymbolT.typ cmem.toSymbol).rho) E.logmsg TRACEG symi.pos ( text "(1) renamed type :: " <+> text (nicer typ1 g) @@ -528,7 +527,7 @@ instFun symc symi mname = do -- finally make the function pure JMethod{attr = if special || unchecked rex - || needsUnchecked fst (view SymbolT.name cmem) (Map.lookupDefault Something cvar.var jsubstr) + || needsUnchecked fst (view SymMeth.name cmem) (Map.lookupDefault Something cvar.var jsubstr) then attrs [JUnchecked, JPublic, JFinal, JOverride] else attrs [JPublic, JFinal, JOverride], gvars = targs g methty, diff --git a/frege/compiler/passes/Enter.fr b/frege/compiler/passes/Enter.fr index f6081e1f..77efda1b 100644 --- a/frege/compiler/passes/Enter.fr +++ b/frege/compiler/passes/Enter.fr @@ -194,7 +194,7 @@ enter1ClaDcl fname (d@ClaDcl {pos}) = do SubSt.{idKind <- insert (KeyTk pos.first) (Right tname)}} ST.enter $ SymbolT.C (SymC {sid=0, pos=d.pos, vis=d.vis, doc=d.doc, name=tname, - tau=transTVar d.clvar, supers=[], insts=[], env=empty}) + tau=transTVar d.clvar, supers=[], insts=[], meth=empty}) let vdefs = map (\def -> def.chgVis $ max d.vis) d.members xdefs = filter ((>d.vis) . _.vis) d.members diff --git a/frege/compiler/passes/Final.fr b/frege/compiler/passes/Final.fr index 3e168ca3..2c904a07 100644 --- a/frege/compiler/passes/Final.fr +++ b/frege/compiler/passes/Final.fr @@ -48,8 +48,8 @@ cleanSymtab = do mapEnvSymV :: (Symbols.SymV Global -> Symbols.SymV Global) -> Symbol -> Symbol mapEnvSymV mapsymv sym = case sym of SymbolT.V symv -> SymbolT.V $ mapsymv symv - SymbolT.I symi -> SymbolT.I $ symi.{meth <- fmap (over SymMeth._V mapsymv)} - _ -> over SymbolT.env (fmap (mapEnvSymV mapsymv)) sym + SymbolT.T symt -> SymbolT.T $ symt.{env <- fmap (mapEnvSymV mapsymv)} + _ -> over SymbolT.meth (fmap (over SymMeth._V mapsymv)) sym swap :: (a,b) -> (b,a) swap (a,b) = (b,a) -- !kAarray = (arrayFromIndexList . map swap . each) empty -- g.gen.kTree diff --git a/frege/compiler/passes/Imp.fr b/frege/compiler/passes/Imp.fr index 92c1f386..65cfed75 100644 --- a/frege/compiler/passes/Imp.fr +++ b/frege/compiler/passes/Imp.fr @@ -334,11 +334,11 @@ linkHere ns pack (item@Item {publik,name,members,alias=newn}) sym = do | Just ms <- members = do let nms = map ImportItem.{name <- (`qBy` item.name) • SName.id} ms foreach nms (linkItem ns pack) - SymbolT.C SymC{env} + SymbolT.C symc | Nothing <- members = do -- link class methods let meth = [ item.{name <- (pos.first.{tokid=VARID, value=name.base} `qBy`), members = Nothing, alias = name.base} - | SymbolT.V SymV{vis, name} <- values env, + | SymMeth.V SymV{vis, name} <- values symc.meth, vis == Public || vis == Abstract, not (defined name.base) ] -- import only yet undefined class members -- here = g.thisTab @@ -556,7 +556,7 @@ importClassData pos why pack = do tau = nTau sym.tau, supers = sups, insts = zip ins1 ins2, - env = empty} + meth = empty} where ins1 = mapqs sym.ins1 ins2 = mapqs sym.ins2 diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index a9c930ba..de2814d7 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -55,7 +55,7 @@ pass = do -- bring default class methods in good shape g <- getST - let classmethods = [ sym | SymbolT.C SymC{env} <- values g.thisTab, SymbolT.V (sym@SymV{expr = Just _}) <- values env ] + let classmethods = [ sym | SymbolT.C SymC{meth} <- values g.thisTab, SymMeth.V (sym@SymV{expr = Just _}) <- values meth ] foreach classmethods easyClassMethodSym stio ("functions", length names) diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 384500ee..803554b5 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -49,7 +49,7 @@ data SymD global = !SymD data SymC global = !SymC { sid::Int, pos::Position, vis::Visibility, doc::Maybe String, name::QName, tau::Tau, supers::[QName], insts::[(QName, QName)], - env::TreeMap String (SymbolT global) + meth::TreeMap String (SymMeth global) } --- instance @@ -183,15 +183,6 @@ data SymbolT global = doc f (I s) = (\doc -> I s.{doc}) <$> f s.doc doc f (V s) = (\doc -> V s.{doc}) <$> f s.doc doc f (A s) = (\doc -> A s.{doc}) <$> f s.doc - -- env :: Traversal' (SymbolT g) (TreeMap String (SymbolT g)) - env :: Applicative f => (TreeMap String (SymbolT g) -> f (TreeMap String (SymbolT g))) -> SymbolT g -> f (SymbolT g) - env f (T s) = (\env -> T s.{env}) <$> f s.env - env _ (sym@(L _)) = pure sym - env _ (sym@(D _)) = pure sym - env f (C s) = (\env -> C s.{env}) <$> f s.env - env _ (sym@(I _)) = pure sym - env _ (sym@(V _)) = pure sym - env _ (sym@(A _)) = pure sym -- kind :: Traversal' (SymbolT g) Kind kind :: Applicative f => (Kind -> f Kind) -> SymbolT g -> f (SymbolT g) kind f (T s) = (\kind -> T s.{kind}) <$> f s.kind @@ -201,6 +192,15 @@ data SymbolT global = kind _ (sym@(I _)) = pure sym kind _ (sym@(V _)) = pure sym kind f (A s) = (\kind -> A s.{kind}) <$> f s.kind + -- meth :: Traversal' (SymbolT g) (TreeMap String (SymMeth g)) + meth :: Applicative f => (TreeMap String (SymMeth g) -> f (TreeMap String (SymMeth g))) -> SymbolT g -> f (SymbolT g) + meth _ (sym@(T _)) = pure sym + meth _ (sym@(L _)) = pure sym + meth _ (sym@(D _)) = pure sym + meth f (C s) = (\meth -> C s.{meth}) <$> f s.meth + meth f (I s) = (\meth -> I s.{meth}) <$> f s.meth + meth _ (sym@(V _)) = pure sym + meth _ (sym@(A _)) = pure sym -- name :: Lens' (SymbolT g) QName name :: Functor f => (QName -> f QName) -> SymbolT g -> f (SymbolT g) name f (T s) = (\name -> T s.{name}) <$> f s.name @@ -285,8 +285,8 @@ data SymbolT global = --- a generalized read-only view of 'env' env' :: SymbolT g -> Maybe (TreeMap String (SymbolT g)) - env' (I s) = Just $ fmap SymMeth.toSymbol s.meth - env' s = preview env s + env' (T s) = Just s.env + env' s = fmap (fmap SymMeth.toSymbol) $ preview meth s -- TODO add for performance? -- envValues' :: SymbolT g -> Maybe [SymbolT g] diff --git a/frege/tools/Doc.fr b/frege/tools/Doc.fr index 6b51189e..099ed183 100644 --- a/frege/tools/Doc.fr +++ b/frege/tools/Doc.fr @@ -324,7 +324,7 @@ mkLinks ns pack = do I.linkHere (ns.unNS) pack protoItem.{name=Simple (view SymbolT.pos sym).first.{value=(view SymbolT.name sym).base}, - members = if isJust (preview SymbolT.env rsym) && not (Lens.is SymbolT._I rsym) + members = if isJust (SymbolT.env' rsym) && not (Lens.is SymbolT._I rsym) then Just [] else Nothing, alias=(view SymbolT.name sym).base} sym @@ -439,9 +439,9 @@ continueNamespaces fp = do other -> true noclassmember f _ = true allfuns = funs ++ [ s | syms <- [csyms, isyms, dsyms], sym :: Symbol <- syms, - env <- preview SymbolT.env sym, + env <- SymbolT.env' sym, s <- values env, - isJust (preview SymbolT.typ s) ] + Lens.has SymbolT.typ s ] ordfuns = groupBy (using $ unsafePartialView SymbolT.typ) (sortBy (comparing $ unsafePartialView SymbolT.typ) allfuns) expfuns = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.L SymL{pos,vis,alias}) <- values g.thisTab, vis == Public, diff --git a/frege/tools/Splitter.fr b/frege/tools/Splitter.fr index 219cf39e..a4643b4f 100644 --- a/frege/tools/Splitter.fr +++ b/frege/tools/Splitter.fr @@ -555,7 +555,7 @@ symDep g (SymbolT.I SymI{clas, typ, meth}) = fold L.union tree (map (symDep g . where tree = nameDep g sigt clas sigt = sigmaDep g typ -symDep g (SymbolT.C SymC{supers, env}) = fold L.union tree (map (symDep g) (values env)) +symDep g (SymbolT.C SymC{supers, meth}) = fold L.union tree (map (symDep g . _.toSymbol) (values meth)) where tree = fold (nameDep g) empty supers symDep g sym = error ("don't know dependencies of " ++ nicer sym g) diff --git a/frege/tools/doc/Utilities.fr b/frege/tools/doc/Utilities.fr index 592a0bb5..5de175f5 100644 --- a/frege/tools/doc/Utilities.fr +++ b/frege/tools/doc/Utilities.fr @@ -203,20 +203,20 @@ docSym g (SymbolT.A (syma@SymA{name, vars, typ=ForAll _ rho, doc})) = (code titl :- text " = " :- dRho g.{options <- Options.{flags <- Compilerflags.flagSet SPECIAL}} rho [] -docSym g (SymbolT.C SymC{name,tau,doc,supers,insts,env}) = (code title, content) where +docSym g (SymbolT.C SymC{name,tau,doc,supers,insts,meth}) = (code title, content) where title = (bold • text $ "class ") :- dCtx g (map (\c -> Ctx {pos=Position.null, cname=c, tau}) supers) :- text " " :- Label name (text name.base) :- text " " :- dTau g tau - members = sortBy (comparing $ view SymbolT.name) (values env) + members = sortBy (comparing $ view SymMeth.name) (values meth) ki (tname, iname) = Ref iname (text (nice tname g)) content = [ p | d <- [docit g doc, if null insts then [] else [h3 (text "Known Instances"), par (joint ", " ki insts)], if null members then [] else [h3 (text "Member Functions"), - DL (Just "func") (map (docSym g) members)]], + DL (Just "func") (map (docSym g . _.toSymbol) members)]], p <- d ] docSym g (SymbolT.I SymI{pos, name, doc, clas, typ=ForAll _ rho, meth}) = (code title, content) where From cdd5ba172cd5f54418e48558b8550ad3f1bad370 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 15:52:31 +0900 Subject: [PATCH 64/95] Replace a partial function in InstanceCode with a new error message lowerKindSpecialClasses has a partial function that cannot be avoided. The error case is an internal error (caused by bad frege.Prelude.List). --- frege/compiler/gen/java/InstanceCode.fr | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index 8344d307..7453af4d 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -112,12 +112,16 @@ classCode sym = do --- Returns the compiler state prior to this action, which must be restored afterwards. lowerKindSpecialClasses = do g ← getST - let unsafeToSymC s = case s of { SymbolT.C x -> x; } let items = [ (c,v) | n <- specialClassNames - , c <- unsafeToSymC <$> g.findit (TName pPreludeList n) + , c <- findSpecialClass g n , v <- Map.values c.meth ] mapM_ (\(c, v) -> lowerKindAbstractFun c v.toSymbol) items return g + where + findSpecialClass g n = case g.findit (TName pPreludeList n) of + Just (SymbolT.C symc) -> Just symc + Just _ -> error $ "lowerKindSpecialClasses: non-class name in specialClassNames: " ++ show n + Nothing -> Nothing lowerKindAbstractFun :: SymC Global -> Symbol -> StG () lowerKindAbstractFun symc sym = do From eba635651e2266c9b0650c73e802fd5f4d22d3cb Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 16:19:33 +0900 Subject: [PATCH 65/95] View SymMeth as SymV in InstanceCode to reduce unsafePartialView --- frege/compiler/gen/java/InstanceCode.fr | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index 7453af4d..1f4907c4 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -354,15 +354,16 @@ instFun symc symi mname = do sym <- findV mname let classnames = symc.name:symc.supers special = isSpecialClass symc - cmems = [ m | cln <- classnames - , SymbolT.C SymC{meth} <- g.findit cln - , m <- meth.lookupS mname.base ] + cmems = [ unsafePartialView SymMeth._V m + | cln <- classnames + , SymbolT.C SymC{meth} <- g.findit cln + , m <- meth.lookupS mname.base ] case cmems of [] → E.fatal symi.pos (text "trying to instFun " <+> text (nicer mname g) <+> text " but no class member found.") cmem:_ → do -- replace symc with class where method was introduced - symc <- findC (view SymMeth.name cmem).tynm + symc <- findC cmem.name.tynm E.logmsg TRACEG symi.pos (text "instFun" <+> text (nicer sym g) <+> text "for" <+> text (nicer cmem g)) -- We need to tweek the types a bit so that java type variables won't conflict. @@ -383,14 +384,14 @@ instFun symc symi mname = do -- op :: forall a b y c. (Y b, X y) => T a b -> y -> c E.logmsg TRACEG symi.pos ( text (nicer sym.name g) <+> text " :: " <+> text (nicer sym.typ g) - text (nicer (view SymMeth.name cmem) g) <+> text " :: " <+> text (nicer (unsafePartialView SymbolT.typ cmem.toSymbol) g) + text (nicer cmem.name g) <+> text " :: " <+> text (nicer cmem.typ g) ) - let otvs = filter ((`elem` symi.typ.vars) . Tau.var) (unsafePartialView SymbolT.typ cmem.toSymbol).tvars - orep = filter (`notElem` ((unsafePartialView SymbolT.typ cmem.toSymbol).vars)) (allBinders g) + let otvs = filter ((`elem` symi.typ.vars) . Tau.var) cmem.typ.tvars + orep = filter (`notElem` cmem.typ.vars) (allBinders g) substBound :: TreeMap String Tau -> [Tau] -> [Tau] substBound subst xs = map (\tv -> maybe tv _.{kind=tv.kind} (lookup tv.var subst)) xs subst1 = Map.fromList [ (tv.var, tv.{var=s}) | (s,tv) ← zip orep otvs] - typ1 = ForAll (substBound subst1 (unsafePartialView SymbolT.typ cmem.toSymbol).bound) (substRho subst1 (unsafePartialView SymbolT.typ cmem.toSymbol).rho) + typ1 = ForAll (substBound subst1 cmem.typ.bound) (substRho subst1 cmem.typ.rho) E.logmsg TRACEG symi.pos ( text "(1) renamed type :: " <+> text (nicer typ1 g) @@ -531,7 +532,7 @@ instFun symc symi mname = do -- finally make the function pure JMethod{attr = if special || unchecked rex - || needsUnchecked fst (view SymMeth.name cmem) (Map.lookupDefault Something cvar.var jsubstr) + || needsUnchecked fst cmem.name (Map.lookupDefault Something cvar.var jsubstr) then attrs [JUnchecked, JPublic, JFinal, JOverride] else attrs [JPublic, JFinal, JOverride], gvars = targs g methty, From 5634a4f1729664ae9dc35ea521f6b963f86bb4d0 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 16:26:02 +0900 Subject: [PATCH 66/95] Treat non-SymV as non-existent in Transdef.ordInfix --- frege/compiler/passes/Transdef.fr | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index dce84515..740b5144 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -1101,8 +1101,8 @@ ordInfix fname (orig@Infx{name, left, right}) left <- ordInfix fname Infx{name, left, right=right.left} return Infx{name=right.name, left, right=right.right} bindright = return Infx{name, left, right} -- a $ x+1 == a $ (x+1) - case (fmap SymVal.fromSymbol $ g.findit op1, fmap SymVal.fromSymbol $ g.findit op2) of - (Just (Just sym1), Just (Just sym2)) -> + case (SymVal.fromSymbol =<< g.findit op1, SymVal.fromSymbol =<< g.findit op2) of + (Just sym1, Just sym2) -> if prec (view SymVal.op sym1) > prec (view SymVal.op sym2) then bindleft else if prec (view SymVal.op sym1) < prec (view SymVal.op sym2) then bindright else -- equal precedence From 1df01813b57ea2c5eb52133f71794a8c807562c4 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 16:28:11 +0900 Subject: [PATCH 67/95] Remove a "may evaluate to false" warning in Classes.tcInstMethod A redundant guard which introduced that error was removed. --- frege/compiler/Classes.fr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index db1eab24..15d8ec16 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -751,7 +751,7 @@ tcInstMethod (sc:scs) isym msym = do SymMeth.V msymv -> changeSym $ SymbolT.V msymv.{typ = msig, anno = true} _ -> pure () other -> E.fatal isym.pos (msgdoc ("RhoTau expected, got " ++ rhotau.nicer g)) - Just (SymMeth.V (symv@SymV {typ=sig})) | isPSigma sig -> do + Just (SymMeth.V (symv@SymV {typ=sig})) -> do -- isPSigma sig == true E.fatal symv.pos (text (symv.nice g ++ " of " ++ sc.nice g ++ " is not annotated")) -- Some class has a default method that links somewhere else -- The method was introduced in a super class From 61f2681467324625b436a1e80ee80a1b223a4d53 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 16:37:19 +0900 Subject: [PATCH 68/95] Remove uses of unsafePartialView in Classes Instead of crashing, erroneous cases are simply treated as un-matched cases. --- frege/compiler/Classes.fr | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index 15d8ec16..d8ef47ab 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -45,7 +45,7 @@ import Data.TreeMap as TM(keys, values, TreeMap, insert, delete, lookup) import Data.List as DL(uniq, sort, sortBy, maximumBy) import Data.Graph (stronglyConnectedComponents tsort) -import frege.compiler.common.Lens (preview, set, unsafePartialView, view) +import frege.compiler.common.Lens (preview, set, view) import Compiler.enums.Flags as Compilerflags(TRACE6) import Compiler.enums.Visibility @@ -587,21 +587,23 @@ funForCIT cname iname tname (mname@MName _ base) = do ++ "` given as implementation of instance member `" ++ nicer member g ++ "` must be annotated.")) changeSym $ SymbolT.I isym.{ meth <- delete member.key } - Just osym | not (g.ourSym osym) || implemented (unsafePartialView SymbolT._Val osym) = case tvmb of + Just osym' + | Just osym <- preview SymbolT._Val osym' + , not (g.ourSym osym.toSymbol) || implemented osym -> case tvmb of Just (SymbolT.L (tsym@SymL{alias=same})) - | same == alias = changeSym $ set SymbolT.op msym.op osym -- copy op + | same == alias = changeSym $ SymVal.toSymbol $ set SymVal.op msym.op osym -- copy op | same == member = do -- this is the normal case after enter -- remove one indirection changeSym $ SymbolT.L tsym.{alias} - changeSym $ set SymbolT.op msym.op osym + changeSym $ SymVal.toSymbol $ set SymVal.op msym.op osym Just err -> E.error ipos (msgdoc ("definition of " ++ member.nicer g ++ " not allowed because " ++ err.nicer g ++ " already exists.")) Nothing -> do E.logmsg TRACE6 ipos (text (mname.nice g ++ " not yet implemented in " ++ tsym.nice g)) - linkq (MName tname base) osym - changeSym $ set SymbolT.op msym.op osym + linkq (MName tname base) osym.toSymbol + changeSym $ SymVal.toSymbol $ set SymVal.op msym.op osym Just osym -> E.error ipos (text (nicer osym g ++ " is not implemented.")) Nothing -> do E.fatal ipos (msgdoc (nicer member g ++ " links to " ++ alias.nicer g ++ ", but the latter doesn't exist.")) @@ -632,17 +634,17 @@ funForCIT cname iname tname (mname@MName _ base) = do -- Issue 126: can be alias to type member | MName yname other ← alias, yname == tname, - Just impl <- g.follow (SymbolT.L ali) = do - if implemented $ unsafePartialView SymbolT._Val impl + Just impl <- preview SymbolT._Val =<< g.follow (SymbolT.L ali) = do + if implemented impl then do - E.logmsg TRACE6 (view SymbolT.pos impl) (text (mname.nice g ++ " not yet implemented in " ++ isym.nice g)) + E.logmsg TRACE6 (view SymVal.pos impl) (text (mname.nice g ++ " not yet implemented in " ++ isym.nice g)) E.logmsg TRACE6 isym.pos (text ("copy implementation from " ++ impl.nice g)) - let ivsym = set SymbolT.name (MName iname base) $ set SymbolT.sid 0 $ set SymbolT.op msym.op $ impl - enter ivsym + let ivsym = set SymVal.name (MName iname base) $ set SymVal.sid 0 $ set SymVal.op msym.op $ impl + enter ivsym.toSymbol changeSym $ SymbolT.T tsym.{ env <- delete other } - linkq (MName tname other) ivsym + linkq (MName tname other) ivsym.toSymbol else do - E.error (view SymbolT.pos impl) (msgdoc ("implementation missing for " ++ impl.nicer g)) + E.error (view SymVal.pos impl) (msgdoc ("implementation missing for " ++ impl.nicer g)) | MName yname _ <- alias, Just (SymbolT.I ysym) <- g.findit yname, ysym.clas `notElem` csym.supers, From 6a604001bdecd8870aae4ff7b711e0df980affbb Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 16:40:43 +0900 Subject: [PATCH 69/95] Remove an unused import in Final to avoid warnings --- frege/compiler/passes/Final.fr | 1 - 1 file changed, 1 deletion(-) diff --git a/frege/compiler/passes/Final.fr b/frege/compiler/passes/Final.fr index 2c904a07..5ee58322 100644 --- a/frege/compiler/passes/Final.fr +++ b/frege/compiler/passes/Final.fr @@ -9,7 +9,6 @@ import Compiler.enums.Flags import Compiler.common.ImpExp import Compiler.types.Symbols import Compiler.types.External -import Compiler.Classtools as CT buildMode :: Global -> Bool From c4c77364b45031da613cf39a9b543289975f9fe2 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 16:46:53 +0900 Subject: [PATCH 70/95] Remove uses of partial matches in VarCode Instead of crashing, erroneous cases are simply treated as un-matched cases. --- frege/compiler/gen/java/VarCode.fr | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index ee806875..a560f275 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -9,7 +9,7 @@ import Lib.PP(text, <>, <+>, <+/>, ) import Data.Bits(BitSet, BitSet.member, BitSet.unionE, BitSet.differenceE) import Data.List(partitioned, zip4) -import frege.compiler.common.Lens (view) +import frege.compiler.common.Lens (preview, view) import Compiler.enums.Flags(TRACEG) import Compiler.enums.RFlag as RF(RFlag) @@ -1129,7 +1129,6 @@ genExpr rflg rm ex binds = do <+> text (nicer ft g) <+> text " @@ " <+> text (show rm)) - let unsafeToSymV s = case s of { SymbolT.V x -> x; } let genArgBind ∷ Sigma → JType → ExprT → StG Binding genArgBind sig arm aex @@ -1138,7 +1137,7 @@ genExpr rflg rm ex binds = do Just ft ← aex.typ = case aex of (exx@Vbl{name = Local{uid}}) | Just bind <- lookup uid binds, - Nothing <- g.findit exx.name >>= _.expr . unsafeToSymV, -- pattern bound + Nothing <- g.findit exx.name >>= preview SymbolT._V >>= _.expr, -- pattern bound not bind.ftype.bound.null, -- forall a. .... -- make sure the contexts are in the right order -- we can't pass forall a b. (Num a, Num b) => @@ -1233,27 +1232,26 @@ genExpr rflg rm ex binds = do -- Local Variables are being looked up in the bindings Vbl{name=Local{uid, base}, pos, typ} | Just b ← lookup uid binds = do - let unsafeToSymV s = case s of { SymbolT.V x -> x; } case b.ftype of ForAll{bound, rho} | not (null bound), - Just sym <- g.findit ex.name, + Just (SymbolT.V sym) <- g.findit ex.name, -- exclude local methods - not (isJust (unsafeToSymV sym).expr && (unsafeToSymV sym).depth > 0 && RMethod `member` (unsafeToSymV sym).rkind), - b' ← if (unsafeToSymV sym).depth == 0 && RMethod `member` (unsafeToSymV sym).rkind + not (isJust sym.expr && sym.depth > 0 && RMethod `member` sym.rkind), + b' <- if sym.depth == 0 && RMethod `member` sym.rkind then b.{jex ← JX.invoke []} -- evaluate method CAFs else b = instPatternBound pos b' ft >>= result ForAll{bound, rho} | not (null bound), - Nothing <- g.findit ex.name >>= _.expr . unsafeToSymV, -- pattern bound + Nothing <- g.findit ex.name >>= preview SymbolT._V >>= _.expr, -- pattern bound = instPatternBound pos b ft >>= result _ | Func{} ← b.jtype, - Just sym <- g.findit ex.name, - RMethod `member` (unsafeToSymV sym).rkind, - (unsafeToSymV sym).depth > 0 + Just (SymbolT.V sym) <- g.findit ex.name, + RMethod `member` sym.rkind, + sym.depth > 0 = etaWrap (snd (U.returnType ft.rho)) _ = result b | otherwise = do @@ -1268,8 +1266,7 @@ genExpr rflg rm ex binds = do then etaWrap (snd (U.returnType ft.rho)) else if case g.findit name.tynm of Just (SymbolT.T symt) -> symt.enum - -- symt must be SymT - Nothing -> false + _ -> false then do let item = symJavaName g (SymbolT.D sym) stref = JX.staticMember item From 3b9cefbc1ae5b7cdf46c58b9060c2714143563eb Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 16:52:26 +0900 Subject: [PATCH 71/95] Add a custom partial function in InstanceCode All SymMeths in SymC.meth should have been resolved to SymV in this phase (at least that's how I understand the code). An error here, if any, is an internal error, and is reported as a pure error to help find a bug in the compiler. --- frege/compiler/gen/java/InstanceCode.fr | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index 1f4907c4..60e279ff 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -7,7 +7,7 @@ import Lib.PP (text, <+>, , <+/>, <>) import Data.TreeMap as Map(values, lookup, delete, insert, TreeMap) import Data.List(zip4) -import frege.compiler.common.Lens (over, unsafePartialView, view) +import frege.compiler.common.Lens (over, view) import Compiler.Utilities(findC, findV, forceTau, returnType) import Compiler.Javatypes(subTypeOf) @@ -79,7 +79,7 @@ import Compiler.gen.java.VarCode(varCode, compiling, genExpression, genExpr) classCode :: Symbol -> StG [JDecl] classCode (SymbolT.C (sym@SymC{tau = TVar{var,kind}})) = do -- type class g <- getST - let vals = map (unsafePartialView SymMeth._V) $ values sym.meth + let vals = map symMethAsSymV $ values sym.meth special = isSpecialClass sym abstrFuns ← mapSt (abstractFun sym) vals let name = (symJavaName g (SymbolT.C sym)).base @@ -354,7 +354,7 @@ instFun symc symi mname = do sym <- findV mname let classnames = symc.name:symc.supers special = isSpecialClass symc - cmems = [ unsafePartialView SymMeth._V m + cmems = [ symMethAsSymV m | cln <- classnames , SymbolT.C SymC{meth} <- g.findit cln , m <- meth.lookupS mname.base ] @@ -545,3 +545,7 @@ instFun symc symi mname = do ++ [(attrFinal, pSigma, lazy jt, name) | (jt,name) ← zip vgargs args], body = JBlock{stmts=[JReturn rex]}} + +private symMethAsSymV :: SymMeth Global -> SymV Global +private symMethAsSymV (SymMeth.V symv) = symv +private symMethAsSymV _ = error "InstanceCode: all methods should have been resolved" From da7ebcff1e389a3faa1564c1bcfb28d0539f22d0 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 18:04:11 +0900 Subject: [PATCH 72/95] Add a custom partial function in Global Some functions in Global assumes certain propeties of Symbols. Those assumptions should be correct unless something goes very wrong. An error here, if any, is an internal error, and is reported as a pure error to help find a bug in the compiler. --- frege/compiler/types/Global.fr | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/frege/compiler/types/Global.fr b/frege/compiler/types/Global.fr index 41b4e0bf..2dd74e27 100644 --- a/frege/compiler/types/Global.fr +++ b/frege/compiler/types/Global.fr @@ -8,7 +8,7 @@ import frege.data.TreeMap as TM(TreeMap, each) import frege.java.Net(URLClassLoader) import frege.control.monad.State (State, StateT) -import frege.compiler.common.Lens (preview, unsafePartialView, view) +import frege.compiler.common.Lens (preview, view) import frege.compiler.enums.Flags as Compilerflags(Flag, Flags, isOn, isOff) import frege.compiler.enums.TokenID(TokenID) import frege.compiler.types.Positions @@ -259,20 +259,22 @@ inPrelude p g = (p `elem` map fst preludePacks) --- Determine type symbol of some type --- This is either a function, or basically a 'Tau' type instTSym :: Sigma -> Global -> Maybe (SymT Global) -instTSym (ForAll _ (RhoTau _ tau)) g = instTauSym tau g --- no need to deconstruct this again -instTSym _ {- (ForAll _ (RhoFun{})) -} g = fmap (unsafePartialView SymbolT._T) $ g.findit (TName pPreludeBase "->") - - --- instTSym _ g = Nothing +instTSym (ForAll _ (RhoTau _ tau)) g = instTauSym tau g +instTSym _ g = fmap assertSymT (g.findit (TName pPreludeBase "->")) + where + assertSymT (SymbolT.T symt) = symt + assertSymT _ = error "instTSym: frege.PreludeBase.(->) not a SymT??" --- return type symbol for constructor of tau, if any instTauSym :: Tau -> Global -> Maybe (SymT Global) instTauSym tau g = case tau of - TCon {name} -> fmap (unsafePartialView SymbolT._T) $ Global.findit g name + TCon {name} -> fmap (assertSymT name) $ g.findit name TApp a _ -> instTauSym a g _ -> Nothing + where + assertSymT _ (SymbolT.T symt) = symt + assertSymT name _ = error $ "instTauSym: TCon{name=" ++ show name ++ "} refers to a non-SymT??" --- The names of the java primitive types From 9effb28a213a4e36299fc201d556dbe71bffa653 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 18:09:04 +0900 Subject: [PATCH 73/95] Add an error message to the new error in SymbolTable Since only SymMeth (i.e. SymV or SymL) can be a member of SymC.meth or SymI.meth, if 'sym' is not SymMeth, it is an error. A new error message was added to report it instead of just crashing. --- frege/compiler/common/SymbolTable.fr | 1 + 1 file changed, 1 insertion(+) diff --git a/frege/compiler/common/SymbolTable.fr b/frege/compiler/common/SymbolTable.fr index 62e0318f..173853f4 100644 --- a/frege/compiler/common/SymbolTable.fr +++ b/frege/compiler/common/SymbolTable.fr @@ -169,6 +169,7 @@ private insUpdSymByName insupd sym = do Just ameth -> do meth <- enterSym insupd SymMeth.toSymbol typMeth name.key ameth enterWith DoUpdate t.pack t.key $ set SymbolT.meth meth typ + Nothing -> E.error (view SymbolT.pos sym) $ msgdoc $ sym.nice g ++ " cannot be a member of " ++ typ.nice g Nothing -> E.fatal (view SymbolT.pos sym) $ msgdoc $ "no environment: " ++ t.nice g Local uid _ -> enterLocal insupd sym uid where From a9b0fa2cd7aa267306011b6f3957acaf55012d75 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 18:22:00 +0900 Subject: [PATCH 74/95] Add a copy of unsafePartialView to MethodCall A part of MethodCall.nativeCall uses unsafePartialView a lot. The reason is that it was written by myself as a prototype and is not polished yet. --- frege/compiler/gen/java/MethodCall.fr | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/frege/compiler/gen/java/MethodCall.fr b/frege/compiler/gen/java/MethodCall.fr index 861d56df..80d66886 100644 --- a/frege/compiler/gen/java/MethodCall.fr +++ b/frege/compiler/gen/java/MethodCall.fr @@ -4,7 +4,8 @@ module frege.compiler.gen.java.MethodCall where import Data.TreeMap(TreeMap, values) import Data.List(elemBy) -import frege.compiler.common.Lens (_Just, unsafePartialView, view) +import frege.data.Monoid (First) +import frege.compiler.common.Lens (Getting, _Just, preview, view) import Compiler.Utilities as U() @@ -106,6 +107,9 @@ nativeCall g (symv@SymV{nativ = Just item, gargs}) subst aexs = newBind g bsig ( evalStG g st = fst $ st.run g x = do g <- getST si <- symInfo $ SymbolT.V symv + -- this part is an unfinished, prototyped one. See PR #361, #363 + let unsafePartialView :: Getting (First a) s a -> s -> a + unsafePartialView l = unJust . preview l let name = (head si.argSigs).rho.tau.name irsym = unJust $ g.findit name nms = mapMaybe (_.name) [ fld | SymbolT.D x <- values (unsafePartialView _Just irsym.env'), fld <- x.flds ] From afca4cedc2ca7210a7ed2e747030605140dd59c5 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 18:36:18 +0900 Subject: [PATCH 75/95] Remove uses of partial matches in doc.Utility Instead of crashing, erroneous cases are simply treated as un-matched cases. --- frege/tools/doc/Utilities.fr | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/frege/tools/doc/Utilities.fr b/frege/tools/doc/Utilities.fr index 5de175f5..7038f844 100644 --- a/frege/tools/doc/Utilities.fr +++ b/frege/tools/doc/Utilities.fr @@ -332,9 +332,7 @@ overloadOf g sym = [ SymbolT.V o --- Give a list of sigmas and throws clauses of the overloads for this one overSig :: Global -> SymV Global -> [(Sigma, [Tau])] -overSig g sym = [(o.typ, o.throwing) | q <- sym.over, o <- unsafeToSymV <$> Global.findit g q] - where - unsafeToSymV (SymbolT.V x) = x +overSig g sym = [(o.typ, o.throwing) | q <- sym.over, SymbolT.V o <- Global.findit g q] --- create a label for a variable or a constructor -- label (MName (TName _ b1) b2) = Label (mangled b1 ++ "." ++ mangled b2) (text b2) From a42eca7ec67c77f0a482641478719a54feb772d7 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 18:38:01 +0900 Subject: [PATCH 76/95] Remove uses of partial functions in tools.Doc 'allfuns' now contain SymVs only. If non SymVs are in an env of a Symbol, they are just now ignored. Some of the other functions had their types changed in order to reflect that change. --- frege/tools/Doc.fr | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/frege/tools/Doc.fr b/frege/tools/Doc.fr index 099ed183..82384662 100644 --- a/frege/tools/Doc.fr +++ b/frege/tools/Doc.fr @@ -63,7 +63,7 @@ import Data.TreeMap as TM(TreeMap, keys, values, each, insert) import Data.List as DL(sortBy, groupBy, intersperse) import Data.Bits -import frege.compiler.common.Lens (preview, unsafePartialView, view) +import frege.compiler.common.Lens (view) import Compiler.enums.Flags as Compilerflags(VERBOSE) import Compiler.enums.Visibility(Public) @@ -376,7 +376,7 @@ continueNamespaces fp = do tableOC = [h3 (text "Table of Content"), toc] toc = ul (Just "data") (tocpars [ (asyms++csyms++dsyms - ++(sortBy (comparing $ view SymbolT.pos) (funs++links)), "data", "Definitions"), + ++(sortBy (comparing $ view SymbolT.pos) (map SymbolT.V funs ++ links)), "data", "Definitions"), -- (asyms, "data", "Type Aliases"), -- (csyms, "data", "Type Classes"), -- (dsyms, "data", "Data Types"), @@ -422,12 +422,12 @@ continueNamespaces fp = do DL (Just "func") (map docTypes ordfuns)] definitions = [h2 (XLbl "data" (text "Definitions")), DL (Just "data") (map (docSym g) sourcesyms)] - sourcesyms = sortBy (comparing $ view SymbolT.pos) (asyms ++ csyms ++ dsyms ++ funs ++ links) + sourcesyms = sortBy (comparing $ view SymbolT.pos) (asyms ++ csyms ++ dsyms ++ map SymbolT.V funs ++ links) asyms = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.A _) <- values g.thisTab] csyms = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.C _) <- values g.thisTab] isyms = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.I _) <- values g.thisTab] dsyms = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.T _) <- values g.thisTab] - funs = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.V _) <- values g.thisTab] + funs = sortBy (comparing $ _.name) [symv | SymbolT.V symv <- values g.thisTab] links = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.L SymL{alias}) <- values g.thisTab, g.our alias, other <- g.findit alias, @@ -438,20 +438,21 @@ continueNamespaces fp = do Just (SymbolT.C _) -> false other -> true noclassmember f _ = true - allfuns = funs ++ [ s | syms <- [csyms, isyms, dsyms], sym :: Symbol <- syms, - env <- SymbolT.env' sym, - s <- values env, - Lens.has SymbolT.typ s ] - ordfuns = groupBy (using $ unsafePartialView SymbolT.typ) (sortBy (comparing $ unsafePartialView SymbolT.typ) allfuns) + allfuns = funs ++ [ s + | syms <- [csyms, isyms, dsyms] + , sym :: Symbol <- syms + , env <- SymbolT.env' sym + , SymbolT.V s <- values env ] + ordfuns = groupBy (using _.typ) (sortBy (comparing _.typ) allfuns) expfuns = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.L SymL{pos,vis,alias}) <- values g.thisTab, vis == Public, not (g.our alias) ] - docTypes :: [Symbol] -> (Text, [Paragraph]) + docTypes :: [SymV Global] -> (Text, [Paragraph]) docTypes [] = undefined docTypes ss = (code typ, [par $ content ss]) where - typ = dRho g (unsafePartialView SymbolT.typ (head ss)).rho (repeat false) - content = fold (:-) (text "") . intersperse (text ", ") . map (flip fref g . view SymbolT.name) + typ = dRho g ((head ss).typ).rho (repeat false) + content = fold (:-) (text "") . intersperse (text ", ") . map (flip fref g . _.name) -- h3 (text "Imports"), ul Nothing (map docImp (Tree.keyvalues ?S.packs Eq))] -- we are producing strict HTML401 From e7908e50873c068ebf864e9bd6083be64314ea1f Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 18:54:08 +0900 Subject: [PATCH 77/95] Remove uses of partial matches in ide.Utilities Instead of crashing, erroneous cases are simply treated as un-matched cases. --- frege/ide/Utilities.fr | 42 +++++++++++++++++++++++------------------- 1 file changed, 23 insertions(+), 19 deletions(-) diff --git a/frege/ide/Utilities.fr b/frege/ide/Utilities.fr index a55c1a82..a4d3834f 100644 --- a/frege/ide/Utilities.fr +++ b/frege/ide/Utilities.fr @@ -10,7 +10,7 @@ import frege.compiler.passes.Imp as I(getFP) import frege.compiler.tc.Util as TC import frege.compiler.Typecheck as TY hiding(pass, post) -import frege.compiler.common.Lens (_Just, preview, unsafePartialView, view) +import frege.compiler.common.Lens (_Just, preview, view) import Compiler.enums.TokenID(TokenID, defaultInfix) import Compiler.enums.Visibility(Private, Public) @@ -147,7 +147,6 @@ instance Show Proposal where proposeContent :: Global -> Y RTree -> Int -> JArray Token -> Int -> [Proposal] proposeContent !global root !offset !tokens !index = propose where - unsafeToSymV (SymbolT.V x) = x snekot = backwards tokens index -- reverse order, last token before cursor on top thisline = takeWhile onThisLine snekot onThisLine tok = Token.line tok == token.line && tok.col > 0 @@ -252,15 +251,17 @@ proposeContent !global root !offset !tokens !index = propose Just (Right qname) <- Global.resolved global qual, traceLn ("resolved " ++ qual.value) || true, Just sym <- global.findit qname, + Just typ <- preview SymbolT.typ sym, traceLn ("found " ++ sym.nice global) || true, - = memProposal sym theProposal + = memProposal typ theProposal | (Token{tokid=CHAR, value="."} : (qual@Token{tokid=VARID}) :_) <- snekot, traceLn ("rule: " ++ qual.value ++ "." ++ insideProposal.prefix) || true, Just (Right qname) <- Global.resolved global qual, traceLn ("resolved " ++ qual.value) || true, Just sym <- global.findit qname, + Just typ <- preview SymbolT.typ sym, traceLn ("found " ++ sym.nice global) || true, - = memProposal sym insideProposal + = memProposal typ insideProposal | (Token{tokid=VARID}:Token{tokid=CHAR, value="."}:(qual@Token{tokid=STRCONST}):_) <- snekot, (true, proposals) <- tauProposal TY.tauString theProposal = proposals @@ -332,12 +333,12 @@ proposeContent !global root !offset !tokens !index = propose traceLn ("rule fundef " ++ value ++ "¦") || true, Just (Right qname) <- Global.resolved global varid, traceLn ("resolved " ++ nicer qname global) || true, - Just sym <- global.findit qname, + Just (SymbolT.V sym) <- global.findit qname, traceLn ("found " ++ sym.nice global) || true, - (unsafeToSymV sym).anno, traceLn (sym.nice global ++ " is annotated") || true, - isNothing (unsafeToSymV sym).nativ, traceLn (sym.nice global ++ " is not nativ") || true, - isNothing (unsafeToSymV sym).expr, traceLn (sym.nice global ++ " has no expression") || true, - (_, sigmas) <- U.returnType (unsafeToSymV sym).typ.rho, + sym.anno, traceLn (sym.nice global ++ " is annotated") || true, + isNothing sym.nativ, traceLn (sym.nice global ++ " is not nativ") || true, + isNothing sym.expr, traceLn (sym.nice global ++ " has no expression") || true, + (_, sigmas) <- U.returnType sym.typ.rho, = let conidProposals | direct, token.tokid == CONID = @@ -359,8 +360,9 @@ proposeContent !global root !offset !tokens !index = propose Just (Right qname) <- Global.resolved global token, traceLn ("resolved " ++ value) || true, Just sym <- global.findit qname, + Just typ <- preview SymbolT.typ sym, traceLn ("found " ++ sym.nice global) || true, - RhoTau{tau} <- (unsafePartialView SymbolT.typ sym).rho, + RhoTau{tau} <- typ.rho, tau <- TC.reduced tau global, traceLn ("type is " ++ nicer tau global) || true, Just symbol <- instTauSym tau global @@ -371,8 +373,9 @@ proposeContent !global root !offset !tokens !index = propose Just (Right qname) <- Global.resolved global token, traceLn ("resolved " ++ value) || true, Just sym <- global.findit qname, + Just typ <- preview SymbolT.typ sym, traceLn ("found " ++ sym.nice global) || true, - (tau,_) <- U.returnType (unsafePartialView SymbolT.typ sym).rho, + (tau,_) <- U.returnType typ.rho, tau <- TC.reduced tau global, traceLn ("return type is " ++ nicer tau global) || true, Just symbol <- instTauSym tau global @@ -496,11 +499,11 @@ proposeContent !global root !offset !tokens !index = propose -- Find a proposal for id.member -- - memProposal :: Symbol -> Proposal -> [Proposal] - memProposal sym prop - | RhoTau _ tau <- (unsafePartialView SymbolT.typ sym).rho, -- look in env of type tau + memProposal :: Sigma -> Proposal -> [Proposal] + memProposal typ prop + | RhoTau _ tau <- typ.rho, -- look in env of type tau (true, result) <- tauProposal tau prop = result - | RhoFun{rho} <- (unsafePartialView SymbolT.typ sym).rho, -- look in return type of fn + | RhoFun{rho} <- typ.rho, -- look in return type of fn RhoTau _ tau <- rho, (true, result) <- tauProposal tau prop = result | otherwise = filteredEnvProposal prop (classMember:standardFilter) (thisTab global) @@ -515,9 +518,10 @@ proposeContent !global root !offset !tokens !index = propose Just s | ss <- s:U.supersOfNativ s global, -- the supertypes of s (including s) -- traceLn("supertypes are " ++ show ss) || true, - envs <- [ unsafePartialView _Just sym.env' | s <- ss, + envs <- [ env | s <- ss, q <- U.typesOfNativ s global, - sym <- global.findit q ] + sym <- global.findit q, + env <- sym.env' ] = (true, concatMap (flip envProposal prop) envs) other | [TCon{name}, _, tau2] <- tau.flat, @@ -655,8 +659,8 @@ proposeContent !global root !offset !tokens !index = propose | SymbolT.V SymV{name, nativ = Just _} <- sym, m~´^(.+)[αβγδεζηθιßκλμνξοπρςστυφχψω]+$´ <- base, -- overloaded?? Just stem <- m.group 1, - Just overld <- global.findit name.{base=stem}, - name `elem` (unsafeToSymV overld).over = symProp stem overld + Just (SymbolT.V overld) <- global.findit name.{base=stem}, + name `elem` overld.over = symProp stem $ SymbolT.V overld | otherwise = (imported, base) where imported | global.our (view SymbolT.name sym) = base From e01d94c26061c4a95221c3b4bf648ad57b97368f Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 19:15:02 +0900 Subject: [PATCH 78/95] Change SymbolTable.InsUpd to protected being "private" crashes fregedoc (but not fregec). --- frege/compiler/common/SymbolTable.fr | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/frege/compiler/common/SymbolTable.fr b/frege/compiler/common/SymbolTable.fr index 173853f4..5724c71f 100644 --- a/frege/compiler/common/SymbolTable.fr +++ b/frege/compiler/common/SymbolTable.fr @@ -21,8 +21,9 @@ import frege.compiler.common.Errors as E() import frege.compiler.instances.Nicer -private data InsUpd = DoInsert | DoUpdate -private derive Show InsUpd +-- "private" crashes fregedoc +protected data InsUpd = DoInsert | DoUpdate +protected derive Show InsUpd private enterWith :: InsUpd -> Pack -> String -> Symbol -> StG () From 4b83084a8e16089756d410e2e8c98295fe403d44 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 19:28:54 +0900 Subject: [PATCH 79/95] Make constructors of SymbolT, SymMeth and SymVal strict optimizations from now on --- frege/compiler/types/Symbols.fr | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 803554b5..b043bf2e 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -91,8 +91,8 @@ data SymA global = !SymA --- generalized value --- variable, function, or data constructor data SymVal global - = protected D (SymD global) - | protected V (SymV global) + = protected !D (SymD global) + | protected !V (SymV global) where toSymbol :: SymVal g -> SymbolT g toSymbol (D s) = SymbolT.D s @@ -131,9 +131,9 @@ data SymVal global --- method of a class data SymMeth global = --- inherited by super classes - protected L (SymL global) + protected !L (SymL global) | --- ordinary members (methods) - protected V (SymV global) + protected !V (SymV global) where toSymbol :: SymMeth g -> SymbolT g toSymbol (L s) = SymbolT.L s @@ -163,13 +163,13 @@ data SymMeth global The information stored in the 'Symtab' nodes. -} data SymbolT global = - protected T (SymT global) --- data type - | protected L (SymL global) --- alias name - | protected D (SymD global) --- data constructor - | protected C (SymC global) --- class - | protected I (SymI global) --- instance - | protected V (SymV global) --- variable or function - | protected A (SymA global) --- type alias + protected !T (SymT global) --- data type + | protected !L (SymL global) --- alias name + | protected !D (SymD global) --- data constructor + | protected !C (SymC global) --- class + | protected !I (SymI global) --- instance + | protected !V (SymV global) --- variable or function + | protected !A (SymA global) --- type alias where hashCode :: SymbolT global -> Int hashCode = view SymbolT.sid From e6f82dd3f20c3818963f28034214af1e13744ec1 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 19:54:14 +0900 Subject: [PATCH 80/95] Clean unused imports Particularly unsafePartialView (defined in f.c.common.Lens) is no longer used anywhere. --- frege/compiler/Kinds.fr | 2 +- frege/compiler/Typecheck.fr | 2 +- frege/compiler/common/Trans.fr | 2 +- frege/compiler/gen/java/Common.fr | 2 +- frege/compiler/gen/java/DataCode.fr | 2 +- frege/compiler/passes/Enter.fr | 2 +- frege/compiler/passes/Strict.fr | 2 +- frege/compiler/tc/Methods.fr | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/frege/compiler/Kinds.fr b/frege/compiler/Kinds.fr index 8a44f24c..536f5717 100644 --- a/frege/compiler/Kinds.fr +++ b/frege/compiler/Kinds.fr @@ -41,7 +41,7 @@ module frege.compiler.Kinds where import frege.Prelude hiding(<+>, break) -import frege.compiler.common.Lens (set, unsafePartialView, view) +import frege.compiler.common.Lens (set, view) import Compiler.enums.Flags as Compilerflags(TRACEK) diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index 5ec715ca..9becc481 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -79,7 +79,7 @@ import Data.TreeMap as TM(TreeMap, values, lookup, insert, import Data.Graph (stronglyConnectedComponents tsort) import Data.List(groupBy, sortBy) -import frege.compiler.common.Lens (preview, unsafePartialView, view) +import frege.compiler.common.Lens (view) import Compiler.enums.Flags as Compilerflags(flagSet, OVERLOADING, TRACEO, TRACET, TRACEZ) import Compiler.enums.TokenID diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index 68d88fc6..338a7554 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -6,7 +6,7 @@ import Data.TreeMap as TM(TreeMap, TreeSet, lookup, insert, keys, values, eac import Data.List (partitioned) import Lib.PP(text, msgdoc, <+>, text) -import frege.compiler.common.Lens (unsafePartialView, view) +import frege.compiler.common.Lens (view) import Compiler.enums.TokenID(VARID) import Compiler.enums.SymState(Typechecked) diff --git a/frege/compiler/gen/java/Common.fr b/frege/compiler/gen/java/Common.fr index ad442472..0aad3ee8 100644 --- a/frege/compiler/gen/java/Common.fr +++ b/frege/compiler/gen/java/Common.fr @@ -4,7 +4,7 @@ module frege.compiler.gen.java.Common where import frege.Prelude hiding (<+>) -import frege.compiler.common.Lens (unsafePartialView, view) +import frege.compiler.common.Lens (view) import Data.TreeMap(values, insert, lookup, TreeMap Map, fromList) import Data.Bits(BitSet.member) diff --git a/frege/compiler/gen/java/DataCode.fr b/frege/compiler/gen/java/DataCode.fr index 0bad61fb..99821cf4 100644 --- a/frege/compiler/gen/java/DataCode.fr +++ b/frege/compiler/gen/java/DataCode.fr @@ -3,7 +3,7 @@ module frege.compiler.gen.java.DataCode where import frege.Prelude hiding (<+>) -import frege.compiler.common.Lens (unsafePartialView, view) +import frege.compiler.common.Lens (view) import Compiler.common.Errors as E() import Compiler.common.Binders(allBinders) diff --git a/frege/compiler/passes/Enter.fr b/frege/compiler/passes/Enter.fr index 77efda1b..fbd9bbbd 100644 --- a/frege/compiler/passes/Enter.fr +++ b/frege/compiler/passes/Enter.fr @@ -5,7 +5,7 @@ import frege.Prelude hiding (<+>) import frege.data.TreeMap as TM(TreeMap, keys, values, insert) import frege.data.List as DL(uniqBy, sort, sortBy) -import frege.compiler.common.Lens (_Just, preview, unsafePartialView, view) +import frege.compiler.common.Lens (view) import frege.compiler.enums.Flags as Compilerflags(TRACE3, TRACE4, isOn, isOff) import frege.compiler.enums.TokenID(defaultInfix) diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index de2814d7..15517bdd 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -6,7 +6,7 @@ import frege.data.TreeMap as TM(TreeMap, TreeSet, lookup, insert, keys, value import frege.data.List as DL(uniq, sort, partitioned, elemBy) import frege.data.Bits(BitSet, BitSet.member, BitSet.union bitunion, BitSet.intersection, BitSet.difference) import frege.data.Graph(stronglyConnectedComponents tsort) -import frege.compiler.common.Lens (set, unsafePartialView, view) +import frege.compiler.common.Lens (set, view) import frege.compiler.enums.Flags import frege.compiler.enums.TokenID(VARID) import frege.compiler.enums.RFlag diff --git a/frege/compiler/tc/Methods.fr b/frege/compiler/tc/Methods.fr index bfdcd05f..87bdce74 100644 --- a/frege/compiler/tc/Methods.fr +++ b/frege/compiler/tc/Methods.fr @@ -39,7 +39,7 @@ package frege.compiler.tc.Methods where import frege.Prelude hiding (<+>) -import frege.compiler.common.Lens (unsafePartialView, view) +import frege.compiler.common.Lens (view) import frege.compiler.Utilities as U() import Lib.PP (msgdoc, text, <+>, <+/>, nest) From 46e2e2f6e5ff1d690f13ed0bb39faf6c8cdd1ee1 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 20:19:02 +0900 Subject: [PATCH 81/95] Replace 'view'ing lenses with simple getters Added simple getters to SymbolT to be used instead of 'view'ing a 'Lens'. In Haskell, 'view' can have significant overhead than simple pattern matching. The existing lenses were given a leading underscore, like the prisms. --- frege/compiler/Classes.fr | 16 +- frege/compiler/Kinds.fr | 4 +- frege/compiler/Main.fr | 10 +- frege/compiler/Typecheck.fr | 13 +- frege/compiler/Utilities.fr | 26 +-- frege/compiler/classes/Nice.fr | 5 +- frege/compiler/common/Resolve.fr | 47 +++-- frege/compiler/common/SymbolTable.fr | 67 +++--- frege/compiler/gen/java/Common.fr | 4 +- frege/compiler/gen/java/DataCode.fr | 6 +- frege/compiler/gen/java/InstanceCode.fr | 12 +- frege/compiler/gen/java/Match.fr | 5 +- frege/compiler/gen/java/MethodCall.fr | 2 +- frege/compiler/gen/java/VarCode.fr | 4 +- frege/compiler/passes/Enter.fr | 10 +- frege/compiler/passes/Final.fr | 2 +- frege/compiler/passes/Imp.fr | 24 +-- frege/compiler/passes/Transdef.fr | 10 +- frege/compiler/passes/TypeAlias.fr | 4 +- frege/compiler/tc/Methods.fr | 4 +- frege/compiler/types/Global.fr | 3 +- frege/compiler/types/Symbols.fr | 265 +++++++++++++----------- frege/ide/Utilities.fr | 46 ++-- frege/tools/Doc.fr | 30 +-- frege/tools/Splitter.fr | 27 +-- frege/tools/doc/Utilities.fr | 10 +- 26 files changed, 340 insertions(+), 316 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index d8ef47ab..c32d9d05 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -294,8 +294,8 @@ passC = do -- this can happen if subclass is defined before the base class -- we correct it here silently Just (SymbolT.L s) -> changeSym $ SymbolT.L s.{alias=symm.name} - Just s -> E.fatal (view SymbolT.pos s) (text ("checklink: " ++ s.nice g ++ " should be a link")) - Nothing -> E.fatal (view SymbolT.pos v) (text ("checklink: " ++ glob.nice g ++ "findit is " + Just s -> E.fatal s.pos (text ("checklink: " ++ s.nice g ++ " should be a link")) + Nothing -> E.fatal v.pos (text ("checklink: " ++ glob.nice g ++ "findit is " ++ v.nice g ++ " but find is Nothing")) Just v -> E.error symm.pos (msgdoc ("definition of " ++ symm.nice g ++ " clashes with " ++ v.nice g @@ -324,16 +324,16 @@ passC = do changeSym $ SymbolT.V msym.{typ =ForAll bound rho.{context <- (thisctx:)}} checkanno sym1 sym2 = do g <- getST - E.fatal (view SymbolT.pos sym2) (text ("checkanno (" ++ sym1.nice g + E.fatal sym2.pos (text ("checkanno (" ++ sym1.nice g ++ ") (" ++ sym2.nice g ++ ")")) supercheck :: Symbol -> QName -> StG () supercheck symc qn = do g <- getST case g.find qn of Just (SymbolT.C _) -> return () - _ -> E.error (view SymbolT.pos symc) (msgdoc (QName.nice qn g + _ -> E.error symc.pos (msgdoc (QName.nice qn g ++ " cannot be a superclass of " - ++ (view SymbolT.name symc).nice g ++ " as it is not a class.")) + ++ symc.name.nice g ++ " as it is not a class.")) {- trace1 (qn1, qns) = do g <- getST @@ -571,7 +571,7 @@ funForCIT cname iname tname (mname@MName _ base) = do ++ " directly.")) | otherwise = E.error tvsym.pos (msgdoc (tvsym.nice g ++ " should be alias of " ++ ivsym.nice g)) - Just tvsym -> E.error (view SymbolT.pos tvsym) (msgdoc ("definition of " ++ ivsym.nice g + Just tvsym -> E.error tvsym.pos (msgdoc ("definition of " ++ ivsym.nice g ++ " not allowed because " ++ tvsym.nice g ++ " already exists.")) Nothing -> do @@ -685,7 +685,7 @@ funForCIT cname iname tname (mname@MName _ base) = do linkq (MName iname base) target funForCIT cname iname tname mname -- try again Nothing -> E.fatal ali.pos (msgdoc ("Link to nowhere: " ++ nicer ali g)) - Just osym -> E.fatal (view SymbolT.pos osym) (text ("funForCIT: expected type member, found " ++ osym.nice g)) + Just osym -> E.fatal osym.pos (text ("funForCIT: expected type member, found " ++ osym.nice g)) funForCIT cname iname tname mname = error "funForCIT: not a member" --- check if 'SymVal' is an implemented function @@ -716,7 +716,7 @@ tcInstMethod (sc:scs) isym msym = do let !mtnice = case isPSigma sig of true -> "None"; false -> sig.nicer g !csig = ForAll (filter ((sc.tau.var!=) . _.var) sbnd) srho !sig = case g.findit (view SymMeth.name msym) of - Just xsym | Just typ <- preview SymbolT.typ xsym -> typ + Just xsym | Just typ <- preview SymbolT._typ xsym -> typ other -> error ("tcInstMethod: link to nothing: " ++ nice msym g) E.logmsg TRACE6 (view SymMeth.pos msym) (text (msym.nice g ++ " class: " ++ sc.nice g diff --git a/frege/compiler/Kinds.fr b/frege/compiler/Kinds.fr index 536f5717..eaa1c34c 100644 --- a/frege/compiler/Kinds.fr +++ b/frege/compiler/Kinds.fr @@ -41,8 +41,6 @@ module frege.compiler.Kinds where import frege.Prelude hiding(<+>, break) -import frege.compiler.common.Lens (set, view) - import Compiler.enums.Flags as Compilerflags(TRACEK) import Compiler.types.Positions(Positioned) @@ -73,7 +71,7 @@ kiTypes = do g <- getST let tsyms = typeSyms g deps = map (typeDep g) tsyms - tdeps = zip (map (view SymbolT.name) tsyms) deps + tdeps = zip (map _.name tsyms) deps groups = tsort tdeps foreach groups kiTypeGroup return () diff --git a/frege/compiler/Main.fr b/frege/compiler/Main.fr index 2654b81f..ea633996 100644 --- a/frege/compiler/Main.fr +++ b/frege/compiler/Main.fr @@ -46,7 +46,7 @@ import Control.monad.State import Data.TreeMap as TM(TreeMap, each, values, keys, insert, delete) import Data.List (sort, uniq) -import frege.compiler.common.Lens (preview, set, view) +import frege.compiler.common.Lens (set) import frege.data.Foldable (for_) import frege.Version(version) @@ -262,14 +262,14 @@ makeFile glob sts = do foreach (values st) mergeSym mergeSym sym = do g ← getST - when (view SymbolT.vis sym != Private || (view SymbolT.name sym).{tynm?}) do - case g.find (view SymbolT.name sym) of + when (sym.vis != Private || sym.name.{tynm?}) do + case g.find sym.name of Just _ → return () none → do u ← uniqid - enter $ set SymbolT.sid u $ case sym of + enter $ set SymbolT._sid u $ case sym of SymbolT.T symt -> SymbolT.T symt.{env=empty} - _ -> set SymbolT.meth empty $ sym + _ -> set SymbolT._meth empty $ sym E.logmsg TRACEZ Position.null ( text "makeFile: entered" <+> (text (sym.nice g)) diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index 9becc481..dc4c25bd 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -129,7 +129,7 @@ memberTree = do ins t sy | Just list <- t.lookup b = if sy `elem` list then t else t.insert b (sy:list) | otherwise = insert b [sy] t - where b = (view SymbolT.name sy).base + where b = sy.name.base stio mems fundep :: TreeMap String [Symbol] -> SymV Global -> StG (QName, [QName]) @@ -141,7 +141,7 @@ fundep mtree SymV{name, expr=Just dx} = do case sy of SymbolT.V SymV{typ} -> isPSigma typ _ -> true - dep = [ view SymbolT.name sy | sy <- keys deptree, g.ourSym sy, needed sy ] + dep = [ sy.name | sy <- keys deptree, g.ourSym sy, needed sy ] stio (name, dep) fundep mtree SymV{name, expr=Nothing} = stio (name, []) @@ -375,6 +375,7 @@ checkKind = correctK empty pure $ Right Let{env, ex = ex', typ = fmap (substSigma subst) typ } correctKind subst x = pure $ Left x.{typ ← fmap (substSigma subst)} +checkAmbiguous :: Symbol -> Sigma -> StG () checkAmbiguous sym (ForAll bnd r) = do let ra = r.{context=[]} -- ctx => rho --> rho rb = (rhoInt).{context=r.context} -- Int --> ctx => Int @@ -384,14 +385,14 @@ checkAmbiguous sym (ForAll bnd r) = do if null bad then stio () else do g <- getST - E.error (view SymbolT.pos sym) (msgdoc ("Ambiguous type " + E.error sym.pos (msgdoc ("Ambiguous type " ++ nicer r g ++ " in " ++ nice sym g)) - E.hint (view SymbolT.pos sym) (msgdoc ("It is not clear at what types to instantiate " + E.hint sym.pos (msgdoc ("It is not clear at what types to instantiate " ++ (if length bad == 1 then "type variable " else "type variables ") ++ joined ", " bad ++ " that " ++ (if length bad == 1 then "occurs" else "occur") ++ " in the context, but not in the type.")) - E.hint (view SymbolT.pos sym) (msgdoc ("This can happen through constructs like (Enum.ord • Enum.from) " + E.hint sym.pos (msgdoc ("This can happen through constructs like (Enum.ord • Enum.from) " ++ " where a class context is both introduced and eliminated locally so " ++ "that a caller can not know which type is meant.")) @@ -409,7 +410,7 @@ checkReturn sym sigma = if all (`elem` svars) tvars then stio () else do g <- getST - U.symWarning E.warn sym (msgdoc ("application of " ++ (view SymbolT.name sym).nice g ++ " will diverge.")) + U.symWarning E.warn sym (msgdoc ("application of " ++ sym.name.nice g ++ " will diverge.")) {- removeCheckedCtx :: Symbol -> Sigma -> StG Symbol removeCheckedCtx sym sigma diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index 6fb6917f..ff03f479 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -125,7 +125,7 @@ findC qname = do g <- getST case g.findit qname of Just (SymbolT.C sym) -> stio sym - Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for class " ++ qname.nice g ++ ", found " + Just sym -> E.fatal sym.pos (fill (break ("looked for class " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for class " ++ qname.nice g ++ ", found Nothing"))) @@ -135,7 +135,7 @@ findI qname = do g <- getST case g.findit qname of Just (SymbolT.I sym) -> stio sym - Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for instance " ++ qname.nice g ++ ", found " + Just sym -> E.fatal sym.pos (fill (break ("looked for instance " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for instance " ++ qname.nice g ++ ", found Nothing"))) @@ -145,7 +145,7 @@ findT qname = do g <- getST case g.findit qname of Just (SymbolT.T sym) -> stio sym - Just sym -> E.fatal (view SymbolT.pos sym) (fill (break("looked for type " ++ qname.nice g ++ ", found " + Just sym -> E.fatal sym.pos (fill (break("looked for type " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for type " ++ qname.nice g ++ ", found Nothing"))) @@ -155,7 +155,7 @@ findV qname = do g <- getST case g.findit qname of Just (SymbolT.V sym) -> stio sym - Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for function " ++ qname.nice g ++ ", found " + Just sym -> E.fatal sym.pos (fill (break ("looked for function " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for function " ++ qname.nice g ++ ", found Nothing"))) @@ -166,7 +166,7 @@ findVD qname = do case g.findit qname of Just (SymbolT.V sym) -> stio (SymVal.V sym) Just (SymbolT.D sym) -> stio (SymVal.D sym) - Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for function or constructor " ++ qname.nice g ++ ", found " + Just sym -> E.fatal sym.pos (fill (break ("looked for function or constructor " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for function " ++ qname.nice g ++ ", found Nothing"))) @@ -176,7 +176,7 @@ findD qname = do g <- getST case g.findit qname of Just (SymbolT.D sym) -> stio sym - Just sym -> E.fatal (view SymbolT.pos sym) (fill (break ("looked for constructor " ++ qname.nice g ++ ", found " + Just sym -> E.fatal sym.pos (fill (break ("looked for constructor " ++ qname.nice g ++ ", found " ++ sym.nice g))) Nothing -> E.fatal Position.null (fill (break ("looked for constructor " ++ qname.nice g ++ ", found Nothing"))) @@ -294,7 +294,7 @@ patLocal pos uid name = vSym pos (Local uid name) --- set uid for a local symbol -setuid uid = over SymbolT.name QName.{uid} . set SymbolT.sid uid +setuid uid = over SymbolT._name QName.{uid} . set SymbolT._sid uid {-- @@ -317,8 +317,8 @@ freshVar pos = do --- update the local names uids in an expression that match one of the symbols by name replaceLocals :: [Symbol] -> Expr -> StG (Either Expr Expr) replaceLocals syms (v@Vbl {name = Local 0 s}) = - case DL.find (\sym -> (view SymbolT.name sym).base == s) syms of - Just sym -> stio (Right v.{name = view SymbolT.name sym}) + case DL.find (\sym -> sym.name.base == s) syms of + Just sym -> stio (Right v.{name = sym.name}) other -> stio (Right v) replaceLocals syms x = stio (Left x) @@ -631,10 +631,10 @@ appTauSigmas tau sigs = foldM appTauSig tau sigs >>= return . tauAsSigma -} symWarning :: (Position -> DOCUMENT -> StG ()) -> Symbol -> DOCUMENT -> StG () symWarning warn sym msg = - case preview SymbolT.doc sym of + case preview SymbolT._doc sym of Nothing -> pure () Just (Just ´^\s*nowarn:´) -> pure () - Just _ -> warn (view SymbolT.pos sym) msg + Just _ -> warn sym.pos msg {- ################# functions introduced through Classes.fr ############## -} @@ -936,7 +936,7 @@ ourGlobalFuns mtree ex = foldEx true collect empty ex where symVD f g sym = case sym of SymbolT.V _ -> f sym SymbolT.D _ -> g sym - other -> Prelude.error ((view SymbolT.name sym).base ++ " is neither SymV nor SymD") + other -> Prelude.error (sym.name.base ++ " is neither SymV nor SymD") {-- @@ -948,7 +948,7 @@ fundep (SymV{name, expr=Just dx}) = do g <- getST x <- dx deptree <- ourGlobalFuns empty x - let dep = [ name | sy <- keys deptree, let name = view SymbolT.name sy, g.our name ] + let dep = [ name | sy <- keys deptree, let name = sy.name, g.our name ] stio (name, dep) fundep (SymV{name, expr=Nothing}) = stio (name, []) diff --git a/frege/compiler/classes/Nice.fr b/frege/compiler/classes/Nice.fr index 730391ac..bd13b050 100644 --- a/frege/compiler/classes/Nice.fr +++ b/frege/compiler/classes/Nice.fr @@ -44,7 +44,6 @@ package frege.compiler.classes.Nice import Data.TreeMap as TM(TreeMap, each) import Lib.PP(DOCUMENT,text) -import frege.compiler.common.Lens (view) import frege.compiler.types.NSNames import frege.compiler.types.SNames import frege.compiler.types.Packs @@ -126,9 +125,9 @@ instance Nice (SymMeth Global) where instance Nice Symbol where nice (sym@(SymbolT.L SymL{alias})) g = category sym g ++ " `" ++ alias.nice g ++ "`" - nice sym g = category sym g ++ " `" ++ (view SymbolT.name sym).nice g ++ "`" + nice sym g = category sym g ++ " `" ++ sym.name.nice g ++ "`" nicer (sym@(SymbolT.L SymL{alias})) g = category sym g ++ " `" ++ alias.nicer g ++ "`" - nicer sym g = category sym g ++ " `" ++ (view SymbolT.name sym).nicer g ++ "`" + nicer sym g = category sym g ++ " `" ++ sym.name.nicer g ++ "`" protected category (SymbolT.T _) _ = "data type" diff --git a/frege/compiler/common/Resolve.fr b/frege/compiler/common/Resolve.fr index 3b9d152d..2b63078d 100644 --- a/frege/compiler/common/Resolve.fr +++ b/frege/compiler/common/Resolve.fr @@ -6,7 +6,7 @@ import frege.Prelude hiding(break, <+>) import frege.data.TreeMap as TM(TreeMap, lookup, each, insert, union, including, contains, keys, values, fromKeys) import frege.data.List as DL(partitioned, sortBy, minimumBy) import frege.lib.PP(break, fill, text, nest, msgdoc, <+>, <>, DOCUMENT) -import frege.compiler.common.Lens (_Just, preview, set, view) +import frege.compiler.common.Lens (_Just, preview, set) import frege.compiler.enums.Flags import frege.compiler.enums.Visibility import frege.compiler.types.Positions @@ -34,11 +34,12 @@ canonical g qname = case Global.findit g qname of -- access is forbidden to global private symbols from a different package -accessforbidden we sym = case view SymbolT.name sym of +accessforbidden :: Pack -> Symbol -> Bool +accessforbidden we sym = case sym.name of Local {} -> false - VName p _ -> view SymbolT.vis sym == Private && p != we - TName p _ -> view SymbolT.vis sym == Private && p != we - MName (TName p _) _ -> view SymbolT.vis sym == Private && p != we + VName p _ -> sym.vis == Private && p != we + TName p _ -> sym.vis == Private && p != we + MName (TName p _) _ -> sym.vis == Private && p != we _ -> Prelude.error ("Strange symbol") @@ -59,18 +60,18 @@ protected resolve fname pos sname = do foreach ss docWarningSym foreach ss (traceSym sname) foreach ss registerNS - stio (map (view SymbolT.name) ss) -- some public ones found + stio (map (_.name) ss) -- some public ones found where - registerNS sym = weUse (view SymbolT.name sym) + registerNS sym = weUse sym.name docWarningSym :: Symbol -> StG () docWarningSym sym = do g <- getST - docWarning pos ((view SymbolT.name sym).nicer g) (join $ preview SymbolT.doc sym) + docWarning pos (sym.name.nicer g) (join $ preview SymbolT._doc sym) traceSym :: SName -> Symbol -> StG () traceSym sname symbol = do E.logmsg TRACE5 pos (text (show sname ++ " resolved to " ++ nice symbol g ++ " (" - ++ QName.show (view SymbolT.name symbol) ++ ", " ++ show (view SymbolT.vis symbol) ++ ")")) + ++ QName.show symbol.name ++ ", " ++ show symbol.vis ++ ")")) {-- Note in the state that we need the import that is associated @@ -130,7 +131,7 @@ private resolve3 fname pos (Simple Token{value=qs}) = do scopefrom envs = fold more [] envs where more :: [String] -> Symtab -> [String] - more acc env = foldr (:) acc [ (view SymbolT.name v).base | v <- values env, + more acc env = foldr (:) acc [ v.name.base | v <- values env, not (Lens.is SymbolT._I v) ] -- T.v T.C N.v N.C N.T private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do @@ -139,7 +140,7 @@ private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do let tname = TName g.thisPack n mname = MName tname v -- T.v or T.C member = g.findit mname - mlist = map (canonical g . view SymbolT.name) member.toList -- [MName _ _ ] or [] + mlist = map (canonical g . _.name) member.toList -- [MName _ _ ] or [] mbtsym = g.findit tname msts | Just sym <- mbtsym = ms sym | otherwise = [] @@ -162,7 +163,7 @@ private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do case mbtsym of -- re-register qualifier as type name Just sym -> changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk snm.ty) (Right $ view SymbolT.name sym)}} + idKind <- insert (KeyTk snm.ty) (Right sym.name)}} sonst -> return () stio mlist (Just s, Nothing) -> do @@ -181,8 +182,8 @@ private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do Just sym -> do -- register qualifier as type name changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk snm.ty) (Right $ view SymbolT.name sym)}} - weUse $ view SymbolT.name sym + idKind <- insert (KeyTk snm.ty) (Right sym.name)}} + weUse sym.name case member of Just mem -> stio [mem] Nothing -> do @@ -193,12 +194,12 @@ private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do -- all known type and namespace names tsns :: Global -> [String] tsns g = [ n | NSX n <- keys g.namespaces ] - ++ [ (view SymbolT.name s).base | (s::Symbol) <- values g.thisTab, isTName (view SymbolT.name s)] + ++ [ s.name.base | (s::Symbol) <- values g.thisTab, isTName s.name] ms :: Symbol -> [String] - ms s | Just env <- s.env' = map (QName.base . view SymbolT.name) (values env) + ms s | Just env <- s.env' = map (QName.base . _.name) (values env) | otherwise = [] es :: Symtab -> [String] - es e = map (QName.base . view SymbolT.name) (values e) + es e = map (QName.base . _.name) (values e) private resolve3 _ pos (snm@With2 Token{value=n} Token{value=t} Token{value=qm}) = do g <- getST @@ -219,8 +220,8 @@ private resolve3 _ pos (snm@With2 Token{value=n} Token{value=t} Token{value=qm}) Just sym -> do -- register 2nd qualifier as type name changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk snm.ty) (Right $ view SymbolT.name sym)}} - weUse $ view SymbolT.name sym + idKind <- insert (KeyTk snm.ty) (Right sym.name)}} + weUse sym.name let mname = MName tname m case g.findit mname of Nothing -> do @@ -240,10 +241,10 @@ private resolve3 _ pos (snm@With2 Token{value=n} Token{value=t} Token{value=qm}) ns :: Global -> [String] ns g = [ n | NSX n <- keys g.namespaces ] ms :: Symbol -> [String] - ms s | Just env <- s.env' = map (QName.base . view SymbolT.name) (values env) + ms s | Just env <- s.env' = map (QName.base . _.name) (values env) | otherwise = [] ts :: Symtab -> [String] - ts e = [ x | TName _ x <- map (view SymbolT.name) (values e) ] + ts e = [ x | TName _ x <- map (_.name) (values e) ] resolveVName fname pos name = do @@ -331,9 +332,9 @@ checkXName pos sym name = do g <- getST case g.findit name of Nothing -> stio Nothing -- error should have come from resolve - Just it | constructor sym == constructor it = stio (Just $ view SymbolT.name it) + Just it | constructor sym == constructor it = stio (Just it.name) | otherwise = do - E.error pos (fill ([text "expected", text ((set SymbolT.name name sym).nice g) <> text ","] + E.error pos (fill ([text "expected", text ((set SymbolT._name name sym).nice g) <> text ","] ++ break "but found " ++ [text (it.nice g)])) stio Nothing diff --git a/frege/compiler/common/SymbolTable.fr b/frege/compiler/common/SymbolTable.fr index 5724c71f..2b613170 100644 --- a/frege/compiler/common/SymbolTable.fr +++ b/frege/compiler/common/SymbolTable.fr @@ -5,7 +5,7 @@ module frege.compiler.common.SymbolTable where import frege.Prelude hiding(error, print, println, break, <+>) import frege.data.TreeMap as TM(TreeMap, lookup, each, insert, union, including, contains, keys, values, fromKeys) import frege.lib.PP(fill, break, pretty, text, nest, msgdoc, <+>, <>, DOCUMENT) -import frege.compiler.common.Lens (preview, set, view) +import frege.compiler.common.Lens (preview, set) import frege.compiler.enums.Flags import frege.compiler.enums.SymState import frege.compiler.enums.Visibility @@ -35,7 +35,7 @@ private enterWith insupd p n s = do changeST Global.{packages <- insert p ntab} Nothing -> do let sp = g.unpack p - E.error (view SymbolT.pos s) (fill ([text "module", text "`" <> text sp <> text "`"] + E.error s.pos (fill ([text "module", text "`" <> text sp <> text "`"] ++ break "does not exist.")) where doInsUpd = case insupd of @@ -55,9 +55,9 @@ private insertSym toSymbol tab key value = case tab.lookupS key of case toSymbol value of SymbolT.V SymV{pos, name} -> E.error pos (msgdoc("duplicate function or pattern binding for `" ++ name.nice g ++ "`, already bound on line " - ++ show (view SymbolT.pos (toSymbol old)))) - _ -> E.error (view SymbolT.pos (toSymbol value)) (msgdoc("redefinition of " ++ on ++ " with " ++ qn - ++ " introduced on line " ++ show (view SymbolT.pos (toSymbol old)))) + ++ show (toSymbol old).pos)) + _ -> E.error (toSymbol value).pos (msgdoc("redefinition of " ++ on ++ " with " ++ qn + ++ " introduced on line " ++ show (toSymbol old).pos)) stio (tab.insertS key value) @@ -68,7 +68,7 @@ private updateSym toSymbol tab key value = case tab.lookupS key of Nothing -> do g <- getST let qn = (toSymbol value).nice g - E.error (view SymbolT.pos (toSymbol value)) (fill (break ("cannot update " ++ qn ++ " " ++ show (keys tab)))) + E.error (toSymbol value).pos (fill (break ("cannot update " ++ qn ++ " " ++ show (keys tab)))) stio (tab.insert key value) {-- @@ -105,14 +105,12 @@ enter sym = case sym of _ -> enterOrUpdate where enterOrUpdate = - let name = view SymbolT.name sym - in - case name of + case sym.name of Local{uid} -> do g <- getST uid <- if uid > 0 then return uid else uniqid let symv = toSymVBecauseLocal sym - case g.find name of + case g.find sym.name of Nothing | uid == symv.sid-> do E.logmsg TRACE3 symv.pos (text("enterLocal: " ++ @@ -121,16 +119,16 @@ enter sym = case sym of ", " ++ show symv.state)) changeST Global.{locals <- TreeMap.insertkvI uid symv} | otherwise = E.fatal symv.pos (text ("enterLocal: uid=" ++ - show uid ++ ", sid=" ++ show symv.sid ++ " for " ++ show name)) + show uid ++ ", sid=" ++ show symv.sid ++ " for " ++ show sym.name)) Just that -> E.error symv.pos (text ("already entered: " ++ nice symv g ++ " with uid " ++ show uid)) _ -> do g <- getST - case g.find name of + case g.find sym.name of Nothing -> enterByName sym Just that | SymbolT.L SymL{alias=thatAlias} <- that, SymbolT.L SymL{alias=symAlias} <- sym, thatAlias == symAlias = pure () -- do nothing - | SymbolT.L SymL{alias} <- that, alias.getpack != name.getpack = do - E.warn (view SymbolT.pos sym) (fill (break("hiding previously (line " ++ show (view SymbolT.pos that) + | SymbolT.L SymL{alias} <- that, alias.getpack != sym.name.getpack = do + E.warn sym.pos (fill (break("hiding previously (line " ++ show that.pos ++ ") imported " ++ that.nice g ++ " through " ++ sym.nice g))) changeSym sym @@ -146,42 +144,41 @@ private enterByName = insUpdSymByName DoInsert private insUpdSymByName :: InsUpd -> Symbol -> StG () -private insUpdSymByName insupd sym | view SymbolT.sid sym == 0 = do +private insUpdSymByName insupd sym | sym.sid == 0 = do u <- uniqid - insUpdSymByName insupd $ set SymbolT.sid u sym + insUpdSymByName insupd $ set SymbolT._sid u sym private insUpdSymByName insupd sym = do g <- getST - E.logmsg TRACE3 (view SymbolT.pos sym) $ logMessage g - let name = view SymbolT.name sym - case name of - TName p b -> enterWith insupd p name.key sym - VName p b -> enterWith insupd p name.key sym + E.logmsg TRACE3 sym.pos $ logMessage g + case sym.name of + TName p b -> enterWith insupd p sym.name.key sym + VName p b -> enterWith insupd p sym.name.key sym MName t b -> do g <- getST case g.findit t of Nothing -> do let qn = t.nice g - E.error (view SymbolT.pos sym) $ msgdoc $ "namespace `" ++ qn ++ "` does not exist" + E.error sym.pos $ msgdoc $ "namespace `" ++ qn ++ "` does not exist" Just (SymbolT.T typt) -> do - env <- enterSym insupd id typt.env name.key sym + env <- enterSym insupd id typt.env sym.name.key sym enterWith DoUpdate t.pack t.key $ SymbolT.T typt.{env} - Just typ -> case preview SymbolT.meth typ of + Just typ -> case preview SymbolT._meth typ of Just typMeth -> case SymMeth.fromSymbol sym of Just ameth -> do - meth <- enterSym insupd SymMeth.toSymbol typMeth name.key ameth - enterWith DoUpdate t.pack t.key $ set SymbolT.meth meth typ - Nothing -> E.error (view SymbolT.pos sym) $ msgdoc $ sym.nice g ++ " cannot be a member of " ++ typ.nice g - Nothing -> E.fatal (view SymbolT.pos sym) $ msgdoc $ "no environment: " ++ t.nice g + meth <- enterSym insupd SymMeth.toSymbol typMeth sym.name.key ameth + enterWith DoUpdate t.pack t.key $ set SymbolT._meth meth typ + Nothing -> E.error sym.pos $ msgdoc $ sym.nice g ++ " cannot be a member of " ++ typ.nice g + Nothing -> E.fatal sym.pos $ msgdoc $ "no environment: " ++ t.nice g Local uid _ -> enterLocal insupd sym uid where logMessage g = fill $ case insupd of DoUpdate -> [ text $ "insUpdSymByName " ++ show insupd - , lit $ view SymbolT.sid sym + , lit sym.sid , text $ concat [ sym.nice g , " :: " - , maybe "" (\typ -> typ.nice g) $ preview SymbolT.typ sym + , maybe "" (\typ -> typ.nice g) $ preview SymbolT._typ sym , ", " , maybe "" (\SymV{state} -> show state) $ preview SymbolT._V sym ]] @@ -189,7 +186,7 @@ private insUpdSymByName insupd sym = do [ "insUpdSymByName" , show insupd , sym.nice g - , show (view SymbolT.sid sym) + , show sym.sid ] ++ case sym of SymbolT.V SymV{typ} | not (isPSigma typ) -> ["::", typ.nicer g] @@ -203,7 +200,7 @@ private insUpdSymByName insupd sym = do private enterLocal :: InsUpd -> Symbol -> Int -> StG () private enterLocal DoInsert sym _ = do g <- getST - E.fatal (view SymbolT.pos sym) (text ("local passed to enterbyname " ++ nice sym g)) + E.fatal sym.pos (text ("local passed to enterbyname " ++ nice sym g)) private enterLocal DoUpdate sym uid = do let symv = toSymVBecauseLocal sym when (symv.sid != uid) do @@ -214,12 +211,12 @@ private enterLocal DoUpdate sym uid = do {-- create a symbolic link to given qname -} linkq :: QName -> Symbol -> StG () -linkq from sym = linkqv from sym (view SymbolT.vis sym) +linkq from sym = linkqv from sym sym.vis --- create a symbolic link to a given 'Symbol' with a given 'Visibility' linkqv :: QName -> Symbol -> Visibility -> StG () -linkqv from sym vis = linkqvp from sym vis (view SymbolT.pos sym) +linkqv from sym vis = linkqvp from sym vis sym.pos -- create a symbolic link to a given 'Symbol' with a given 'Visibility' and 'Position' @@ -229,5 +226,5 @@ linkqvp from sym vis pos = do E.logmsg TRACE3 pos (text ("`" ++ from.nice g ++ "` link to " ++ sym.nice g)) enter $ SymbolT.L (SymL {sid=0, pos=pos, vis, -- doc=Nothing, - name=from, alias=view SymbolT.name sym}) + name=from, alias=sym.name}) diff --git a/frege/compiler/gen/java/Common.fr b/frege/compiler/gen/java/Common.fr index 0aad3ee8..06fce98e 100644 --- a/frege/compiler/gen/java/Common.fr +++ b/frege/compiler/gen/java/Common.fr @@ -589,8 +589,8 @@ symInfo sym = do g <- getST case g.gen.symi8.lookup sym of Just si -> do - E.logmsg TRACEG (view SymbolT.pos sym) ( - text "got symInfo:" <+> text (nice sym g) <+> text (show (view SymbolT.sid sym)) + E.logmsg TRACEG sym.pos ( + text "got symInfo:" <+> text (nice sym g) <+> text (show sym.sid) text "si.returnJT" <+> annoG g si.returnJT text "si.retSig " <+> text (nice si.retSig g) -- text " diff --git a/frege/compiler/gen/java/DataCode.fr b/frege/compiler/gen/java/DataCode.fr index 99821cf4..7d36679e 100644 --- a/frege/compiler/gen/java/DataCode.fr +++ b/frege/compiler/gen/java/DataCode.fr @@ -3,8 +3,6 @@ module frege.compiler.gen.java.DataCode where import frege.Prelude hiding (<+>) -import frege.compiler.common.Lens (view) - import Compiler.common.Errors as E() import Compiler.common.Binders(allBinders) import Compiler.common.JavaName @@ -197,7 +195,7 @@ dataCode (SymbolT.T (sym@SymT{ nativ = Just _ })) = do dataCode sym = do g ← getST - E.fatal (view SymbolT.pos sym) ( + E.fatal sym.pos ( text "dataCode: argument is " <+> text (nice sym g) ) @@ -341,7 +339,7 @@ subDecls (SymbolT.T sym) = do concat <$> mapM (varCode emptyTree) subdefs subDecls sym = do g ← getST - E.fatal (view SymbolT.pos sym) ( + E.fatal sym.pos ( text "subDecls: argument is " <+> text (nice sym g) ) \ No newline at end of file diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index 60e279ff..38fb3acf 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -103,7 +103,7 @@ classCode (SymbolT.C (sym@SymC{tau = TVar{var,kind}})) = do -- type cl --- If given something else than a type class this is a fatal compiler error classCode sym = do g ← getST - E.fatal (view SymbolT.pos sym) ( + E.fatal sym.pos ( text "classCode: argument is " <+> text (nice sym g) ) @@ -126,7 +126,7 @@ lowerKindSpecialClasses = do lowerKindAbstractFun :: SymC Global -> Symbol -> StG () lowerKindAbstractFun symc sym = do let classvar = symc.tau.var - newsym = over SymbolT.typ (lowerKind classvar) sym + newsym = over SymbolT._typ (lowerKind classvar) sym changeSym newsym -- force syminfo to regenerate information, if already present changeST Global.{gen ← _.{symi8 ← delete sym}} @@ -228,10 +228,10 @@ instanceCode (SymbolT.I sym) = do -- instance definition methods1 = map (view SymMeth.name) (values sym.meth) -- methods of super classes that are implemented in the type itself methods3 = case instTSym sym.typ g of - Just tsym -> [ view SymbolT.name sym | + Just tsym -> [ sym.name | sym <- values tsym.env, - (view SymbolT.name sym).base `elem` superMethods, - (view SymbolT.name sym).base `notElem` methods] where + sym.name.base `elem` superMethods, + sym.name.base `notElem` methods] where methods = map QName.base (methods1++methods2) _ -> error "unexpected result from instTSym" methods = methods1 ++ methods2 ++ methods3 @@ -343,7 +343,7 @@ instanceCode (SymbolT.I sym) = do -- instance definition --- If given something else than a type class this is a fatal compiler error instanceCode sym = do g ← getST - E.fatal (view SymbolT.pos sym) ( + E.fatal sym.pos ( text "instanceCode: argument is " <+> text (nice sym g) ) diff --git a/frege/compiler/gen/java/Match.fr b/frege/compiler/gen/java/Match.fr index f7584db9..b97301e6 100644 --- a/frege/compiler/gen/java/Match.fr +++ b/frege/compiler/gen/java/Match.fr @@ -13,8 +13,6 @@ import frege.Prelude hiding(apply, <+>) import Data.TreeMap as TM(TreeMap, values, keys, each, insert, lookup) import Data.List as DL(sortBy, partitioned) -import frege.compiler.common.Lens (view) - import Compiler.enums.Literals import Compiler.types.Strictness @@ -372,10 +370,11 @@ match _ pat b c bs = do * @pat@ must be a constructor application whose constructor is the same * as given in @con@ -} +matchCon :: Bool -> Pattern -> Symbol -> [Binding] -> (TreeMap Int Binding -> StG [JStmt]) -> TreeMap Int Binding -> StG [JStmt] matchCon assert (PCon {pos,qname, pats}) con bexs cont binds = do g <- getST sym <- U.findD qname - if sym.sid != view SymbolT.sid con + if sym.sid != con.sid then do E.fatal pos (text ("matchCon: " ++ nice qname g ++ " against " ++ nice con g)) else do diff --git a/frege/compiler/gen/java/MethodCall.fr b/frege/compiler/gen/java/MethodCall.fr index 80d66886..f08b4b5a 100644 --- a/frege/compiler/gen/java/MethodCall.fr +++ b/frege/compiler/gen/java/MethodCall.fr @@ -116,7 +116,7 @@ nativeCall g (symv@SymV{nativ = Just item, gargs}) subst aexs = newBind g bsig ( return $ flip mapMaybe nms $ \fldnm -> do nativrsym <- g.findit $ si.retSig.rho.tau.name nativsym <- TreeMap.lookup fldnm (unsafePartialView _Just nativrsym.env') - nativnm <- unsafePartialView SymbolT.nativ nativsym + nativnm <- unsafePartialView SymbolT._nativ nativsym let nativsi = evalStG g $ symInfo nativsym fldsym <- TreeMap.lookup fldnm (unsafePartialView _Just irsym.env') pure $ wrapIRMethod g (head args) (head si.argJTs) nativsi nativnm fldnm (unsafePartialView Symbol._Val fldsym) diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index a560f275..7f17941d 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -9,7 +9,7 @@ import Lib.PP(text, <>, <+>, <+/>, ) import Data.Bits(BitSet, BitSet.member, BitSet.unionE, BitSet.differenceE) import Data.List(partitioned, zip4) -import frege.compiler.common.Lens (preview, view) +import frege.compiler.common.Lens (preview) import Compiler.enums.Flags(TRACEG) import Compiler.enums.RFlag as RF(RFlag) @@ -279,7 +279,7 @@ innerFun (SymbolT.V (sym@SymV {expr = Just dx})) binds = do innerFun sym binds = do g ← getST - E.fatal (view SymbolT.pos sym) (text "invalid inner fun " <+> text (sym.nice g)) + E.fatal sym.pos (text "invalid inner fun " <+> text (sym.nice g)) {-- diff --git a/frege/compiler/passes/Enter.fr b/frege/compiler/passes/Enter.fr index fbd9bbbd..831b7838 100644 --- a/frege/compiler/passes/Enter.fr +++ b/frege/compiler/passes/Enter.fr @@ -5,7 +5,7 @@ import frege.Prelude hiding (<+>) import frege.data.TreeMap as TM(TreeMap, keys, values, insert) import frege.data.List as DL(uniqBy, sort, sortBy) -import frege.compiler.common.Lens (view) +import frege.compiler.common.Lens () import frege.compiler.enums.Flags as Compilerflags(TRACE3, TRACE4, isOn, isOff) import frege.compiler.enums.TokenID(defaultInfix) @@ -75,10 +75,10 @@ private transKind kind = case kind of link :: Symbol -> StG () link sym = do g <- getST - E.logmsg TRACE3 (view SymbolT.pos sym) (text ("`" ++ (view SymbolT.name sym).base ++ "` link to " ++ sym.nice g)) + E.logmsg TRACE3 sym.pos (text ("`" ++ sym.name.base ++ "` link to " ++ sym.nice g)) ST.enter $ SymbolT.L - (SymL {sid=0, pos=view SymbolT.pos sym, vis=view SymbolT.vis sym, -- doc=Nothing, - name=VName g.thisPack (view SymbolT.name sym).base, alias=view SymbolT.name sym}) + (SymL {sid=0, pos=sym.pos, vis=sym.vis, -- doc=Nothing, + name=VName g.thisPack sym.name.base, alias=sym.name}) --- reorder definitions so that annotations come last @@ -227,7 +227,7 @@ enter1ClaDcl fname (d@ClaDcl {pos}) = do g <- getST let vs = (filter (maybe true (not . Lens.is SymbolT._L) . g.find . VName g.thisPack - . QName.base . view SymbolT.name) + . QName.base . _.name) . values . fromMaybe empty) (_.env' =<< g.findit tname) E.logmsg TRACE3 pos (text ("enter1: ClaDcl: vs=" ++ show (map (flip nice g) vs))) foreach (vs) link diff --git a/frege/compiler/passes/Final.fr b/frege/compiler/passes/Final.fr index 5ee58322..90ff57f6 100644 --- a/frege/compiler/passes/Final.fr +++ b/frege/compiler/passes/Final.fr @@ -48,7 +48,7 @@ cleanSymtab = do mapEnvSymV mapsymv sym = case sym of SymbolT.V symv -> SymbolT.V $ mapsymv symv SymbolT.T symt -> SymbolT.T $ symt.{env <- fmap (mapEnvSymV mapsymv)} - _ -> over SymbolT.meth (fmap (over SymMeth._V mapsymv)) sym + _ -> over SymbolT._meth (fmap (over SymMeth._V mapsymv)) sym swap :: (a,b) -> (b,a) swap (a,b) = (b,a) -- !kAarray = (arrayFromIndexList . map swap . each) empty -- g.gen.kTree diff --git a/frege/compiler/passes/Imp.fr b/frege/compiler/passes/Imp.fr index 65cfed75..44f632b0 100644 --- a/frege/compiler/passes/Imp.fr +++ b/frege/compiler/passes/Imp.fr @@ -47,7 +47,7 @@ import Data.TreeMap as TM(TreeMap, keys, insert, insertWith, each, values, looku import Data.List as DL(sortBy, zipWith4) import Data.Bits(BitSet.BitSet) -import frege.compiler.common.Lens (view) +import frege.compiler.common.Lens () import Compiler.enums.Flags import Compiler.enums.TokenID(CONID, VARID, defaultInfix, ROP4) @@ -246,15 +246,15 @@ importEnv pos env ns pack (imp@Imports {except=true, items}) = do let xs = [ withNS ns.unNS (ImportItem.name e) | e <- items ] exss <- mapSt (resolve (VName g.thisPack) pos) xs let exs = fold (++) [] exss - nitems = [ protoItem.{ name = Simple pos.first.{tokid=VARID, value=(view SymbolT.name sym).base}, + nitems = [ protoItem.{ name = Simple pos.first.{tokid=VARID, value=sym.name.base}, members = nomem csym, - alias = (view SymbolT.name sym).base} | + alias = sym.name.base} | sym <- sortBy (comparing constructor) (values env), -- place SymL before SymC - csym <- g.findit (view SymbolT.name sym), + csym <- g.findit sym.name, not (Lens.is SymbolT._D csym) -- no constructors - || (view SymbolT.name sym).base != (view SymbolT.name csym).base, -- except renamed ones - view SymbolT.name csym `notElem` exs, - view SymbolT.vis sym == Public + || sym.name.base != csym.name.base, -- except renamed ones + csym.name `notElem` exs, + sym.vis == Public ] nomem (SymbolT.C _) = Just [] nomem _ = Nothing @@ -285,7 +285,7 @@ linkHere ns pack (item@Item {publik,name,members,alias=newn}) sym = do let pos = Pos name.id name.id let conid = (newn.charAt 0).isUpperCase conidOk - | TName _ _ <- view SymbolT.name sym = true + | TName _ _ <- sym.name = true | SymbolT.D _ <- sym = true | otherwise = false vis = if publik then Public else Private @@ -293,9 +293,9 @@ linkHere ns pack (item@Item {publik,name,members,alias=newn}) sym = do E.logmsg TRACE2 pos (text ("linkHere: " ++ ns ++ "." ++ newn ++ ", vis =" ++ show vis ++ " ==> " ++ nice sym g)) changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk pos.first) (Right (view SymbolT.name sym))}} + idKind <- insert (KeyTk pos.first) (Right sym.name)}} - let !errors = case view SymbolT.name sym of + let !errors = case sym.name of name@(TName _ b) | newn == name.base || conid = linkqvp (TName g.thisPack newn) sym vis pos | otherwise = do @@ -320,7 +320,7 @@ linkHere ns pack (item@Item {publik,name,members,alias=newn}) sym = do noteWhy (Local{}) = stio () noteReExported p | p /= pack = changeST _.{sub <- _.{packWhy <- insertWith (++) p [NSX ns]}} | otherwise = changeST _.{sub <- _.{packWhy <- insert p [NSX ns]}} - noteWhy (view SymbolT.name sym) + noteWhy sym.name errors case sym of @@ -360,7 +360,7 @@ linkItem ns pack (item@Item {publik,name,members,alias}) = do [] -> stio () -- got error message from resolve or excluded [sym] -> linkHere ns pack item sym syms -- look for a type name - | (tsym:_) <- [ x | x <- syms, TName{} <- Just (view SymbolT.name x)] + | (tsym:_) <- [ x | x <- syms, TName{} <- Just x.name] = linkHere ns pack item tsym | otherwise = do -- by taking the first result, we resolve NS.x linkHere ns pack item (head syms) diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index 740b5144..ad62e759 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -128,12 +128,12 @@ fixity (d@FixDcl{pos, opid, ops}) = foreach ops changeop change sym = do g <- getST - case preview SymbolT.op sym of + case preview SymbolT._op sym of Just op -> do - unless (g.our (view SymbolT.name sym) || op == defaultInfix || op == opid) do + unless (g.our sym.name || op == defaultInfix || op == opid) do E.hint pos (text ("Should you change associativity/precedence for " - ++ nicer (view SymbolT.name sym) g)) - changeSym $ set SymbolT.op opid sym + ++ nicer sym.name g)) + changeSym $ set SymbolT._op opid sym Nothing -> E.error pos (text (nicer sym g ++ " cannot have a precedence")) @@ -1025,7 +1025,7 @@ transExpr env fname ex = do ++ symd.name.nice g)) stio res Just sym -> do - when (g.errors == 0 && (view SymbolT.name sym).base != "undefined") do + when (g.errors == 0 && sym.name.base != "undefined") do E.error pos (msgdoc ("looked for constructor " ++ name.nice g ++ ", found " ++ sym.nice g)) stio vUndef diff --git a/frege/compiler/passes/TypeAlias.fr b/frege/compiler/passes/TypeAlias.fr index 16a62dd3..00d54b38 100644 --- a/frege/compiler/passes/TypeAlias.fr +++ b/frege/compiler/passes/TypeAlias.fr @@ -93,7 +93,7 @@ transalias (d@TypDcl {pos}) = do -- type aliases may be incomplete typS <- U.validSigma1 (map Tau.var d.vars) d.typ typ <- U.transSigma (ForAll [] typS.rho) - changeSym $ set SymbolT.typ typ.{bound=[]} sym + changeSym $ set SymbolT._typ typ.{bound=[]} sym bound -> do -- type X a b c = forall x y. ...... -- The bound variables x y must be distinct from the type args a b c @@ -106,7 +106,7 @@ transalias (d@TypDcl {pos}) = do if null badfree then do typ1 <- U.transSigma d.typ.{bound=[]} bounds ← U.transBounds bound - changeSym $ set SymbolT.typ typ1.{bound=bounds} sym + changeSym $ set SymbolT._typ typ1.{bound=bounds} sym pure () else E.error pos (text "Type variable(s) " diff --git a/frege/compiler/tc/Methods.fr b/frege/compiler/tc/Methods.fr index 87bdce74..295b998b 100644 --- a/frege/compiler/tc/Methods.fr +++ b/frege/compiler/tc/Methods.fr @@ -39,8 +39,6 @@ package frege.compiler.tc.Methods where import frege.Prelude hiding (<+>) -import frege.compiler.common.Lens (view) - import frege.compiler.Utilities as U() import Lib.PP (msgdoc, text, <+>, <+/>, nest) import Data.TreeMap as TM(keys, TreeMap) @@ -467,7 +465,7 @@ sanity (SymbolT.V (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, o sanity sym = do g <- getST - E.fatal (view SymbolT.pos sym) (msgdoc ("cannot check native function type sanity for " ++ nicer sym g)) + E.fatal sym.pos (msgdoc ("cannot check native function type sanity for " ++ nicer sym g)) --- structural equality of 'Tau' types, variables are not unified, but compared by name matches :: Tau -> Tau -> Bool diff --git a/frege/compiler/types/Global.fr b/frege/compiler/types/Global.fr index 2dd74e27..39debb6d 100644 --- a/frege/compiler/types/Global.fr +++ b/frege/compiler/types/Global.fr @@ -8,7 +8,6 @@ import frege.data.TreeMap as TM(TreeMap, each) import frege.java.Net(URLClassLoader) import frege.control.monad.State (State, StateT) -import frege.compiler.common.Lens (preview, view) import frege.compiler.enums.Flags as Compilerflags(Flag, Flags, isOn, isOff) import frege.compiler.enums.TokenID(TokenID) import frege.compiler.types.Positions @@ -198,7 +197,7 @@ data Global = !Global { --- tell if a 'Symbol' is from the module we're just compiling ourSym :: Global -> Symbol -> Bool - ourSym g sy = our g (view Symbol.name sy) + ourSym g sy = our g sy.name --- find the 'Symbol' for a 'QName', which may be a 'SymL' (symbolic link) find :: Global -> QName -> Maybe Symbol diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index b043bf2e..798fa032 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -3,7 +3,7 @@ module frege.compiler.types.Symbols where import frege.data.TreeMap as TM(TreeMap, each, values) import frege.control.monad.State -import frege.compiler.common.Lens (Choice, preview, prism', view) +import frege.compiler.common.Lens (Choice, preview, prism') import frege.compiler.enums.RFlag(RState, RFlag) import frege.compiler.types.Positions import frege.compiler.types.Strictness @@ -172,121 +172,154 @@ data SymbolT global = | protected !A (SymA global) --- type alias where hashCode :: SymbolT global -> Int - hashCode = view SymbolT.sid + hashCode = SymbolT.sid - -- doc :: Traversal' (SymbolT g) (Maybe String) - doc :: Applicative f => (Maybe String -> f (Maybe String)) -> SymbolT g -> f (SymbolT g) - doc f (T s) = (\doc -> T s.{doc}) <$> f s.doc - doc _ (sym@(L _)) = pure sym - doc f (D s) = (\doc -> D s.{doc}) <$> f s.doc - doc f (C s) = (\doc -> C s.{doc}) <$> f s.doc - doc f (I s) = (\doc -> I s.{doc}) <$> f s.doc - doc f (V s) = (\doc -> V s.{doc}) <$> f s.doc - doc f (A s) = (\doc -> A s.{doc}) <$> f s.doc - -- kind :: Traversal' (SymbolT g) Kind - kind :: Applicative f => (Kind -> f Kind) -> SymbolT g -> f (SymbolT g) - kind f (T s) = (\kind -> T s.{kind}) <$> f s.kind - kind _ (sym@(L _)) = pure sym - kind _ (sym@(D _)) = pure sym - kind _ (sym@(C _)) = pure sym - kind _ (sym@(I _)) = pure sym - kind _ (sym@(V _)) = pure sym - kind f (A s) = (\kind -> A s.{kind}) <$> f s.kind - -- meth :: Traversal' (SymbolT g) (TreeMap String (SymMeth g)) - meth :: Applicative f => (TreeMap String (SymMeth g) -> f (TreeMap String (SymMeth g))) -> SymbolT g -> f (SymbolT g) - meth _ (sym@(T _)) = pure sym - meth _ (sym@(L _)) = pure sym - meth _ (sym@(D _)) = pure sym - meth f (C s) = (\meth -> C s.{meth}) <$> f s.meth - meth f (I s) = (\meth -> I s.{meth}) <$> f s.meth - meth _ (sym@(V _)) = pure sym - meth _ (sym@(A _)) = pure sym - -- name :: Lens' (SymbolT g) QName - name :: Functor f => (QName -> f QName) -> SymbolT g -> f (SymbolT g) - name f (T s) = (\name -> T s.{name}) <$> f s.name - name f (L s) = (\name -> L s.{name}) <$> f s.name - name f (D s) = (\name -> D s.{name}) <$> f s.name - name f (C s) = (\name -> C s.{name}) <$> f s.name - name f (I s) = (\name -> I s.{name}) <$> f s.name - name f (V s) = (\name -> V s.{name}) <$> f s.name - name f (A s) = (\name -> A s.{name}) <$> f s.name - -- nativ :: Traversal' (SymbolT g) (Maybe String) - nativ :: Applicative f => (Maybe String -> f (Maybe String)) -> SymbolT g -> f (SymbolT g) - nativ f (T s) = (\nativ -> T s.{nativ}) <$> f s.nativ - nativ _ (sym@(L _)) = pure sym - nativ _ (sym@(D _)) = pure sym - nativ _ (sym@(C _)) = pure sym - nativ _ (sym@(I _)) = pure sym - nativ f (V s) = (\nativ -> V s.{nativ}) <$> f s.nativ - nativ _ (sym@(A _)) = pure sym - -- op :: Traversal' (SymbolT g) TokenID - op :: Applicative f => (TokenID -> f TokenID) -> SymbolT g -> f (SymbolT g) - op _ (sym@(T _)) = pure sym - op _ (sym@(L _)) = pure sym - op f (D s) = (\op -> D s.{op}) <$> f s.op - op _ (sym@(C _)) = pure sym - op _ (sym@(I _)) = pure sym - op f (V s) = (\op -> V s.{op}) <$> f s.op - op _ (sym@(A _)) = pure sym - -- pos :: Lens' (SymbolT g) Position - pos :: Functor f => (Position -> f Position) -> SymbolT g -> f (SymbolT g) - pos f (T s) = (\pos -> T s.{pos}) <$> f s.pos - pos f (L s) = (\pos -> L s.{pos}) <$> f s.pos - pos f (D s) = (\pos -> D s.{pos}) <$> f s.pos - pos f (C s) = (\pos -> C s.{pos}) <$> f s.pos - pos f (I s) = (\pos -> I s.{pos}) <$> f s.pos - pos f (V s) = (\pos -> V s.{pos}) <$> f s.pos - pos f (A s) = (\pos -> A s.{pos}) <$> f s.pos - -- pur :: Traversal' (SymbolT g) Bool - pur :: Applicative f => (Bool -> f Bool) -> SymbolT g -> f (SymbolT g) - pur f (T s) = (\pur -> T s.{pur}) <$> f s.pur - pur _ (sym@(L _)) = pure sym - pur _ (sym@(D _)) = pure sym - pur _ (sym@(C _)) = pure sym - pur _ (sym@(I _)) = pure sym - pur f (V s) = (\pur -> V s.{pur}) <$> f s.pur - pur _ (sym@(A _)) = pure sym - -- sid :: Lens' (SymbolT g) Int - sid :: Functor f => (Int -> f Int) -> SymbolT g -> f (SymbolT g) - sid f (T s) = (\sid -> T s.{sid}) <$> f s.sid - sid f (L s) = (\sid -> L s.{sid}) <$> f s.sid - sid f (D s) = (\sid -> D s.{sid}) <$> f s.sid - sid f (C s) = (\sid -> C s.{sid}) <$> f s.sid - sid f (I s) = (\sid -> I s.{sid}) <$> f s.sid - sid f (V s) = (\sid -> V s.{sid}) <$> f s.sid - sid f (A s) = (\sid -> A s.{sid}) <$> f s.sid - -- strsig :: Traversal' (SymbolT g) Strictness - strsig :: Applicative f => (Strictness -> f Strictness) -> SymbolT g -> f (SymbolT g) - strsig _ (sym@(T _)) = pure sym - strsig _ (sym@(L _)) = pure sym - strsig f (D s) = (\strsig -> D s.{strsig}) <$> f s.strsig - strsig _ (sym@(C _)) = pure sym - strsig _ (sym@(I _)) = pure sym - strsig f (V s) = (\strsig -> V s.{strsig}) <$> f s.strsig - strsig _ (sym@(A _)) = pure sym - -- typ :: Traversal' (SymbolT g) Sigma - typ :: Applicative f => (Sigma -> f Sigma) -> SymbolT g -> f (SymbolT g) - typ f (T s) = (\typ -> T s.{typ}) <$> f s.typ - typ _ (sym@(L _)) = pure sym - typ f (D s) = (\typ -> D s.{typ}) <$> f s.typ - typ _ (sym@(C _)) = pure sym - typ f (I s) = (\typ -> I s.{typ}) <$> f s.typ - typ f (V s) = (\typ -> V s.{typ}) <$> f s.typ - typ f (A s) = (\typ -> A s.{typ}) <$> f s.typ - -- vis :: Lens' (SymbolT g) Visibility - vis :: Functor f => (Visibility -> f Visibility) -> SymbolT g -> f (SymbolT g) - vis f (T s) = (\vis -> T s.{vis}) <$> f s.vis - vis f (L s) = (\vis -> L s.{vis}) <$> f s.vis - vis f (D s) = (\vis -> D s.{vis}) <$> f s.vis - vis f (C s) = (\vis -> C s.{vis}) <$> f s.vis - vis f (I s) = (\vis -> I s.{vis}) <$> f s.vis - vis f (V s) = (\vis -> V s.{vis}) <$> f s.vis - vis f (A s) = (\vis -> A s.{vis}) <$> f s.vis + name :: SymbolT g -> QName + name (T s) = s.name + name (L s) = s.name + name (D s) = s.name + name (C s) = s.name + name (I s) = s.name + name (V s) = s.name + name (A s) = s.name + pos :: SymbolT g -> Position + pos (T s) = s.pos + pos (L s) = s.pos + pos (D s) = s.pos + pos (C s) = s.pos + pos (I s) = s.pos + pos (V s) = s.pos + pos (A s) = s.pos + sid :: SymbolT g -> Int + sid (T s) = s.sid + sid (L s) = s.sid + sid (D s) = s.sid + sid (C s) = s.sid + sid (I s) = s.sid + sid (V s) = s.sid + sid (A s) = s.sid + vis :: SymbolT g -> Visibility + vis (T s) = s.vis + vis (L s) = s.vis + vis (D s) = s.vis + vis (C s) = s.vis + vis (I s) = s.vis + vis (V s) = s.vis + vis (A s) = s.vis + + -- _doc :: Traversal' (SymbolT g) (Maybe String) + _doc :: Applicative f => (Maybe String -> f (Maybe String)) -> SymbolT g -> f (SymbolT g) + _doc f (T s) = (\doc -> T s.{doc}) <$> f s.doc + _doc _ (sym@(L _)) = pure sym + _doc f (D s) = (\doc -> D s.{doc}) <$> f s.doc + _doc f (C s) = (\doc -> C s.{doc}) <$> f s.doc + _doc f (I s) = (\doc -> I s.{doc}) <$> f s.doc + _doc f (V s) = (\doc -> V s.{doc}) <$> f s.doc + _doc f (A s) = (\doc -> A s.{doc}) <$> f s.doc + -- _kind :: Traversal' (SymbolT g) Kind + _kind :: Applicative f => (Kind -> f Kind) -> SymbolT g -> f (SymbolT g) + _kind f (T s) = (\kind -> T s.{kind}) <$> f s.kind + _kind _ (sym@(L _)) = pure sym + _kind _ (sym@(D _)) = pure sym + _kind _ (sym@(C _)) = pure sym + _kind _ (sym@(I _)) = pure sym + _kind _ (sym@(V _)) = pure sym + _kind f (A s) = (\kind -> A s.{kind}) <$> f s.kind + -- _meth :: Traversal' (SymbolT g) (TreeMap String (SymMeth g)) + _meth :: Applicative f => (TreeMap String (SymMeth g) -> f (TreeMap String (SymMeth g))) -> SymbolT g -> f (SymbolT g) + _meth _ (sym@(T _)) = pure sym + _meth _ (sym@(L _)) = pure sym + _meth _ (sym@(D _)) = pure sym + _meth f (C s) = (\meth -> C s.{meth}) <$> f s.meth + _meth f (I s) = (\meth -> I s.{meth}) <$> f s.meth + _meth _ (sym@(V _)) = pure sym + _meth _ (sym@(A _)) = pure sym + -- _name :: Lens' (SymbolT g) QName + _name :: Functor f => (QName -> f QName) -> SymbolT g -> f (SymbolT g) + _name f (T s) = (\name -> T s.{name}) <$> f s.name + _name f (L s) = (\name -> L s.{name}) <$> f s.name + _name f (D s) = (\name -> D s.{name}) <$> f s.name + _name f (C s) = (\name -> C s.{name}) <$> f s.name + _name f (I s) = (\name -> I s.{name}) <$> f s.name + _name f (V s) = (\name -> V s.{name}) <$> f s.name + _name f (A s) = (\name -> A s.{name}) <$> f s.name + -- _nativ :: Traversal' (SymbolT g) (Maybe String) + _nativ :: Applicative f => (Maybe String -> f (Maybe String)) -> SymbolT g -> f (SymbolT g) + _nativ f (T s) = (\nativ -> T s.{nativ}) <$> f s.nativ + _nativ _ (sym@(L _)) = pure sym + _nativ _ (sym@(D _)) = pure sym + _nativ _ (sym@(C _)) = pure sym + _nativ _ (sym@(I _)) = pure sym + _nativ f (V s) = (\nativ -> V s.{nativ}) <$> f s.nativ + _nativ _ (sym@(A _)) = pure sym + -- _op :: Traversal' (SymbolT g) TokenID + _op :: Applicative f => (TokenID -> f TokenID) -> SymbolT g -> f (SymbolT g) + _op _ (sym@(T _)) = pure sym + _op _ (sym@(L _)) = pure sym + _op f (D s) = (\op -> D s.{op}) <$> f s.op + _op _ (sym@(C _)) = pure sym + _op _ (sym@(I _)) = pure sym + _op f (V s) = (\op -> V s.{op}) <$> f s.op + _op _ (sym@(A _)) = pure sym + -- _pos :: Lens' (SymbolT g) Position + _pos :: Functor f => (Position -> f Position) -> SymbolT g -> f (SymbolT g) + _pos f (T s) = (\pos -> T s.{pos}) <$> f s.pos + _pos f (L s) = (\pos -> L s.{pos}) <$> f s.pos + _pos f (D s) = (\pos -> D s.{pos}) <$> f s.pos + _pos f (C s) = (\pos -> C s.{pos}) <$> f s.pos + _pos f (I s) = (\pos -> I s.{pos}) <$> f s.pos + _pos f (V s) = (\pos -> V s.{pos}) <$> f s.pos + _pos f (A s) = (\pos -> A s.{pos}) <$> f s.pos + -- _pur :: Traversal' (SymbolT g) Bool + _pur :: Applicative f => (Bool -> f Bool) -> SymbolT g -> f (SymbolT g) + _pur f (T s) = (\pur -> T s.{pur}) <$> f s.pur + _pur _ (sym@(L _)) = pure sym + _pur _ (sym@(D _)) = pure sym + _pur _ (sym@(C _)) = pure sym + _pur _ (sym@(I _)) = pure sym + _pur f (V s) = (\pur -> V s.{pur}) <$> f s.pur + _pur _ (sym@(A _)) = pure sym + -- _sid :: Lens' (SymbolT g) Int + _sid :: Functor f => (Int -> f Int) -> SymbolT g -> f (SymbolT g) + _sid f (T s) = (\sid -> T s.{sid}) <$> f s.sid + _sid f (L s) = (\sid -> L s.{sid}) <$> f s.sid + _sid f (D s) = (\sid -> D s.{sid}) <$> f s.sid + _sid f (C s) = (\sid -> C s.{sid}) <$> f s.sid + _sid f (I s) = (\sid -> I s.{sid}) <$> f s.sid + _sid f (V s) = (\sid -> V s.{sid}) <$> f s.sid + _sid f (A s) = (\sid -> A s.{sid}) <$> f s.sid + -- _strsig :: Traversal' (SymbolT g) Strictness + _strsig :: Applicative f => (Strictness -> f Strictness) -> SymbolT g -> f (SymbolT g) + _strsig _ (sym@(T _)) = pure sym + _strsig _ (sym@(L _)) = pure sym + _strsig f (D s) = (\strsig -> D s.{strsig}) <$> f s.strsig + _strsig _ (sym@(C _)) = pure sym + _strsig _ (sym@(I _)) = pure sym + _strsig f (V s) = (\strsig -> V s.{strsig}) <$> f s.strsig + _strsig _ (sym@(A _)) = pure sym + -- _typ :: Traversal' (SymbolT g) Sigma + _typ :: Applicative f => (Sigma -> f Sigma) -> SymbolT g -> f (SymbolT g) + _typ f (T s) = (\typ -> T s.{typ}) <$> f s.typ + _typ _ (sym@(L _)) = pure sym + _typ f (D s) = (\typ -> D s.{typ}) <$> f s.typ + _typ _ (sym@(C _)) = pure sym + _typ f (I s) = (\typ -> I s.{typ}) <$> f s.typ + _typ f (V s) = (\typ -> V s.{typ}) <$> f s.typ + _typ f (A s) = (\typ -> A s.{typ}) <$> f s.typ + -- _vis :: Lens' (SymbolT g) Visibility + _vis :: Functor f => (Visibility -> f Visibility) -> SymbolT g -> f (SymbolT g) + _vis f (T s) = (\vis -> T s.{vis}) <$> f s.vis + _vis f (L s) = (\vis -> L s.{vis}) <$> f s.vis + _vis f (D s) = (\vis -> D s.{vis}) <$> f s.vis + _vis f (C s) = (\vis -> C s.{vis}) <$> f s.vis + _vis f (I s) = (\vis -> I s.{vis}) <$> f s.vis + _vis f (V s) = (\vis -> V s.{vis}) <$> f s.vis + _vis f (A s) = (\vis -> A s.{vis}) <$> f s.vis --- a generalized read-only view of 'env' env' :: SymbolT g -> Maybe (TreeMap String (SymbolT g)) env' (T s) = Just s.env - env' s = fmap (fmap SymMeth.toSymbol) $ preview meth s + env' s = fmap (fmap SymMeth.toSymbol) $ preview _meth s -- TODO add for performance? -- envValues' :: SymbolT g -> Maybe [SymbolT g] @@ -360,9 +393,9 @@ instance Ord (SymA g) where --- Symbols ordered by the 'Symbol.sid' field, which is a unique number. --- This allows us to have sets of symbols. instance Ord (SymbolT g) where - sym1 <=> sym2 = view SymbolT.sid sym1 <=> view SymbolT.sid sym2 - sym1 == sym2 = view SymbolT.sid sym1 == view SymbolT.sid sym2 - sym1 != sym2 = view SymbolT.sid sym1 != view SymbolT.sid sym2 + sym1 <=> sym2 = sym1.sid <=> sym2.sid + sym1 == sym2 = sym1.sid == sym2.sid + sym1 != sym2 = sym1.sid != sym2.sid instance Positioned (SymMeth g) where @@ -372,8 +405,8 @@ instance Positioned (SymMeth g) where instance Positioned (SymbolT g) where is x = "" - getpos = view SymbolT.pos + getpos = SymbolT.pos getrange sym = case sym.env' of - Just env -> fold Position.merge (view SymbolT.pos sym) (map getrange (values env)) + Just env -> fold Position.merge sym.pos (map getrange (values env)) Nothing -> getpos sym diff --git a/frege/ide/Utilities.fr b/frege/ide/Utilities.fr index a4d3834f..e465d72f 100644 --- a/frege/ide/Utilities.fr +++ b/frege/ide/Utilities.fr @@ -10,7 +10,7 @@ import frege.compiler.passes.Imp as I(getFP) import frege.compiler.tc.Util as TC import frege.compiler.Typecheck as TY hiding(pass, post) -import frege.compiler.common.Lens (_Just, preview, view) +import frege.compiler.common.Lens (preview) import Compiler.enums.TokenID(TokenID, defaultInfix) import Compiler.enums.Visibility(Private, Public) @@ -251,7 +251,7 @@ proposeContent !global root !offset !tokens !index = propose Just (Right qname) <- Global.resolved global qual, traceLn ("resolved " ++ qual.value) || true, Just sym <- global.findit qname, - Just typ <- preview SymbolT.typ sym, + Just typ <- preview SymbolT._typ sym, traceLn ("found " ++ sym.nice global) || true, = memProposal typ theProposal | (Token{tokid=CHAR, value="."} : (qual@Token{tokid=VARID}) :_) <- snekot, @@ -259,7 +259,7 @@ proposeContent !global root !offset !tokens !index = propose Just (Right qname) <- Global.resolved global qual, traceLn ("resolved " ++ qual.value) || true, Just sym <- global.findit qname, - Just typ <- preview SymbolT.typ sym, + Just typ <- preview SymbolT._typ sym, traceLn ("found " ++ sym.nice global) || true, = memProposal typ insideProposal | (Token{tokid=VARID}:Token{tokid=CHAR, value="."}:(qual@Token{tokid=STRCONST}):_) <- snekot, @@ -360,7 +360,7 @@ proposeContent !global root !offset !tokens !index = propose Just (Right qname) <- Global.resolved global token, traceLn ("resolved " ++ value) || true, Just sym <- global.findit qname, - Just typ <- preview SymbolT.typ sym, + Just typ <- preview SymbolT._typ sym, traceLn ("found " ++ sym.nice global) || true, RhoTau{tau} <- typ.rho, tau <- TC.reduced tau global, @@ -373,7 +373,7 @@ proposeContent !global root !offset !tokens !index = propose Just (Right qname) <- Global.resolved global token, traceLn ("resolved " ++ value) || true, Just sym <- global.findit qname, - Just typ <- preview SymbolT.typ sym, + Just typ <- preview SymbolT._typ sym, traceLn ("found " ++ sym.nice global) || true, (tau,_) <- U.returnType typ.rho, tau <- TC.reduced tau global, @@ -553,7 +553,7 @@ proposeContent !global root !offset !tokens !index = propose after = if null afters then Nothing else Just (DL.minimumBy (comparing symoffset) afters) - symoffset = Token.offset . Position.first . view SymbolT.pos + symoffset = Token.offset . Position.first . _.pos (befores, afters) = DL.partitioned (( 0 - then (view SymbolT.name sym).base.startsWith model.prefix + then sym.name.base.startsWith model.prefix else true, - let (proposal, newText) = symProp (view SymbolT.name sym).base sym + let (proposal, newText) = symProp sym.name.base sym ] -- standardFilter standardFilter = [notPrivate, notTuple, notInstance, notOverloaded] - notPrivate sym = view SymbolT.vis sym != Private - || global.our (view SymbolT.name sym) + notPrivate sym = sym.vis != Private + || global.our sym.name || Lens.is SymbolT._L sym - notTuple = not . (flip String.startsWith "(") . QName.base . view SymbolT.name + notTuple = not . (flip String.startsWith "(") . QName.base . _.name notInstance = (Just "instance" !=) . fmap (flip Nice.category global) . global.follow notOverloaded sym @@ -627,7 +627,7 @@ proposeContent !global root !offset !tokens !index = propose classMember sym | Just member <- global.follow sym, - MName{tynm, base} <- view SymbolT.name member, + MName{tynm, base} <- member.name, Just (SymbolT.C _) <- global.findit tynm = true | otherwise = false -- make proposals for symbols in given symtab, considering prefix if any @@ -663,8 +663,8 @@ proposeContent !global root !offset !tokens !index = propose name `elem` overld.over = symProp stem $ SymbolT.V overld | otherwise = (imported, base) where - imported | global.our (view SymbolT.name sym) = base - | otherwise = base ++ " (" ++ nice (view SymbolT.name sym) global ++ ")" + imported | global.our sym.name = base + | otherwise = base ++ " (" ++ nice sym.name global ++ ")" {-- Create a list of triples with position, namespace and package @@ -682,14 +682,14 @@ imports g = [ (pos, NSName.unNS ns, Pack.raw pack) | symbols :: Symtab -> [Symbol] symbols tab = (sortBy positionAndName • filter wanted • values) tab where - positionAndName a b = case view SymbolT.pos a <=> view SymbolT.pos b of - Eq -> comparing (QName.base . view SymbolT.name) a b + positionAndName a b = case a.pos <=> b.pos of + Eq -> comparing (QName.base . _.name) a b ne -> ne wanted :: Symbol -> Bool wanted sym | SymbolT.L _ <- sym = false - | Local{} <- view SymbolT.name sym = true - | (view SymbolT.name sym).base ~ ´^(chg|upd|has|let|anon|lc)\$´ = false + | Local{} <- sym.name = true + | sym.name.base ~ ´^(chg|upd|has|let|anon|lc)\$´ = false | otherwise = true exprSymbols = U.foldEx false collectsyms [] @@ -721,8 +721,8 @@ label g (SymbolT.A SymA{name,typ}) = name.base ++ " = " ++ typ.rho.nicer gspecia where gspecial = g.{options <- _.{flags <- Flags.flagSet SPECIAL}} label g sym - | Just kind <- preview SymbolT.kind sym = (view SymbolT.name sym).base ++ dcolon g ++ show kind - | otherwise = (view SymbolT.name sym).base + | Just kind <- preview SymbolT._kind sym = sym.name.base ++ dcolon g ++ show kind + | otherwise = sym.name.base {-- Increment the pass number in the state @@ -797,7 +797,7 @@ symbolDocumentation sym = do g <- getSTT let syms = case sym of SymbolT.L SymL{alias} | Just target <- g.findit alias = - if (view SymbolT.name sym).base == (view SymbolT.name target).base + if sym.name.base == target.name.base then [target] else [sym, target] other = [sym] @@ -850,10 +850,10 @@ infixDoc g = joined "
\n" (map htmlsafe lines) where tab = thisTab g - syms = [ (desc op, (view SymbolT.name sym0).base) | + syms = [ (desc op, sym0.name.base) | sym0 ← values tab, sym ← g.follow sym0, -- resolve symlinks - op <- preview SymbolT.op sym, + op <- preview SymbolT._op sym, op != defaultInfix ] groups = map toTuple • groupBy (using fst) • sortBy (descending fst) $ syms diff --git a/frege/tools/Doc.fr b/frege/tools/Doc.fr index 82384662..3027c6e0 100644 --- a/frege/tools/Doc.fr +++ b/frege/tools/Doc.fr @@ -63,7 +63,7 @@ import Data.TreeMap as TM(TreeMap, keys, values, each, insert) import Data.List as DL(sortBy, groupBy, intersperse) import Data.Bits -import frege.compiler.common.Lens (view) +import frege.compiler.common.Lens () import Compiler.enums.Flags as Compilerflags(VERBOSE) import Compiler.enums.Visibility(Public) @@ -318,15 +318,15 @@ mkLinks ns pack = do link :: Symbol -> StG () link (sym::Symbol) = do g <- getST - case g.thisTab.lookupS (view SymbolT.name sym).key of + case g.thisTab.lookupS sym.name.key of Just _ -> return () - Nothing -> let rsym = fromMaybe sym (g.findit (view SymbolT.name sym)) in + Nothing -> let rsym = fromMaybe sym (g.findit sym.name) in I.linkHere (ns.unNS) pack - protoItem.{name=Simple (view SymbolT.pos sym).first.{value=(view SymbolT.name sym).base}, + protoItem.{name=Simple sym.pos.first.{value=sym.name.base}, members = if isJust (SymbolT.env' rsym) && not (Lens.is SymbolT._I rsym) then Just [] else Nothing, - alias=(view SymbolT.name sym).base} + alias=sym.name.base} sym continueImport = do @@ -376,7 +376,7 @@ continueNamespaces fp = do tableOC = [h3 (text "Table of Content"), toc] toc = ul (Just "data") (tocpars [ (asyms++csyms++dsyms - ++(sortBy (comparing $ view SymbolT.pos) (map SymbolT.V funs ++ links)), "data", "Definitions"), + ++(sortBy (comparing _.pos) (map SymbolT.V funs ++ links)), "data", "Definitions"), -- (asyms, "data", "Type Aliases"), -- (csyms, "data", "Type Classes"), -- (dsyms, "data", "Data Types"), @@ -422,17 +422,17 @@ continueNamespaces fp = do DL (Just "func") (map docTypes ordfuns)] definitions = [h2 (XLbl "data" (text "Definitions")), DL (Just "data") (map (docSym g) sourcesyms)] - sourcesyms = sortBy (comparing $ view SymbolT.pos) (asyms ++ csyms ++ dsyms ++ map SymbolT.V funs ++ links) - asyms = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.A _) <- values g.thisTab] - csyms = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.C _) <- values g.thisTab] - isyms = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.I _) <- values g.thisTab] - dsyms = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.T _) <- values g.thisTab] - funs = sortBy (comparing $ _.name) [symv | SymbolT.V symv <- values g.thisTab] - links = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.L SymL{alias}) <- values g.thisTab, + sourcesyms = sortBy (comparing _.pos) (asyms ++ csyms ++ dsyms ++ map SymbolT.V funs ++ links) + asyms = sortBy (comparing _.name) [sym | sym@(SymbolT.A _) <- values g.thisTab] + csyms = sortBy (comparing _.name) [sym | sym@(SymbolT.C _) <- values g.thisTab] + isyms = sortBy (comparing _.name) [sym | sym@(SymbolT.I _) <- values g.thisTab] + dsyms = sortBy (comparing _.name) [sym | sym@(SymbolT.T _) <- values g.thisTab] + funs = sortBy (comparing _.name) [symv | SymbolT.V symv <- values g.thisTab] + links = sortBy (comparing _.name) [sym | sym@(SymbolT.L SymL{alias}) <- values g.thisTab, g.our alias, other <- g.findit alias, not (Lens.is SymbolT._D other), -- no constructor aliases - noclassmember g $ view SymbolT.name other] + noclassmember g other.name] where noclassmember g (MName tname _) = case g.findit tname of Just (SymbolT.C _) -> false @@ -444,7 +444,7 @@ continueNamespaces fp = do , env <- SymbolT.env' sym , SymbolT.V s <- values env ] ordfuns = groupBy (using _.typ) (sortBy (comparing _.typ) allfuns) - expfuns = sortBy (comparing $ view SymbolT.name) [sym | sym@(SymbolT.L SymL{pos,vis,alias}) <- values g.thisTab, + expfuns = sortBy (comparing _.name) [sym | sym@(SymbolT.L SymL{pos,vis,alias}) <- values g.thisTab, vis == Public, not (g.our alias) ] docTypes :: [SymV Global] -> (Text, [Paragraph]) diff --git a/frege/tools/Splitter.fr b/frege/tools/Splitter.fr index a4643b4f..afdd68aa 100644 --- a/frege/tools/Splitter.fr +++ b/frege/tools/Splitter.fr @@ -9,7 +9,7 @@ import Data.TreeMap as L(values, keys, each, TreeMap) import Data.Bits import Data.Graph (stronglyConnectedComponents tsort) -import frege.compiler.common.Lens (set, view) +import frege.compiler.common.Lens (set) import Compiler.enums.Flags as Compilerflags(IDETOKENS, NOUNLET) import Compiler.enums.TokenID @@ -123,7 +123,7 @@ ours g = (filter (g.ourSym) . filter noAliases) (values g.thisTab) noAliases (SymbolT.L SymL{name=n@VName{},alias=a@VName{}}) = g.our a && g.our n noAliases (SymbolT.L _) = false noAliases _ = true -ascending g = sortBy (Prelude.comparing (view SymbolT.pos)) (ours g) +ascending g = sortBy (Prelude.comparing (_.pos)) (ours g) split :: [String] -> StIO (String, Int) split args = do @@ -137,7 +137,7 @@ split args = do -- doio $ mapM_ (printRange g) (ascending g) let deps g = map (symDep g) (ascending g) udeps = map (\(a,as) -> (a, filter (a!=) as)) -- eliminate self recursion - (zip (map (view SymbolT.name) (ascending g)) (map keys (deps g))) + (zip (map (_.name) (ascending g)) (map keys (deps g))) deptree = L.fromList udeps tdeps = tsort udeps asc = ascending g @@ -261,7 +261,7 @@ printMods g modul mbHelper mItems hItems syms = do dat <- openReader g.options.source >>= getContentsOf -- print the initial portion of the original file let first = head syms - startoff = (view SymbolT.pos first).first.offset + startoff = first.pos.first.offset initialportion = substr dat 0 startoff orig <- newMod g (g.unpack g.thisPack) orig.println initialportion @@ -294,8 +294,8 @@ printMods g modul mbHelper mItems hItems syms = do where out :: String -> MutableIO PrintWriter -> MutableIO PrintWriter -> MutableIO PrintWriter -> Symbol -> IO () out dat ow mw hw sym = do - let symName = view SymbolT.name sym - symPos = view SymbolT.pos sym + let symName = sym.name + symPos = sym.pos stderr.println (nicer symName g ++ ", range=" ++ symPos.first.value ++ " .. " ++ show symPos.last) @@ -427,8 +427,9 @@ printDep g tree qns = do println "" println (" :: " ++ show (map (flip nicer g) xs)) -printRange g symbol = do - let pos = view SymbolT.pos symbol +printRange :: Global -> Symbol -> IO () +printRange g symbol = do + let pos = symbol.pos println (show pos.first.offset ++ "-" ++ show (pos.end) ++ symbol.nicer g @@ -463,7 +464,7 @@ fullRange symbol next = do -- doio $ stderr.println ("Last token: " ++ show last) return last upperRange symbol (Just next) - | (view SymbolT.pos symbol).end >= (view SymbolT.pos next).start = do + | symbol.pos.end >= next.pos.start = do g <- getSTT liftIO do stderr.println "I am sorry, but I can't continue." @@ -472,7 +473,7 @@ fullRange symbol next = do ++ nicer next g ++ " do overlap, ") stderr.println "probably because of annotations detached from their definitions." System.exit 4 - return (view SymbolT.pos symbol).first + return symbol.pos.first | otherwise = do g <- getSTT lower <- lowerRange next @@ -499,11 +500,11 @@ fullRange symbol next = do lowerRange symbol = do g <- getSTT let toks = g.sub.toks - this = (view SymbolT.pos symbol).first `indexIn` toks + this = symbol.pos.first `indexIn` toks case this of Just index -> return (elemAt toks n) where n = skipComments index toks Nothing -> error ("Couldn't find start token " - ++ show (view SymbolT.pos symbol).first ++ " of " ++ symbol.nicer g) + ++ show symbol.pos.first ++ " of " ++ symbol.nicer g) dclintro :: [TokenID] @@ -530,7 +531,7 @@ makeRanges ascending = do let nextTokens = map Just (tail ascending) ++ [Nothing] ranges = zipWith fullRange ascending nextTokens ranges <- sequence ranges - mapM_ (liftStG . changeSym) (zipWith (flip $ set SymbolT.pos) ascending ranges) + mapM_ (liftStG . changeSym) (zipWith (flip $ set SymbolT._pos) ascending ranges) -- symDep g _ sym | traceLn ("doing symDep for " ++ nicer sym g) = undefined symDep g (SymbolT.A SymA{typ}) = sigmaDep g typ diff --git a/frege/tools/doc/Utilities.fr b/frege/tools/doc/Utilities.fr index 7038f844..d27ebfb3 100644 --- a/frege/tools/doc/Utilities.fr +++ b/frege/tools/doc/Utilities.fr @@ -244,9 +244,9 @@ docSym g (SymbolT.T SymT{name, doc, typ=ForAll _ rho, env, nativ, pur}) = (code nativetype (Just s) = text " = " :- mode pur :- (bold • text $ "native ") :- text s mode true = (bold . text) $ "immutable " mode false = (bold . text) $ "mutable " - members = sortBy (comparing $ view SymbolT.name) [ v | v@(SymbolT.V SymV{name}) <- values env, + members = sortBy (comparing $ _.name) [ v | v@(SymbolT.V SymV{name}) <- values env, QName.base name !~ ´\$´] - constrs = sortBy (comparing $ view SymbolT.name) [ v | v@(SymbolT.D _) <- values env] + constrs = sortBy (comparing $ _.name) [ v | v@(SymbolT.D _) <- values env] content = [ p | d <- [docit g doc, if null constrs then [] else [h3 (text "Constructors"), @@ -297,7 +297,7 @@ docSym g (SymbolT.V (sym@SymV{name, typ, doc, nativ, pur, strsig, op, throwing}) -- tsig Nothing = badref "no type???" ovl = case nativ of Just _ | (o:_) <- overloadOf g (SymbolT.V sym) - = spaces 2 :- (bold • text $ "overloads ") :- Ref (view SymbolT.name o) (text (view SymbolT.name o).base) + = spaces 2 :- (bold • text $ "overloads ") :- Ref o.name (text o.name.base) _ = text "" title = label name :- text (symDcolon g) :- tsig typ :- tnat nativ :- tthrows throwing :- ovl :- docop op @@ -319,10 +319,10 @@ docop tok --- Give the function that is overloaded with this one. overloadOf :: Global -> Symbol -> [Symbol] overloadOf g sym = [ SymbolT.V o - | symtab <- g.packages.lookup (view SymbolT.name sym).getpack + | symtab <- g.packages.lookup sym.name.getpack , symbol <- values symtab , o@SymV{over=(_:_)} <- symvs symbol - , view SymbolT.name sym `elem` o.over + , sym.name `elem` o.over ] where symvs sym From 750cc61e6176a11c17a3aaf1dbe484ea03f68f25 Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 22:21:20 +0900 Subject: [PATCH 82/95] Remove Prisms and use Traversals instead We don't use 'review', so Traversal is enough. Well, we do use 'is', but 'has' can be used for the purpose. Prism depends on Profunctor. In Haskell, the "profunctor" is a huge package. If, in some day, we port it to Frege, the compiler depending on it may be a problem. --- frege/compiler/common/Lens.fr | 98 ++++++-------------------------- frege/compiler/common/Resolve.fr | 2 +- frege/compiler/passes/Enter.fr | 2 +- frege/compiler/passes/Imp.fr | 2 +- frege/compiler/types/Symbols.fr | 81 +++++++++++++++----------- frege/ide/Utilities.fr | 2 +- frege/tools/Doc.fr | 4 +- 7 files changed, 70 insertions(+), 121 deletions(-) diff --git a/frege/compiler/common/Lens.fr b/frege/compiler/common/Lens.fr index 59c5360e..6dc78100 100644 --- a/frege/compiler/common/Lens.fr +++ b/frege/compiler/common/Lens.fr @@ -1,8 +1,4 @@ ---- The code here is taken and modified from Haskell's "profunctors" and "lens" packages. ---- ---- profunctors: ---- Copyright 2011-2015 Edward Kmett ---- License BSD-3-Clause +--- The code here is taken and modified from Haskell's "lens" packages. --- --- lens: --- Copyright 2012-2016 Edward Kmett @@ -14,30 +10,9 @@ import frege.data.wrapper.Boolean (All, Any) import frege.data.wrapper.Const (Const) import frege.data.wrapper.Identity (Identity) -class Profunctor p where - dimap :: (a -> b) -> (c -> d) -> p b c -> p a d - lmap :: (a -> b) -> p b c -> p a c - rmap :: (b -> c) -> p a b -> p a c - -instance Profunctor (->) where - dimap ab cd bc = cd . bc . ab - lmap = flip (.) - rmap = (.) - -class Profunctor p => Choice p where - left' :: p a b -> p (Either a c) (Either b c) - right' :: p a b -> p (Either c a) (Either c b) - -instance Choice (->) where - left' ab (Left a) = Left (ab a) - left' _ (Right c) = Right c - right' = fmap - -- note: currently the compiler fails to infer the correct kinds of @f@ -- when incrementally compiling, so you have to write type annotations without the aliases -type APrism s t a b = Market a b a (Identity b) -> Market a b s (Identity t) -type APrism' s a = APrism s s a a type ASetter s t a b = (a -> Identity b) -> s -> Identity t type ASetter' s a = ASetter s s a a type Getting r s a = (a -> Const r a) -> s -> Const r s @@ -45,35 +20,9 @@ type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t type Lens' s a = Lens s s a a type LensLike f s t a b = (a -> f b) -> s -> f t type LensLike' f s a = LensLike f s s a a -type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) -type Prism' s a = Prism s s a a type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t type Traversal' s a = Traversal s s a a -data Market a b s t = Market (b -> t) (s -> Either t a) - -instance Functor (Market a b s) where - fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) - -instance Profunctor (Market a b) where - dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f) - lmap f (Market bt seta) = Market bt (seta . f) - rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta) - -instance Choice (Market a b) where - left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of - Left s -> case seta s of - Left t -> Left (Left t) - Right a -> Right a - Right c -> Left (Right c) - right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of - Left c -> Left (Left c) - Right s -> case seta s of - Left t -> Left (Right t) - Right a -> Right a - -type Market' a = Market a a - -- getters -- dealing with Lenses @@ -86,36 +35,17 @@ views l f = Const.get . l (Const . f) -- dealing with optional fields (Traversals) +-- internal note: also used in place of @is@ of @Prism@ because we don't have @Prism@. has :: Getting Any s a -> s -> Bool has l = Any.unwrap . views l (\_ -> Any True) +-- internal note: also used in place of @isn't@ of @Prism@ because we don't have @Prism@. hasn't :: Getting All s a -> s -> Bool hasn't l = All.unwrap . views l (\_ -> All False) preview :: Getting (First a) s a -> s -> Maybe a preview l = First.getFirst . views l (First . Just) --- dealing with prisms - -prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b -prism bt seta = dimap seta (either pure (fmap bt)) . right' - -prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b -prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s)) - -withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r -withPrism k f = case k (Market Identity Right) of - Market bt seta -> f (Identity.run . bt) (either (Left . Identity.run) Right . seta) - -is :: APrism s t a b -> s -> Bool -is k = not . isn't k - -isn't :: APrism s t a b -> s -> Bool -isn't k s = either (\_ -> True) (\_ -> False) (matching k s) - -matching :: APrism s t a b -> s -> Either t a -matching k = withPrism k $ \_ seta -> seta - -- setters over :: ASetter s t a b -> (a -> b) -> s -> t @@ -125,18 +55,24 @@ set :: ASetter s t a b -> b -> s -> t set l b = Identity.run . l (\_ -> Identity b) -- some concrete prisms +-- defined as @Traversal@ because we don't have @Prism@ -_Left :: Prism (Either a c) (Either b c) a b -_Left = prism Left $ either Right (Left . Right) +_Left :: Traversal (Either a c) (Either b c) a b +_Left f (Left x) = Left <$> f x +_Left _ (Right x) = pure (Right x) -_Right :: Prism (Either c a) (Either c b) a b -_Right = prism Right $ either (Left . Left) Right +_Right :: Traversal (Either c a) (Either c b) a b +_Right f (Right x) = Right <$> f x +_Right _ (Left x) = pure (Left x) -_Just :: Prism (Maybe a) (Maybe b) a b -_Just = prism Just $ maybe (Left Nothing) Right +_Just :: Traversal (Maybe a) (Maybe b) a b +_Just f (Just x) = Just <$> f x +_Just _ Nothing = pure Nothing -_Nothing :: Prism' (Maybe a) () -_Nothing = prism' (const Nothing) $ maybe (Just ()) (const Nothing) +-- identical to @flip (const . pure)@ but added for consistency +_Nothing :: Traversal' (Maybe a) () +_Nothing _ Nothing = pure Nothing +_Nothing _ (Just x) = pure (Just x) --- warning: this function is partial -- TODO eliminate the uses of these functions diff --git a/frege/compiler/common/Resolve.fr b/frege/compiler/common/Resolve.fr index 2b63078d..1ee0bb67 100644 --- a/frege/compiler/common/Resolve.fr +++ b/frege/compiler/common/Resolve.fr @@ -132,7 +132,7 @@ private resolve3 fname pos (Simple Token{value=qs}) = do where more :: [String] -> Symtab -> [String] more acc env = foldr (:) acc [ v.name.base | v <- values env, - not (Lens.is SymbolT._I v) ] + not (Lens.has SymbolT._I v) ] -- T.v T.C N.v N.C N.T private resolve3 _ pos (snm@With1 Token{value=n} Token{value=qv}) = do g <- getST diff --git a/frege/compiler/passes/Enter.fr b/frege/compiler/passes/Enter.fr index 831b7838..c389a7b9 100644 --- a/frege/compiler/passes/Enter.fr +++ b/frege/compiler/passes/Enter.fr @@ -225,7 +225,7 @@ enter1ClaDcl fname (d@ClaDcl {pos}) = do define a method with the same name.) -} g <- getST - let vs = (filter (maybe true (not . Lens.is SymbolT._L) + let vs = (filter (maybe true (not . Lens.has SymbolT._L) . g.find . VName g.thisPack . QName.base . _.name) . values . fromMaybe empty) (_.env' =<< g.findit tname) diff --git a/frege/compiler/passes/Imp.fr b/frege/compiler/passes/Imp.fr index 44f632b0..a915652c 100644 --- a/frege/compiler/passes/Imp.fr +++ b/frege/compiler/passes/Imp.fr @@ -251,7 +251,7 @@ importEnv pos env ns pack (imp@Imports {except=true, items}) = do alias = sym.name.base} | sym <- sortBy (comparing constructor) (values env), -- place SymL before SymC csym <- g.findit sym.name, - not (Lens.is SymbolT._D csym) -- no constructors + not (Lens.has SymbolT._D csym) -- no constructors || sym.name.base != csym.name.base, -- except renamed ones csym.name `notElem` exs, sym.vis == Public diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 798fa032..46dbcf9c 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -3,7 +3,7 @@ module frege.compiler.types.Symbols where import frege.data.TreeMap as TM(TreeMap, each, values) import frege.control.monad.State -import frege.compiler.common.Lens (Choice, preview, prism') +import frege.compiler.common.Lens (preview) import frege.compiler.enums.RFlag(RState, RFlag) import frege.compiler.types.Positions import frege.compiler.types.Strictness @@ -152,12 +152,14 @@ data SymMeth global pos f (L s) = (\pos -> L s.{pos}) <$> f s.pos pos f (V s) = (\pos -> V s.{pos}) <$> f s.pos - -- _L :: Prism' (SymMeth g) (SymL g) - _L :: (Choice p, Applicative f) => p (SymL g) (f (SymL g)) -> p (SymMeth g) (f (SymMeth g)) - _L = prism' L (\s -> case s of { SymMeth.L x -> Just x; _ -> Nothing; }) - -- _V :: Prism' (SymMeth g) (SymV g) - _V :: (Choice p, Applicative f) => p (SymV g) (f (SymV g)) -> p (SymMeth g) (f (SymMeth g)) - _V = prism' V (\s -> case s of { SymMeth.V x -> Just x; _ -> Nothing; }) + -- _L :: Traversal' (SymMeth g) (SymL g) + _L :: Applicative f => (SymL g -> f (SymL g)) -> SymMeth g -> f (SymMeth g) + _L f (L s) = L <$> f s + _L _ s = pure s + -- _V :: Traversal' (SymMeth g) (SymV g) + _V :: Applicative f => (SymV g -> f (SymV g)) -> SymMeth g -> f (SymMeth g) + _V f (V s) = V <$> f s + _V _ s = pure s {-- The information stored in the 'Symtab' nodes. @@ -323,34 +325,45 @@ data SymbolT global = -- TODO add for performance? -- envValues' :: SymbolT g -> Maybe [SymbolT g] - -- _T :: Prism' (SymbolT g) (SymT g) - _T :: (Choice p, Applicative f) => p (SymT g) (f (SymT g)) -> p (SymbolT g) (f (SymbolT g)) - _T = prism' T (\s -> case s of { SymbolT.T x -> Just x; _ -> Nothing; }) - -- _L :: Prism' (SymbolT g) (SymL g) - _L :: (Choice p, Applicative f) => p (SymL g) (f (SymL g)) -> p (SymbolT g) (f (SymbolT g)) - _L = prism' L (\s -> case s of { SymbolT.L x -> Just x; _ -> Nothing; }) - -- _D :: Prism' (SymbolT g) (SymD g) - _D :: (Choice p, Applicative f) => p (SymD g) (f (SymD g)) -> p (SymbolT g) (f (SymbolT g)) - _D = prism' D (\s -> case s of { SymbolT.D x -> Just x; _ -> Nothing; }) - -- _C :: Prism' (SymbolT g) (SymC g) - _C :: (Choice p, Applicative f) => p (SymC g) (f (SymC g)) -> p (SymbolT g) (f (SymbolT g)) - _C = prism' C (\s -> case s of { SymbolT.C x -> Just x; _ -> Nothing; }) - -- _I :: Prism' (SymbolT g) (SymI g) - _I :: (Choice p, Applicative f) => p (SymI g) (f (SymI g)) -> p (SymbolT g) (f (SymbolT g)) - _I = prism' I (\s -> case s of { SymbolT.I x -> Just x; _ -> Nothing; }) - -- _V :: Prism' (SymbolT g) (SymV g) - _V :: (Choice p, Applicative f) => p (SymV g) (f (SymV g)) -> p (SymbolT g) (f (SymbolT g)) - _V = prism' V (\s -> case s of { SymbolT.V x -> Just x; _ -> Nothing; }) - -- _A :: Prism' (SymbolT g) (SymA g) - _A :: (Choice p, Applicative f) => p (SymA g) (f (SymA g)) -> p (SymbolT g) (f (SymbolT g)) - _A = prism' A (\s -> case s of { SymbolT.A x -> Just x; _ -> Nothing; }) + -- _T :: Traversal' (SymbolT g) (SymT g) + _T :: Applicative f => (SymT g -> f (SymT g)) -> SymbolT g -> f (SymbolT g) + _T f (T s) = T <$> f s + _T _ s = pure s + -- _L :: Traversal' (SymbolT g) (SymL g) + _L :: Applicative f => (SymL g -> f (SymL g)) -> SymbolT g -> f (SymbolT g) + _L f (L s) = L <$> f s + _L _ s = pure s + -- _D :: Traversal' (SymbolT g) (SymD g) + _D :: Applicative f => (SymD g -> f (SymD g)) -> SymbolT g -> f (SymbolT g) + _D f (D s) = D <$> f s + _D _ s = pure s + -- _C :: Traversal' (SymbolT g) (SymC g) + _C :: Applicative f => (SymC g -> f (SymC g)) -> SymbolT g -> f (SymbolT g) + _C f (C s) = C <$> f s + _C _ s = pure s + -- _I :: Traversal' (SymbolT g) (SymI g) + _I :: Applicative f => (SymI g -> f (SymI g)) -> SymbolT g -> f (SymbolT g) + _I f (I s) = I <$> f s + _I _ s = pure s + -- _V :: Traversal' (SymbolT g) (SymV g) + _V :: Applicative f => (SymV g -> f (SymV g)) -> SymbolT g -> f (SymbolT g) + _V f (V s) = V <$> f s + _V _ s = pure s + -- _A :: Traversal' (SymbolT g) (SymA g) + _A :: Applicative f => (SymA g -> f (SymA g)) -> SymbolT g -> f (SymbolT g) + _A f (A s) = A <$> f s + _A _ s = pure s - -- _Val :: Prism' (SymbolT g) (SymVal g) - _Val :: (Choice p, Applicative f) => p (SymVal g) (f (SymVal g)) -> p (SymbolT g) (f (SymbolT g)) - _Val = prism' SymVal.toSymbol SymVal.fromSymbol - -- _Meth :: Prism' (SymbolT g) (SymMeth g) - _Meth :: (Choice p, Applicative f) => p (SymMeth g) (f (SymMeth g)) -> p (SymbolT g) (f (SymbolT g)) - _Meth = prism' SymMeth.toSymbol SymMeth.fromSymbol + -- _Val :: Traversal' (SymbolT g) (SymVal g) + _Val :: Applicative f => (SymVal g -> f (SymVal g)) -> SymbolT g -> f (SymbolT g) + _Val f s = case SymVal.fromSymbol s of + Just sv -> SymVal.toSymbol <$> f sv + Nothing -> pure s + -- _Meth :: Traversal' (SymbolT g) (SymMeth g) + _Meth :: Applicative f => (SymMeth g -> f (SymMeth g)) -> SymbolT g -> f (SymbolT g) + _Meth f s = case SymMeth.fromSymbol s of + Just sm -> SymMeth.toSymbol <$> f sm + Nothing -> pure s diff --git a/frege/ide/Utilities.fr b/frege/ide/Utilities.fr index e465d72f..be1c8620 100644 --- a/frege/ide/Utilities.fr +++ b/frege/ide/Utilities.fr @@ -617,7 +617,7 @@ proposeContent !global root !offset !tokens !index = propose standardFilter = [notPrivate, notTuple, notInstance, notOverloaded] notPrivate sym = sym.vis != Private || global.our sym.name - || Lens.is SymbolT._L sym + || Lens.has SymbolT._L sym notTuple = not . (flip String.startsWith "(") . QName.base . _.name notInstance = (Just "instance" !=) . fmap (flip Nice.category global) . global.follow diff --git a/frege/tools/Doc.fr b/frege/tools/Doc.fr index 3027c6e0..0a42dee4 100644 --- a/frege/tools/Doc.fr +++ b/frege/tools/Doc.fr @@ -324,7 +324,7 @@ mkLinks ns pack = do I.linkHere (ns.unNS) pack protoItem.{name=Simple sym.pos.first.{value=sym.name.base}, - members = if isJust (SymbolT.env' rsym) && not (Lens.is SymbolT._I rsym) + members = if isJust (SymbolT.env' rsym) && not (Lens.has SymbolT._I rsym) then Just [] else Nothing, alias=sym.name.base} sym @@ -431,7 +431,7 @@ continueNamespaces fp = do links = sortBy (comparing _.name) [sym | sym@(SymbolT.L SymL{alias}) <- values g.thisTab, g.our alias, other <- g.findit alias, - not (Lens.is SymbolT._D other), -- no constructor aliases + not (Lens.has SymbolT._D other), -- no constructor aliases noclassmember g other.name] where noclassmember g (MName tname _) = case g.findit tname of From 98d630ef5707e1983e56b74064c868e0070c3faa Mon Sep 17 00:00:00 2001 From: matil019 Date: Wed, 30 Oct 2019 22:39:08 +0900 Subject: [PATCH 83/95] Replace 'view'ing lenses with simple getters for SymMeth and SymVal The same refactoring as done to SymbolT. Now all uses of 'view's were replaced by simple getters. This contributes to a big reduction of performance penalty. --- frege/compiler/Classes.fr | 30 ++++----- frege/compiler/Typecheck.fr | 18 +++-- frege/compiler/Utilities.fr | 4 +- frege/compiler/common/Trans.fr | 8 +-- frege/compiler/gen/java/Common.fr | 4 +- frege/compiler/gen/java/InstanceCode.fr | 4 +- frege/compiler/gen/java/MethodCall.fr | 4 +- frege/compiler/passes/Easy.fr | 3 +- frege/compiler/passes/Strict.fr | 22 +++--- frege/compiler/passes/Transdef.fr | 18 ++--- frege/compiler/types/Symbols.fr | 90 ++++++++++++++++--------- frege/tools/doc/Utilities.fr | 6 +- 12 files changed, 114 insertions(+), 97 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index c32d9d05..ec414d37 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -45,7 +45,7 @@ import Data.TreeMap as TM(keys, values, TreeMap, insert, delete, lookup) import Data.List as DL(uniq, sort, sortBy, maximumBy) import Data.Graph (stronglyConnectedComponents tsort) -import frege.compiler.common.Lens (preview, set, view) +import frege.compiler.common.Lens (preview, set) import Compiler.enums.Flags as Compilerflags(TRACE6) import Compiler.enums.Visibility @@ -491,13 +491,13 @@ instForThisClass iname tname cname = do | otherwise = do E.logmsg TRACE6 isym.pos (text ("refresh " ++ tname.nice g ++ " instance of " ++ csym.nice g)) - foreach (map (view SymMeth.name) (values csym.meth)) + foreach (map (_.name) (values csym.meth)) (funForCIT cname iname tname) stio () Nothing -> do E.logmsg TRACE6 isym.pos (text ("make " ++ tname.nice g ++ " an instance of " ++ csym.nice g)) - foreach (map (view SymMeth.name) (values csym.meth)) (funForCIT cname iname tname) + foreach (map (_.name) (values csym.meth)) (funForCIT cname iname tname) csym <- U.findC cname changeSym $ SymbolT.C csym.{insts <- ((tsym.name, iname):)} @@ -591,19 +591,19 @@ funForCIT cname iname tname (mname@MName _ base) = do | Just osym <- preview SymbolT._Val osym' , not (g.ourSym osym.toSymbol) || implemented osym -> case tvmb of Just (SymbolT.L (tsym@SymL{alias=same})) - | same == alias = changeSym $ SymVal.toSymbol $ set SymVal.op msym.op osym -- copy op + | same == alias = changeSym $ SymVal.toSymbol $ set SymVal._op msym.op osym -- copy op | same == member = do -- this is the normal case after enter -- remove one indirection changeSym $ SymbolT.L tsym.{alias} - changeSym $ SymVal.toSymbol $ set SymVal.op msym.op osym + changeSym $ SymVal.toSymbol $ set SymVal._op msym.op osym Just err -> E.error ipos (msgdoc ("definition of " ++ member.nicer g ++ " not allowed because " ++ err.nicer g ++ " already exists.")) Nothing -> do E.logmsg TRACE6 ipos (text (mname.nice g ++ " not yet implemented in " ++ tsym.nice g)) linkq (MName tname base) osym.toSymbol - changeSym $ SymVal.toSymbol $ set SymVal.op msym.op osym + changeSym $ SymVal.toSymbol $ set SymVal._op msym.op osym Just osym -> E.error ipos (text (nicer osym g ++ " is not implemented.")) Nothing -> do E.fatal ipos (msgdoc (nicer member g ++ " links to " ++ alias.nicer g ++ ", but the latter doesn't exist.")) @@ -637,14 +637,14 @@ funForCIT cname iname tname (mname@MName _ base) = do Just impl <- preview SymbolT._Val =<< g.follow (SymbolT.L ali) = do if implemented impl then do - E.logmsg TRACE6 (view SymVal.pos impl) (text (mname.nice g ++ " not yet implemented in " ++ isym.nice g)) + E.logmsg TRACE6 impl.pos (text (mname.nice g ++ " not yet implemented in " ++ isym.nice g)) E.logmsg TRACE6 isym.pos (text ("copy implementation from " ++ impl.nice g)) - let ivsym = set SymVal.name (MName iname base) $ set SymVal.sid 0 $ set SymVal.op msym.op $ impl + let ivsym = set SymVal._name (MName iname base) $ set SymVal._sid 0 $ set SymVal._op msym.op $ impl enter ivsym.toSymbol changeSym $ SymbolT.T tsym.{ env <- delete other } linkq (MName tname other) ivsym.toSymbol else do - E.error (view SymVal.pos impl) (msgdoc ("implementation missing for " ++ impl.nicer g)) + E.error impl.pos (msgdoc ("implementation missing for " ++ impl.nicer g)) | MName yname _ <- alias, Just (SymbolT.I ysym) <- g.findit yname, ysym.clas `notElem` csym.supers, @@ -705,20 +705,20 @@ tcInstMethods supers inst = foreach (values inst.meth) (tcInstMethod supers inst tcInstMethod :: [SymC Global] -> SymI Global -> SymMeth Global -> StG () tcInstMethod [] _ msym = do g <- getST - E.error (view SymMeth.pos msym) (msgdoc (msym.nice g ++ " is not a class member function")) + E.error msym.pos (msgdoc (msym.nice g ++ " is not a class member function")) tcInstMethod (sc:scs) isym msym = do g <- getST - case sc.meth.lookupS (view SymMeth.name msym).key of + case sc.meth.lookupS msym.name.key of Nothing -> tcInstMethod scs isym msym Just (SymMeth.V SymV{typ=(s@ForAll sbnd srho)}) | not (isPSigma s) = do g <- getST let !mtnice = case isPSigma sig of true -> "None"; false -> sig.nicer g !csig = ForAll (filter ((sc.tau.var!=) . _.var) sbnd) srho - !sig = case g.findit (view SymMeth.name msym) of + !sig = case g.findit msym.name of Just xsym | Just typ <- preview SymbolT._typ xsym -> typ other -> error ("tcInstMethod: link to nothing: " ++ nice msym g) - E.logmsg TRACE6 (view SymMeth.pos msym) (text (msym.nice g + E.logmsg TRACE6 msym.pos (text (msym.nice g ++ " class: " ++ sc.nice g ++ " class method type: " ++ s.nicer g ++ " own type: " ++ mtnice)) @@ -742,9 +742,9 @@ tcInstMethod (sc:scs) isym msym = do -- of Eq.== for Int adapt = filter (not • T.sameCtx (Ctx Position.null sc.name tau)) -- msig1 = msig - E.logmsg TRACE6 (view SymMeth.pos msym) (text (msym.nice g ++ " adapted type " ++ msig.nicer g)) + E.logmsg TRACE6 msym.pos (text (msym.nice g ++ " adapted type " ++ msig.nicer g)) msig <- T.canonicSignature msig - E.logmsg TRACE6 (view SymMeth.pos msym) (text (msym.nice g ++ " instance type " ++ msig.nicer g)) + E.logmsg TRACE6 msym.pos (text (msym.nice g ++ " instance type " ++ msig.nicer g)) unless (isPSigma sig) do T.subsCheck msym sig msig T.checkConstraints msym sig msig diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index dc4c25bd..4ababf3a 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -79,8 +79,6 @@ import Data.TreeMap as TM(TreeMap, values, lookup, insert, import Data.Graph (stronglyConnectedComponents tsort) import Data.List(groupBy, sortBy) -import frege.compiler.common.Lens (view) - import Compiler.enums.Flags as Compilerflags(flagSet, OVERLOADING, TRACEO, TRACET, TRACEZ) import Compiler.enums.TokenID import Compiler.enums.Visibility @@ -484,23 +482,23 @@ substInst (vbl@Vbl {pos, name = MName tn bs, typ = Just (ForAll [] rho)}) Just imem' | Just imem <- SymVal.fromSymbol imem' -> do let nrho = rho.{context <- filter (not • sameCtx ctx)} strho = substRho - (unifySigma g (view SymVal.typ imem) ForAll{bound=[], rho=nrho}) - (view SymVal.typ imem).rho + (unifySigma g imem.typ ForAll{bound=[], rho=nrho}) + imem.typ.rho !repl = case imem of - SymVal.V _ -> vbl.{name=view SymVal.name imem, typ = Just (ForAll [] strho)} - SymVal.D _ -> Con{pos=vbl.pos, name=view SymVal.name imem, typ = Just (ForAll [] strho)} + SymVal.V _ -> vbl.{name=imem.name, typ = Just (ForAll [] strho)} + SymVal.D _ -> Con{pos=vbl.pos, name=imem.name, typ = Just (ForAll [] strho)} E.logmsg TRACEO pos ( text ("replace " ++ vbl.name.nice g) nest 4 ( text (":: " ++ vbl.typ.nicer g) text ("sigma :: " ++ mem.typ.nicer g) - text ("with " ++ (view SymVal.name imem).nice g) - <+> text (" :: " ++ (view SymVal.typ imem).nicer g) + text ("with " ++ imem.name.nice g) + <+> text (" :: " ++ imem.typ.nicer g) text ("@@ " ++ nrho.nicer g) text ("?? " ++ strho.nicer g))) changeST Global.{sub <- SubSt.{ - idKind <- insert (KeyTk vbl.pos.first) (Right (view SymVal.name imem))}} - weUse (view SymVal.name imem) + idKind <- insert (KeyTk vbl.pos.first) (Right imem.name)}} + weUse imem.name stio (Left repl) Just wtf -> error ("substInst WTF??? : " ++ nicer wtf g) Nothing -> E.fatal vbl.pos (msgdoc ("substInst: trying " diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index ff03f479..ca1bed08 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -50,7 +50,7 @@ import Data.List as DL(partitioned, sortBy, minimumBy, \\) import Lib.PP(fill, break, pretty, text, nest, msgdoc, <+>, <>, DOCUMENT) -import frege.compiler.common.Lens (over, preview, set, view) +import frege.compiler.common.Lens (over, preview, set) -- import Compiler.enums.Flags import Compiler.enums.TokenID(defaultInfix, VARID) @@ -1038,7 +1038,7 @@ isJavaType _ = stio false {-- Arity of a 'SymVal' based on its type -} arity :: SymVal Global -> Int -arity sym = case returnType (view SymVal.typ sym).rho of +arity sym = case returnType sym.typ.rho of (_, xs) -> length xs diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index 338a7554..e231a111 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -6,8 +6,6 @@ import Data.TreeMap as TM(TreeMap, TreeSet, lookup, insert, keys, values, eac import Data.List (partitioned) import Lib.PP(text, msgdoc, <+>, text) -import frege.compiler.common.Lens (view) - import Compiler.enums.TokenID(VARID) import Compiler.enums.SymState(Typechecked) import Compiler.enums.CaseKind(CWhen) @@ -46,7 +44,7 @@ references sids x = U.foldEx true refs 0 x -- g <- getST -- E.logmsg TRACE7 pos ("references " ++ show n ++ " " ++ show sids ++ " " ++ nice name g) sym <- U.findVD name - if view SymVal.sid sym `elem` sids then stio (Right (n+1)) else stio (Left n) + if sym.sid `elem` sids then stio (Right (n+1)) else stio (Left n) refs n (Ifte c t e _) = do crefs <- references sids c trefs <- references sids t @@ -113,7 +111,7 @@ replSid sid r ex = U.mapEx true action ex where action (v@Vbl {name=Local {}}) = do sym <- U.findVD v.name - if view SymVal.sid sym == sid then stio (Right r) else stio (Right v) + if sym.sid == sid then stio (Right r) else stio (Right v) action x = stio (Left x) @@ -122,7 +120,7 @@ replName sid nm ex = U.mapEx true action ex where action (v@Vbl {name,pos}) = do sym <- U.findVD name - if view SymVal.sid sym == sid then do + if sym.sid == sid then do changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk pos.first) (Right nm)}} stio (Right v.{name=nm}) diff --git a/frege/compiler/gen/java/Common.fr b/frege/compiler/gen/java/Common.fr index 06fce98e..3b6fd357 100644 --- a/frege/compiler/gen/java/Common.fr +++ b/frege/compiler/gen/java/Common.fr @@ -4,8 +4,6 @@ module frege.compiler.gen.java.Common where import frege.Prelude hiding (<+>) -import frege.compiler.common.Lens (view) - import Data.TreeMap(values, insert, lookup, TreeMap Map, fromList) import Data.Bits(BitSet.member) import Lib.PP(pretty, text, <+>, ) @@ -878,7 +876,7 @@ unsafeCast g sym = case sym.name of , Just (SymbolT.C SymC{supers}) <- g.findit clas , mems <- [ cmem | Just (SymbolT.C symc) <- map g.findit (clas:supers) , cmem <- symc.meth.lookupS base - , needsUnchecked snd (view SymMeth.name cmem) Something] + , needsUnchecked snd cmem.name Something] = not (null mems) _ = false diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index 38fb3acf..65e989b5 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -7,7 +7,7 @@ import Lib.PP (text, <+>, , <+/>, <>) import Data.TreeMap as Map(values, lookup, delete, insert, TreeMap) import Data.List(zip4) -import frege.compiler.common.Lens (over, view) +import frege.compiler.common.Lens (over) import Compiler.Utilities(findC, findV, forceTau, returnType) import Compiler.Javatypes(subTypeOf) @@ -225,7 +225,7 @@ instanceCode (SymbolT.I sym) = do -- instance definition SymbolT.C SymC{supers} <- g.findit clas, -- of a class that is in our hierarchy clas `elem` classes || any (`elem` classes) supers] _ -> error "unexpected result from instTSym" - methods1 = map (view SymMeth.name) (values sym.meth) + methods1 = map (_.name) (values sym.meth) -- methods of super classes that are implemented in the type itself methods3 = case instTSym sym.typ g of Just tsym -> [ sym.name | diff --git a/frege/compiler/gen/java/MethodCall.fr b/frege/compiler/gen/java/MethodCall.fr index f08b4b5a..87f0c40b 100644 --- a/frege/compiler/gen/java/MethodCall.fr +++ b/frege/compiler/gen/java/MethodCall.fr @@ -5,7 +5,7 @@ import Data.TreeMap(TreeMap, values) import Data.List(elemBy) import frege.data.Monoid (First) -import frege.compiler.common.Lens (Getting, _Just, preview, view) +import frege.compiler.common.Lens (Getting, _Just, preview) import Compiler.Utilities as U() @@ -309,7 +309,7 @@ wildReturn g symv = wrapIRMethod :: Global -> JExpr -> JType -> SymInfo8 -> String -> String -> SymVal Global -> JDecl wrapIRMethod g this irjt nativsi nativnm fldnm fldsym = let nativargs = argDefs attrFinal (nativsi.{ argSigs <- tail, argJTs <- tail }) (getArgs g) - fldstri = case view SymVal.strsig fldsym of + fldstri = case fldsym.strsig of Strictness.S xs -> tail xs _ -> [] -- how to detect strictness of result value? diff --git a/frege/compiler/passes/Easy.fr b/frege/compiler/passes/Easy.fr index 425e36af..6e084e7a 100644 --- a/frege/compiler/passes/Easy.fr +++ b/frege/compiler/passes/Easy.fr @@ -3,7 +3,6 @@ module frege.compiler.passes.Easy where -- generated by Splitter import frege.Prelude hiding(<+>) import frege.data.TreeMap as TM(TreeMap, TreeSet, lookup, insert, keys, values, each, fromKeys, including, contains, union) -import frege.compiler.common.Lens (view) import frege.compiler.enums.Flags import frege.compiler.enums.Literals import frege.compiler.enums.CaseKind @@ -129,7 +128,7 @@ checkDepth (SymMeth.L (vsym@SymL {pos, alias, name = MName inst base})) = do return () checkDepth bad = do g <- getST - E.fatal (view SymMeth.pos bad) (text(nicer bad g ++ " must not occur in instances.")) + E.fatal bad.pos (text(nicer bad g ++ " must not occur in instances.")) depthSym (vsym@SymV {pos}) diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index 15517bdd..b28a3b5a 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -6,7 +6,7 @@ import frege.data.TreeMap as TM(TreeMap, TreeSet, lookup, insert, keys, value import frege.data.List as DL(uniq, sort, partitioned, elemBy) import frege.data.Bits(BitSet, BitSet.member, BitSet.union bitunion, BitSet.intersection, BitSet.difference) import frege.data.Graph(stronglyConnectedComponents tsort) -import frege.compiler.common.Lens (set, view) +import frege.compiler.common.Lens (set) import frege.compiler.enums.Flags import frege.compiler.enums.TokenID(VARID) import frege.compiler.enums.RFlag @@ -473,7 +473,7 @@ strictName sids nm = do E.logmsg TRACES v.pos (text ("strictness for " ++ v.name.nice g ++ " is " ++ show (S s) ++ " ignoring " - ++ joined ", " (map (flip nice g . view SymVal.name) syms))) + ++ joined ", " (map (flip nice g . _.name) syms))) changeSym $ SymbolT.V v.{expr = Just (return x), strsig = S s, state = StrictChecked} stio syms SymV {expr = Just x} | ari >= 0 = do @@ -549,8 +549,8 @@ strictReturn notLazy sids x = strictness sids x where let mine = if x.{env?} then map QName.uid x.env else if x.{pat?} then map Pattern.uid (patVars x.pat) else [] - my = filter ((`elem` mine) . view SymVal.sid) - them = filter ((`notElem` mine) . view SymVal.sid) + my = filter ((`elem` mine) . _.sid) + them = filter ((`notElem` mine) . _.sid) case x of Vbl {name=Local{}} -> do v <- fmap SymVal.V $ U.findV x.name @@ -575,7 +575,7 @@ strictReturn notLazy sids x = strictness sids x where (filter ((`notElem` sids) • QName.uid) env) (ex, syms) <- strictness sids ex let strictSyms = my syms - sSsids = map (view SymVal.sid) strictSyms + sSsids = map (_.sid) strictSyms upper = [ sres | (loc, sres) <- zip env results, QName.uid loc `elem` sSsids ] result = fold uni (them syms) upper @@ -620,10 +620,10 @@ strictReturn notLazy sids x = strictness sids x where E.fatal (getpos x) (text ("no strictness rule, turn on -xs -xr " ++ show (getpos x))) stio (x, []) where - names g = show . map (flip QName.nice g . view SymVal.name) - inter as = filter (\b -> elemBy (using $ view SymVal.sid) b as) + names g = show . map (flip QName.nice g . _.name) + inter as = filter (\b -> elemBy (using _.sid) b as) uni :: [SymVal Global] -> [SymVal Global] -> [SymVal Global] - uni as bs = as ++ [ b | b <- bs, not (elemBy (using $ view SymVal.sid) b as)] + uni as bs = as ++ [ b | b <- bs, not (elemBy (using _.sid) b as)] maxss (S s1) (S s2) = S (zipWith maxss s1 s2) maxss U s = s maxss s _ = s @@ -641,8 +641,8 @@ strictReturn notLazy sids x = strictness sids x where mark :: SymVal Global -> StG () mark sym = do g <- getST - E.logmsg TRACES (view SymVal.pos sym) (text (nice (view SymVal.name sym) g ++ " marked as strict")) - when (view SymVal.strsig sym == U) do changeSym $ SymVal.toSymbol $ set SymVal.strsig (S[]) sym + E.logmsg TRACES sym.pos (text (nice sym.name g ++ " marked as strict")) + when (sym.strsig == U) do changeSym $ SymVal.toSymbol $ set SymVal._strsig (S[]) sym -- strictness for case alternative, same as in lambda strictAlt (alt@CAlt {pat,ex}) = do (lam, syms) <- strictness sids (Lam {pat,ex,typ=Nothing}) @@ -680,7 +680,7 @@ strictReturn notLazy sids x = strictness sids x where Con {name} -> fmap SymVal.D $ U.findD name Vbl {name} -> fmap SymVal.V $ U.findV name _ -> E.fatal (getpos f) (text ("Can't handle " ++ nice f g ++ " applications")) - let fsym | Local {} <- view SymVal.name v = [v] + let fsym | Local {} <- v.name = [v] | otherwise = [] mkAll = do fapp <- mapSt (strictness sids) (map fst app) diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index ad62e759..7bdd1220 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -44,7 +44,7 @@ import frege.Prelude hiding(<+>, break) import Data.TreeMap as TM(insert, lookup, values, keys, TreeMap, each, contains) import Data.List as DL(find, unique, sortBy, groupBy) -import frege.compiler.common.Lens (preview, set, view) +import frege.compiler.common.Lens (preview, set) import Compiler.enums.Flags as Compilerflags(TRACE5, isOn, flagClr, flagSet, NODOCWARNINGS) import Compiler.enums.TokenID @@ -255,7 +255,7 @@ transFunDcl env fname (d@FunDcl {positions}) = do not (classMember aname g), Just osym <- SymVal.fromSymbol =<< g.findit name, -- make sure there is no precedence conflict - symv.op == view SymVal.op osym || symv.op == defaultInfix || view SymVal.op osym == defaultInfix, + symv.op == osym.op || symv.op == defaultInfix || osym.op == defaultInfix, -- no loops, please! name != symv.name = do let alias = SymL{sid=symv.sid, @@ -264,13 +264,13 @@ transFunDcl env fname (d@FunDcl {positions}) = do name=symv.name, alias=name} -- - when (view SymVal.op osym != symv.op && symv.op != defaultInfix) do - when (view SymVal.op osym != defaultInfix) do + when (osym.op != symv.op && symv.op != defaultInfix) do + when (osym.op != defaultInfix) do E.warn symv.pos (msgdoc ("This changes associativity/precedence for " - ++ nicer (view SymVal.name osym) g + ++ nicer osym.name g ++ " to the one given for " ++ nicer symv.name g)) - changeSym $ SymVal.toSymbol $ set SymVal.op symv.op osym + changeSym $ SymVal.toSymbol $ set SymVal._op symv.op osym changeSym $ SymbolT.L alias othr -> changeSym $ SymbolT.V symv.{expr = Just (return x)} | otherwise = E.fatal pos (text ("expected function, found " ++ sym.nice g)) @@ -1103,10 +1103,10 @@ ordInfix fname (orig@Infx{name, left, right}) bindright = return Infx{name, left, right} -- a $ x+1 == a $ (x+1) case (SymVal.fromSymbol =<< g.findit op1, SymVal.fromSymbol =<< g.findit op2) of (Just sym1, Just sym2) -> - if prec (view SymVal.op sym1) > prec (view SymVal.op sym2) then bindleft - else if prec (view SymVal.op sym1) < prec (view SymVal.op sym2) then bindright + if prec sym1.op > prec sym2.op then bindleft + else if prec sym1.op < prec sym2.op then bindright else -- equal precedence - case (assoc (view SymVal.op sym1), assoc (view SymVal.op sym2)) of + case (assoc sym1.op, assoc sym2.op) of ("left", "left") -> bindleft ("right", "right") -> bindright (left, right) -> do diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index 46dbcf9c..f1d568b6 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -102,30 +102,49 @@ data SymVal global fromSymbol (SymbolT.V s) = Just (V s) fromSymbol _ = Nothing - -- name :: Lens' (SymVal g) QName - name :: Functor f => (QName -> f QName) -> SymVal g -> f (SymVal g) - name f (D s) = (\name -> D s.{name}) <$> f s.name - name f (V s) = (\name -> V s.{name}) <$> f s.name - -- op :: Lens' (SymVal g) TokenID - op :: Functor f => (TokenID -> f TokenID) -> SymVal g -> f (SymVal g) - op f (D s) = (\op -> D s.{op}) <$> f s.op - op f (V s) = (\op -> V s.{op}) <$> f s.op - -- pos :: Lens' (SymVal g) Position - pos :: Functor f => (Position -> f Position) -> SymVal g -> f (SymVal g) - pos f (D s) = (\pos -> D s.{pos}) <$> f s.pos - pos f (V s) = (\pos -> V s.{pos}) <$> f s.pos - -- sid :: Lens' (SymVal g) Int - sid :: Functor f => (Int -> f Int) -> SymVal g -> f (SymVal g) - sid f (D s) = (\sid -> D s.{sid}) <$> f s.sid - sid f (V s) = (\sid -> V s.{sid}) <$> f s.sid - -- strsig :: Lens' (SymVal g) Strictness - strsig :: Functor f => (Strictness -> f Strictness) -> SymVal g -> f (SymVal g) - strsig f (D s) = (\strsig -> D s.{strsig}) <$> f s.strsig - strsig f (V s) = (\strsig -> V s.{strsig}) <$> f s.strsig - -- typ :: Lens' (SymVal g) Sigma - typ :: Functor f => (Sigma -> f Sigma) -> SymVal g -> f (SymVal g) - typ f (D s) = (\typ -> D s.{typ}) <$> f s.typ - typ f (V s) = (\typ -> V s.{typ}) <$> f s.typ + name :: SymVal g -> QName + name (D s) = s.name + name (V s) = s.name + op :: SymVal g -> TokenID + op (D s) = s.op + op (V s) = s.op + pos :: SymVal g -> Position + pos (D s) = s.pos + pos (V s) = s.pos + sid :: SymVal g -> Int + sid (D s) = s.sid + sid (V s) = s.sid + strsig :: SymVal g -> Strictness + strsig (D s) = s.strsig + strsig (V s) = s.strsig + typ :: SymVal g -> Sigma + typ (D s) = s.typ + typ (V s) = s.typ + + -- _name :: Lens' (SymVal g) QName + _name :: Functor f => (QName -> f QName) -> SymVal g -> f (SymVal g) + _name f (D s) = (\name -> D s.{name}) <$> f s.name + _name f (V s) = (\name -> V s.{name}) <$> f s.name + -- _op :: Lens' (SymVal g) TokenID + _op :: Functor f => (TokenID -> f TokenID) -> SymVal g -> f (SymVal g) + _op f (D s) = (\op -> D s.{op}) <$> f s.op + _op f (V s) = (\op -> V s.{op}) <$> f s.op + -- _pos :: Lens' (SymVal g) Position + _pos :: Functor f => (Position -> f Position) -> SymVal g -> f (SymVal g) + _pos f (D s) = (\pos -> D s.{pos}) <$> f s.pos + _pos f (V s) = (\pos -> V s.{pos}) <$> f s.pos + -- _sid :: Lens' (SymVal g) Int + _sid :: Functor f => (Int -> f Int) -> SymVal g -> f (SymVal g) + _sid f (D s) = (\sid -> D s.{sid}) <$> f s.sid + _sid f (V s) = (\sid -> V s.{sid}) <$> f s.sid + -- _strsig :: Lens' (SymVal g) Strictness + _strsig :: Functor f => (Strictness -> f Strictness) -> SymVal g -> f (SymVal g) + _strsig f (D s) = (\strsig -> D s.{strsig}) <$> f s.strsig + _strsig f (V s) = (\strsig -> V s.{strsig}) <$> f s.strsig + -- _typ :: Lens' (SymVal g) Sigma + _typ :: Functor f => (Sigma -> f Sigma) -> SymVal g -> f (SymVal g) + _typ f (D s) = (\typ -> D s.{typ}) <$> f s.typ + _typ f (V s) = (\typ -> V s.{typ}) <$> f s.typ --- the type of 'SymI.env' --- method of a class @@ -143,14 +162,21 @@ data SymMeth global fromSymbol (SymbolT.V s) = Just (V s) fromSymbol _ = Nothing - -- name :: Lens' (SymMeth g) QName - name :: Functor f => (QName -> f QName) -> SymMeth g -> f (SymMeth g) - name f (L s) = (\name -> L s.{name}) <$> f s.name - name f (V s) = (\name -> V s.{name}) <$> f s.name - -- pos :: Lens' (SymMeth g) Position - pos :: Functor f => (Position -> f Position) -> SymMeth g -> f (SymMeth g) - pos f (L s) = (\pos -> L s.{pos}) <$> f s.pos - pos f (V s) = (\pos -> V s.{pos}) <$> f s.pos + name :: SymMeth g -> QName + name (L s) = s.name + name (V s) = s.name + pos :: SymMeth g -> Position + pos (L s) = s.pos + pos (V s) = s.pos + + -- _name :: Lens' (SymMeth g) QName + _name :: Functor f => (QName -> f QName) -> SymMeth g -> f (SymMeth g) + _name f (L s) = (\name -> L s.{name}) <$> f s.name + _name f (V s) = (\name -> V s.{name}) <$> f s.name + -- _pos :: Lens' (SymMeth g) Position + _pos :: Functor f => (Position -> f Position) -> SymMeth g -> f (SymMeth g) + _pos f (L s) = (\pos -> L s.{pos}) <$> f s.pos + _pos f (V s) = (\pos -> V s.{pos}) <$> f s.pos -- _L :: Traversal' (SymMeth g) (SymL g) _L :: Applicative f => (SymL g -> f (SymL g)) -> SymMeth g -> f (SymMeth g) diff --git a/frege/tools/doc/Utilities.fr b/frege/tools/doc/Utilities.fr index d27ebfb3..3a54a62e 100644 --- a/frege/tools/doc/Utilities.fr +++ b/frege/tools/doc/Utilities.fr @@ -47,8 +47,6 @@ import Data.TreeMap as TM(TreeMap, keys, values, each, insert) import Data.List as DL(sortBy, groupBy, intersperse) import Java.Net(URI) -import frege.compiler.common.Lens (preview, view) - import Compiler.enums.Flags as Compilerflags(SPECIAL, isOn, USEUNICODE) import Compiler.enums.Visibility(Public) import Compiler.enums.TokenID @@ -209,7 +207,7 @@ docSym g (SymbolT.C SymC{name,tau,doc,supers,insts,meth}) = (code title, content :- text " " :- Label name (text name.base) :- text " " :- dTau g tau - members = sortBy (comparing $ view SymMeth.name) (values meth) + members = sortBy (comparing _.name) (values meth) ki (tname, iname) = Ref iname (text (nice tname g)) content = [ p | d <- [docit g doc, if null insts then [] @@ -226,7 +224,7 @@ docSym g (SymbolT.I SymI{pos, name, doc, clas, typ=ForAll _ rho, meth}) = (code :- dTau g (TApp TCon{pos, name=clas} (TH.tauRho rho).tau) -- tref clas g :- text " " -- dRho g rho [] - members = sortBy (comparing $ view SymMeth.name) (values meth) + members = sortBy (comparing _.name) (values meth) content = [ p | d <- [docit g doc, if null members then [] else [h3 (text "Member Functions"), From 2709dab3f767b8aa80284b66e9fd2688355b06aa Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 31 Oct 2019 00:43:59 +0900 Subject: [PATCH 84/95] Change the type of allClasses to StG [SymC Global] A redundant pattern match was removed. --- frege/compiler/Classes.fr | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index ec414d37..b3eb7f54 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -82,8 +82,8 @@ post = stio true {-- * look through list of 'Symbol's and note name and direct superclasses for each class -} -classDeps :: [Symbol] -> Global -> [(QName, [QName])] -classDeps syms g = [ (c.name, c.supers) | SymbolT.C c <- syms ] +classDeps :: [SymC Global] -> Global -> [(QName, [QName])] +classDeps syms g = [ (c.name, c.supers) | c <- syms ] --- will loop on mutually recursive classes superclasses (SymbolT.C SymC{supers}) g = (uniq . sort) (supers ++ @@ -95,10 +95,10 @@ superclasses _ _ = [] -- error will be diagnosed later {-- * collect all known classes -} -allClasses :: StG [Symbol] +allClasses :: StG [SymC Global] allClasses = do g <- getST - stio [ c | env <- values g.packages, c@(SymbolT.C _) <- values env ] + stio [ c | env <- values g.packages, SymbolT.C c <- values env ] {-- * handle classes @@ -156,7 +156,7 @@ passC = do symc <- U.findC symc.name changeSym $ SymbolT.C symc.{tau <- Tau.{kind = newkind}} -- update class var symc <- U.findC symc.name - foreach symc.supers (supercheck $ SymbolT.C symc) + foreach symc.supers (supercheck symc) foreach (values symc.meth) (methodcheck symc) nothing -> E.fatal Position.null (text ("lost class " ++ QName.nice qcls g)) superKind symc ka (SymbolT.C supb) = do @@ -326,7 +326,7 @@ passC = do g <- getST E.fatal sym2.pos (text ("checkanno (" ++ sym1.nice g ++ ") (" ++ sym2.nice g ++ ")")) - supercheck :: Symbol -> QName -> StG () + supercheck :: SymC Global -> QName -> StG () supercheck symc qn = do g <- getST case g.find qn of From d39551c7aaa3da289a9b238159f03a567aaba0e4 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 31 Oct 2019 10:15:37 +0900 Subject: [PATCH 85/95] Remove Utilities.symVD Unused partial function The new type SymVal and its member fromSymbol serves the same purpose. --- frege/compiler/Typecheck.fr | 2 +- frege/compiler/Utilities.fr | 6 ------ 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index 4ababf3a..d755f0c0 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -106,7 +106,7 @@ import Compiler.classes.Nice import Compiler.instances.Nicer import Lib.PP(text, msgdoc, nest, stack, <>, , <+/>, <+>) -import frege.compiler.Utilities as U(findC, findD, findV, findVD, symVD, freeTVars, freeTVnames, +import frege.compiler.Utilities as U(findC, findD, findV, findVD, freeTVars, freeTVnames, mapEx, foldEx, arity) import frege.compiler.Kinds as K() diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index ca1bed08..b433bdde 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -933,12 +933,6 @@ ourGlobalFuns mtree ex = foldEx true collect empty ex where collect acc _ = stio (Left acc) -symVD f g sym = case sym of - SymbolT.V _ -> f sym - SymbolT.D _ -> g sym - other -> Prelude.error (sym.name.base ++ " is neither SymV nor SymD") - - {-- * [usage] @fundep expr@ * [returns] a list of our 'QName's that are directly mentioned in _ex_ From a501df7d872c3b09e36310b32b1dc429a4388ba8 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 31 Oct 2019 10:22:12 +0900 Subject: [PATCH 86/95] Modify Desugar.updVis not to throw an error On invalid data constructor, 'updVis' behaves as 'id' instead of an error, just like 'over' in lens does. --- frege/compiler/common/Desugar.fr | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/frege/compiler/common/Desugar.fr b/frege/compiler/common/Desugar.fr index 4b560f52..96f85425 100644 --- a/frege/compiler/common/Desugar.fr +++ b/frege/compiler/common/Desugar.fr @@ -161,9 +161,9 @@ opSname t = case t.qual of change the visibility of a definition -} updVis :: Visibility -> DefinitionS -> DefinitionS -updVis v (DefinitionS.Imp _) = error "ImpDcl doesn't have a visibility" -updVis v (DefinitionS.Fix _) = error "FixDcl doesn't have a visibility" -updVis v (DefinitionS.Doc _) = error "DocDcl doesn't have a visibility" +updVis _ (d@DefinitionS.Imp _) = d +updVis _ (d@DefinitionS.Fix _) = d +updVis _ (d@DefinitionS.Doc _) = d updVis v (DefinitionS.Typ d) = DefinitionS.Typ $ d.{vis = v} updVis v (DefinitionS.Cla d) = DefinitionS.Cla $ d.{vis = v} updVis v (DefinitionS.Ins d) = DefinitionS.Ins $ d.{vis = v} @@ -173,7 +173,7 @@ updVis v (DefinitionS.Nat d) = DefinitionS.Nat $ d.{vis = v} updVis v (DefinitionS.Fun d) = DefinitionS.Fun $ d.{vis = v} updVis v (DefinitionS.Dat d) = DefinitionS.Dat $ d.{vis = v} updVis v (DefinitionS.Jav d) = DefinitionS.Jav $ d.{vis = v} -updVis v (DefinitionS.Mod d) = error "ModDcl doesn't have a visibility" +updVis _ (d@DefinitionS.Mod _) = d {-- set the visibility of a constructor to 'Private' From cfa58ac8ffb383e7534834979a16dcbe740aeeb6 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 31 Oct 2019 11:07:07 +0900 Subject: [PATCH 87/95] Change unAlias.aliases to return [SymA Global] --- frege/compiler/common/UnAlias.fr | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/frege/compiler/common/UnAlias.fr b/frege/compiler/common/UnAlias.fr index f28e69e2..c0c1eeb9 100644 --- a/frege/compiler/common/UnAlias.fr +++ b/frege/compiler/common/UnAlias.fr @@ -71,7 +71,7 @@ unAlias g tau _ -> tau where - aliased (tau1@TApp a b) (SymbolT.A SymA{pos,name,typ,vars}) = case rho of + aliased (tau1@TApp a b) (SymA{pos,name,typ,vars}) = case rho of -- the expansion of the type alias must be more than a tvar RhoTau [] tau2 | not (isTvApp tau2) -> case unify empty tau2 tau1 of Just subst -> Just (substTau env aApp) @@ -86,7 +86,7 @@ unAlias g tau aliased _ _ = Nothing - aliases = [ sym | any <- values g.thisTab, sym@(SymbolT.A _) <- g.follow any ] + aliases = [ sym | any <- values g.thisTab, SymbolT.A sym <- g.follow any ] -- substTau env (TFun a b) = TFun (substTau env a) (substTau env b) From 1ac6dad82f252e5290928bdd856779a65d794510 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 31 Oct 2019 11:11:39 +0900 Subject: [PATCH 88/95] Change isHigherKindedClass to take SymC --- frege/compiler/gen/java/Common.fr | 5 ++--- frege/compiler/gen/java/InstanceCode.fr | 4 ++-- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/frege/compiler/gen/java/Common.fr b/frege/compiler/gen/java/Common.fr index 3b6fd357..fa6602fb 100644 --- a/frege/compiler/gen/java/Common.fr +++ b/frege/compiler/gen/java/Common.fr @@ -833,11 +833,10 @@ isArrayClass :: SymC g -> Bool isArrayClass SymC{name} = isArrayClassName name --- check if a type class is higher kinded -isHigherKindedClass :: SymbolT a -> Bool -isHigherKindedClass (SymbolT.C SymC{tau}) = case tau.kind of +isHigherKindedClass :: SymC g -> Bool +isHigherKindedClass (SymC{tau}) = case tau.kind of KApp{} → true other → false -isHigherKindedClass other = false {-- The (abstract) instance functions for some class members need a diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index 65e989b5..901f0e87 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -297,7 +297,7 @@ instanceCode (SymbolT.I sym) = do -- instance definition let k = kArity csym.tau.kind kindJT = (("frege.run."++) . show . _.jname . rawType $ Kinded k []) jt = head etype.gargs - implementationRestriction = not special && isHigherKindedClass (SymbolT.C csym) && not (implementsKinded g k jt) + implementationRestriction = not special && isHigherKindedClass csym && not (implementsKinded g k jt) when (implementationRestriction) do case jt of Nativ{typ} | not (subTypeOf g typ kindJT) = E.error sym.pos ( @@ -322,7 +322,7 @@ instanceCode (SymbolT.I sym) = do -- instance definition <+> text "re-arranging type arguments." text "Also, if this was a newtype, it'll probably help to change it to data." ) - when (isHigherKindedClass (SymbolT.C csym)) do + when (isHigherKindedClass csym) do E.logmsg TRACEG sym.pos (text "instanceCode" <+> text (csym.name.nicer g) <+> text jt.show) instFuns <- mapM (instFun csym sym) (if implementationRestriction then [] else methods) From 389b78916c14fcab16d208c99146268f2004baa1 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 31 Oct 2019 11:16:37 +0900 Subject: [PATCH 89/95] Change DataCode.subDecls to take SymT --- frege/compiler/gen/java/DataCode.fr | 22 ++++++++-------------- 1 file changed, 8 insertions(+), 14 deletions(-) diff --git a/frege/compiler/gen/java/DataCode.fr b/frege/compiler/gen/java/DataCode.fr index 7d36679e..d3c4a3f7 100644 --- a/frege/compiler/gen/java/DataCode.fr +++ b/frege/compiler/gen/java/DataCode.fr @@ -33,7 +33,7 @@ dataCode (SymbolT.T (sym@SymT{enum = true})) = do g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for enum " ++ nicer sym g)) - sub <- subDecls (SymbolT.T sym) + sub <- subDecls sym let result = JClass{attr = attrTop, name = (javaName g sym.name).base, @@ -58,7 +58,7 @@ dataCode (SymbolT.T (sym@SymT{product = true, newt = true})) = do g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for newtype " ++ nicer sym g)) - sub <- subDecls (SymbolT.T sym) + sub <- subDecls sym let result = JClass{attr = attrs [JAbstract, JPublic, JStatic], name = (javaName g sym.name).base, gvars = [], @@ -80,7 +80,7 @@ dataCode (SymbolT.T (sym@SymT{ product = true })) = do E.logmsg TRACEG sym.pos (text ("dataCode for product " ++ nicer sym g)) con <- conDecls $ head [ con | SymbolT.D con <- values sym.env ] - sub <- subDecls (SymbolT.T sym) + sub <- subDecls sym let jtype = rhoJT g sym.typ.rho kindeds = map (asKinded jtype) [1..kArity sym.kind] @@ -135,7 +135,7 @@ dataCode (SymbolT.T (sym@SymT{ nativ = Nothing, product = false, newt = false }) -- constructors let csyms = [ con | SymbolT.D con <- values sym.env ] - sub <- subDecls (SymbolT.T sym) + sub <- subDecls sym cons <- mapM conDecls csyms let jtype = rhoJT g sym.typ.rho @@ -181,7 +181,7 @@ dataCode (SymbolT.T (sym@SymT{ nativ = Just _ })) = do g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer sym g)) - sub <- subDecls (SymbolT.T sym) + sub <- subDecls sym -- lazyDefs <- lazyDeclarations vals let result @@ -331,15 +331,9 @@ asThunkMethod t = atomMethod "asThunk" (inThunk t) "null" Generate the code for everything in a namespace of a type that is not a constructor. --} -subDecls ∷ Symbol → StG [JDecl] -subDecls (SymbolT.T sym) = do +subDecls :: SymT Global -> StG [JDecl] +subDecls sym = do g ← getST E.logmsg TRACEG sym.pos (text ("subDecls for " ++ nicer sym g)) let subdefs = mapMaybe SymMeth.fromSymbol (values sym.env) -- no constructors - concat <$> mapM (varCode emptyTree) subdefs -subDecls sym = do - g ← getST - E.fatal sym.pos ( - text "subDecls: argument is " - <+> text (nice sym g) - ) \ No newline at end of file + concat <$> mapM (varCode emptyTree) subdefs \ No newline at end of file From 49e0ca1a649d08d784e6fd64d8b9c2ee8a925c76 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 31 Oct 2019 11:32:55 +0900 Subject: [PATCH 90/95] Add instance Ord for SymVal and SymMeth --- frege/compiler/types/Symbols.fr | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/frege/compiler/types/Symbols.fr b/frege/compiler/types/Symbols.fr index f1d568b6..844e1e36 100644 --- a/frege/compiler/types/Symbols.fr +++ b/frege/compiler/types/Symbols.fr @@ -429,6 +429,18 @@ instance Ord (SymA g) where sym1 != sym2 = SymbolT.A sym1 != SymbolT.A sym2 hashCode = hashCode . SymbolT.A +instance Ord (SymVal g) where + sym1 <=> sym2 = sym1.toSymbol <=> sym2.toSymbol + sym1 == sym2 = sym1.toSymbol == sym2.toSymbol + sym1 != sym2 = sym1.toSymbol != sym2.toSymbol + hashCode = hashCode . _.toSymbol + +instance Ord (SymMeth g) where + sym1 <=> sym2 = sym1.toSymbol <=> sym2.toSymbol + sym1 == sym2 = sym1.toSymbol == sym2.toSymbol + sym1 != sym2 = sym1.toSymbol != sym2.toSymbol + hashCode = hashCode . _.toSymbol + --- Symbols ordered by the 'Symbol.sid' field, which is a unique number. --- This allows us to have sets of symbols. instance Ord (SymbolT g) where From 8ec97a24b3d5a05e187deff14b7de42abd10ee64 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 31 Oct 2019 11:49:05 +0900 Subject: [PATCH 91/95] Change symInfo to take SymVal An error case in symInfo was eliminated. Related functions were altered to reflect this change. Most notably Global.GenSt.symi8 now have (SymVal Global) instead of Symbol as keys. A new error message was added to lowerKindSpecialClasses. It didn't make sense to pass SymL to lowerKindAbstractFun because it would eventually put into symi8 but never referenced because symInfo were never called with SymL. --- frege/compiler/gen/java/Common.fr | 9 ++++----- frege/compiler/gen/java/DataCode.fr | 2 +- frege/compiler/gen/java/InstanceCode.fr | 14 ++++++++------ frege/compiler/gen/java/MethodCall.fr | 4 ++-- frege/compiler/gen/java/VarCode.fr | 10 +++++----- frege/compiler/types/Global.fr | 2 +- 6 files changed, 21 insertions(+), 20 deletions(-) diff --git a/frege/compiler/gen/java/Common.fr b/frege/compiler/gen/java/Common.fr index fa6602fb..58a0ddf0 100644 --- a/frege/compiler/gen/java/Common.fr +++ b/frege/compiler/gen/java/Common.fr @@ -25,7 +25,7 @@ import Compiler.types.Global(StIO, StG, Symbol, SymInfo8, Global(), GenSt(), isReserved) import Compiler.enums.TokenID(QUALIFIER) -import Compiler.types.Symbols(SymD, SymT, SymV, SymC, SymI, SymMeth, SymbolT) +import Compiler.types.Symbols(SymD, SymT, SymV, SymC, SymI, SymMeth, SymVal, SymbolT) import Compiler.types.JNames(JName, memberOf) import Compiler.types.QNames(TName) import Compiler.types.Packs(pPreludeIO, pPreludeArrays, pPreludeList) @@ -582,7 +582,7 @@ sComment = (JLocal • JComment) {-- Get 'SymInfo' for given symbol from cache or produce it and put it there -} -symInfo :: Symbol -> StG SymInfo8 +symInfo :: SymVal Global -> StG SymInfo8 symInfo sym = do g <- getST case g.gen.symi8.lookup sym of @@ -595,7 +595,7 @@ symInfo sym = do ) return si other -> case sym of - SymbolT.V symv -> do + SymVal.V symv -> do let (r, as) = U.returnTypeN symv.depth symv.typ.rho rjt = lambdaType (rhoJT g r) sjts = zipWith (argType g) (strictFuns symv.strsig) as @@ -612,7 +612,7 @@ symInfo sym = do text "arg :: " <+> text (nicer s g) <+> text " @@ " <+> text (show j) )) si.argSigs si.argJTs return si - SymbolT.D symd -> do + SymVal.D symd -> do let (r, as) = U.returnType symd.typ.rho rjt = lambdaType (tauJT g r) sjts = zipWith (argType g) (map (bool strict lazy . ConField.strict) symd.flds) as @@ -620,7 +620,6 @@ symInfo sym = do si = SI8{returnJT = rjt, argJTs = fjts, argSigs = as, retSig = ForAll [] (RhoTau [] r)} changeST Global.{gen <- GenSt.{symi8 <- insert sym si}} return si - _ -> error ("symInfo for " ++ nicer sym g ++ ", allowed only for functions/variables") --- map a strictness signature to a (infinite) list of 'Bool' boolS :: Strictness -> [Bool] diff --git a/frege/compiler/gen/java/DataCode.fr b/frege/compiler/gen/java/DataCode.fr index d3c4a3f7..82dfd7e0 100644 --- a/frege/compiler/gen/java/DataCode.fr +++ b/frege/compiler/gen/java/DataCode.fr @@ -264,7 +264,7 @@ coerceDecl gvars jt = -} conDecls :: SymD Global -> StG [JDecl] conDecls sym = do - si <- symInfo (SymbolT.D sym) + si <- symInfo (SymVal.D sym) g <- getST let arity = length sym.flds decls = [comment, constr, constructorMethod sym.cid] diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index 901f0e87..04a4e399 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -114,20 +114,22 @@ lowerKindSpecialClasses = do g ← getST let items = [ (c,v) | n <- specialClassNames , c <- findSpecialClass g n - , v <- Map.values c.meth ] - mapM_ (\(c, v) -> lowerKindAbstractFun c v.toSymbol) items + , v <- notLink g <$> Map.values c.meth ] + mapM_ (\(c, v) -> lowerKindAbstractFun c v) items return g where findSpecialClass g n = case g.findit (TName pPreludeList n) of Just (SymbolT.C symc) -> Just symc Just _ -> error $ "lowerKindSpecialClasses: non-class name in specialClassNames: " ++ show n Nothing -> Nothing + notLink _ (SymMeth.V s) = SymVal.V s + notLink g (SymMeth.L s) = error $ "lowerKindSpecialClasses: SymL in special class: " ++ s.nice g -lowerKindAbstractFun :: SymC Global -> Symbol -> StG () +lowerKindAbstractFun :: SymC Global -> SymVal Global -> StG () lowerKindAbstractFun symc sym = do let classvar = symc.tau.var - newsym = over SymbolT._typ (lowerKind classvar) sym - changeSym newsym + newsym = over SymVal._typ (lowerKind classvar) sym + changeSym newsym.toSymbol -- force syminfo to regenerate information, if already present changeST Global.{gen ← _.{symi8 ← delete sym}} return () @@ -148,7 +150,7 @@ lowerKindAbstractFun symc sym = do abstractFun :: SymC Global -> SymV Global -> StG [JDecl] abstractFun symc sym = do g <- getST - si <- symInfo (SymbolT.V sym) + si <- symInfo (SymVal.V sym) let !classCtx = Ctx {pos=symc.pos, cname = symc.name, tau = symc.tau } diff --git a/frege/compiler/gen/java/MethodCall.fr b/frege/compiler/gen/java/MethodCall.fr index 87f0c40b..b427b368 100644 --- a/frege/compiler/gen/java/MethodCall.fr +++ b/frege/compiler/gen/java/MethodCall.fr @@ -106,7 +106,7 @@ nativeCall g (symv@SymV{nativ = Just item, gargs}) subst aexs = newBind g bsig ( let evalStG :: Global -> StG a -> a evalStG g st = fst $ st.run g x = do g <- getST - si <- symInfo $ SymbolT.V symv + si <- symInfo $ SymVal.V symv -- this part is an unfinished, prototyped one. See PR #361, #363 let unsafePartialView :: Getting (First a) s a -> s -> a unsafePartialView l = unJust . preview l @@ -117,7 +117,7 @@ nativeCall g (symv@SymV{nativ = Just item, gargs}) subst aexs = newBind g bsig ( nativrsym <- g.findit $ si.retSig.rho.tau.name nativsym <- TreeMap.lookup fldnm (unsafePartialView _Just nativrsym.env') nativnm <- unsafePartialView SymbolT._nativ nativsym - let nativsi = evalStG g $ symInfo nativsym + let nativsi = evalStG g $ symInfo $ unsafePartialView SymbolT._Val nativsym fldsym <- TreeMap.lookup fldnm (unsafePartialView _Just irsym.env') pure $ wrapIRMethod g (head args) (head si.argJTs) nativsi nativnm fldnm (unsafePartialView Symbol._Val fldsym) in JNewClass jrty [] (evalStG g x) diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index 7f17941d..6e246506 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -23,7 +23,7 @@ import Compiler.instances.Nicer(nicerctx, nicectx) import Compiler.types.Global(Symbol, StG, Global(), getST, changeST, uniqid) -import Compiler.types.Symbols(SymV, SymL, SymD, SymT, SymC, SymI, SymMeth, SymbolT) +import Compiler.types.Symbols(SymV, SymL, SymD, SymT, SymC, SymI, SymMeth, SymVal, SymbolT) import Compiler.types.Expression(Expr, ExprT, CAlt, CAltT, flatx) import Compiler.types.Patterns(Pattern, PatternT) import Compiler.types.Positions(Positioned) @@ -71,7 +71,7 @@ varCode _ (SymMeth.L SymL{sid, pos, vis, name, alias}) = do varCode binds (SymMeth.V symv) = do g <- getST E.logmsg TRACEG symv.pos (text ("varCode for " ++ nicer symv g)) - si <- symInfo $ SymbolT.V symv + si <- symInfo $ SymVal.V symv case symv of SymV{expr = Just _} | null si.argSigs = cafCode symv binds -- nust be CAF @@ -84,7 +84,7 @@ varCode binds (SymMeth.V symv) = do <+> text (nicer symv.typ.rho g) <> text ", depth=" <> anno symv.depth <> text ", rstate=" <> (text • show) symv.rkind) - si <- symInfo (SymbolT.V symv) + si <- symInfo $ SymVal.V symv return (comment : methCode g symv si) | otherwise = return [] -- there is no code for overloads where @@ -110,7 +110,7 @@ topFun (sym@SymV {expr = Just dx}) binds = do <> text ", rstate=" <> (text • show) sym.rkind) -- x ← dx -- get expression - si ← symInfo (SymbolT.V sym) + si <- symInfo $ SymVal.V sym let !arity = length si.argSigs when (arity != sym.depth) do @@ -191,7 +191,7 @@ localFun (sym@SymV {expr = Just dx}) binds = do <> text ", depth=" <> anno sym.depth <> text ", rstate=" <> (text • show) sym.rkind) - si ← symInfo $ SymbolT.V sym + si <- symInfo $ SymVal.V sym let !arity = length si.argSigs when (arity != sym.depth) do diff --git a/frege/compiler/types/Global.fr b/frege/compiler/types/Global.fr index 39debb6d..9dd13913 100644 --- a/frege/compiler/types/Global.fr +++ b/frege/compiler/types/Global.fr @@ -120,7 +120,7 @@ data GenSt = !Gen { xTree :: TreeMap ExprA Int --- expr table expSym :: TreeMap QName Int --- keeps track of expression numbers used for exported symbols consts :: TreeMap (Literalkind, String, Bool) Int --- constant table - symi8 :: TreeMap Symbol SymInfo8 --- cached information about symbols return/arg types + symi8 :: TreeMap (SymVal Global) SymInfo8 --- cached information about symbols return/arg types jimport :: TreeMap String Pack --- packages we have a java import statement for, by base name main :: String --- bare name of the top level class, set in GenMeta } From 1952d83b13bab8c01351ca1c47116fc40ad98ceb Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 31 Oct 2019 12:03:11 +0900 Subject: [PATCH 92/95] Remove redundant parameter from match.matchEnum --- frege/compiler/gen/java/Match.fr | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/frege/compiler/gen/java/Match.fr b/frege/compiler/gen/java/Match.fr index b97301e6..aacde2e4 100644 --- a/frege/compiler/gen/java/Match.fr +++ b/frege/compiler/gen/java/Match.fr @@ -165,7 +165,7 @@ match assert (pat@PCon {pos,qname,pats}) bind cont binds = do -- g <- getST symd <- U.findD qname -- forall a.a -> List a -> List a symt <- U.findT symd.name.tynm -- forall a.List a - if symt.enum then matchEnum (SymbolT.D symd) (SymbolT.T symt) + if symt.enum then matchEnum symd else if symt.product then if symt.newt then matchNew symd symt @@ -178,15 +178,13 @@ match assert (pat@PCon {pos,qname,pats}) bind cont binds = do other → kbnd comment g = sComment ("match " ++ nice pat g ++ " with " ++ show bind) - -- matchNewt :: Symbol -> Symbol -> StG (Binding, [JStmt]) - -- matchNewt symd symt = match (head pats) bind cont binds - matchEnum :: Symbol -> Symbol -> StG (Binding, [JStmt]) - matchEnum symd symt = do + matchEnum :: SymD Global -> StG (Binding, [JStmt]) + matchEnum symd = do g <- getST let sbnd = unKindedStrict g bind -- (bind, code1) <- realize "$" sbnd body <- cont binds - let comp = JBin sbnd.jex "==" (JX.staticMember (symJavaName g symd)) + let comp = JBin sbnd.jex "==" (JX.staticMember (symJavaName g $ SymbolT.D symd)) ifc = if assert then JAssert comp : body else [JCond "if" comp body] stio (sbnd, comment g : ifc) From d39d4097c894d4fd7ab819b49b5c670cdd2a21c5 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 31 Oct 2019 12:44:48 +0900 Subject: [PATCH 93/95] Restrict parameter type of dataCode, classCode and instanceCode --- frege/compiler/gen/java/DataCode.fr | 12 ++++++------ frege/compiler/gen/java/InstanceCode.fr | 15 ++++----------- frege/compiler/passes/GenCode.fr | 6 +++--- 3 files changed, 13 insertions(+), 20 deletions(-) diff --git a/frege/compiler/gen/java/DataCode.fr b/frege/compiler/gen/java/DataCode.fr index 82dfd7e0..25560d2c 100644 --- a/frege/compiler/gen/java/DataCode.fr +++ b/frege/compiler/gen/java/DataCode.fr @@ -20,7 +20,7 @@ import Compiler.gen.java.Bindings(assign) import Compiler.enums.Flags(TRACEG) --- Generate code for @data@ definitions -dataCode :: Symbol → StG [JDecl] +dataCode :: SymT Global -> StG [JDecl] {-- Enumerations (that is, data types where no constructor has any fields) @@ -29,7 +29,7 @@ dataCode :: Symbol → StG [JDecl] names of the constructors and the function definitions found in the where clause of the @data@. -} -dataCode (SymbolT.T (sym@SymT{enum = true})) = do +dataCode (sym@SymT{enum = true}) = do g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for enum " ++ nicer sym g)) @@ -54,7 +54,7 @@ dataCode (SymbolT.T (sym@SymT{enum = true})) = do We generate an @abstract static class@ as a namespace for the definitions in the where clause, if any. Otherwise, nothing is generated. -} -dataCode (SymbolT.T (sym@SymT{product = true, newt = true})) = do +dataCode (sym@SymT{product = true, newt = true}) = do g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for newtype " ++ nicer sym g)) @@ -75,7 +75,7 @@ dataCode (SymbolT.T (sym@SymT{product = true, newt = true})) = do In this case, also the appropriate Kinded instances will be generated. -} -dataCode (SymbolT.T (sym@SymT{ product = true })) = do +dataCode (sym@SymT{ product = true }) = do g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for product " ++ nicer sym g)) @@ -128,7 +128,7 @@ dataCode (SymbolT.T (sym@SymT{ product = true })) = do > // sub definitions > } -} -dataCode (SymbolT.T (sym@SymT{ nativ = Nothing, product = false, newt = false })) = do +dataCode (sym@SymT{ nativ = Nothing, product = false, newt = false }) = do g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer sym g)) @@ -177,7 +177,7 @@ dataCode (SymbolT.T (sym@SymT{ nativ = Nothing, product = false, newt = false }) Native data types are mapped to a class that acts as namespace for the subdefinitions, if any. -} -dataCode (SymbolT.T (sym@SymT{ nativ = Just _ })) = do -- nativ +dataCode (sym@SymT{ nativ = Just _ }) = do -- nativ g ← getST E.logmsg TRACEG sym.pos (text ("dataCode for native " ++ nicer sym g)) diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index 04a4e399..bfb48938 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -76,8 +76,8 @@ import Compiler.gen.java.VarCode(varCode, compiling, genExpression, genExpr) the class operations, like (++) and 'length'. -} -classCode :: Symbol -> StG [JDecl] -classCode (SymbolT.C (sym@SymC{tau = TVar{var,kind}})) = do -- type class +classCode :: SymC Global -> StG [JDecl] +classCode (sym@SymC{tau = TVar{var,kind}}) = do -- type class g <- getST let vals = map symMethAsSymV $ values sym.meth special = isSpecialClass sym @@ -204,7 +204,8 @@ abstractFun symc sym = do > public Eq_Maybe(CEq ctx) { ... } > } -} -instanceCode (SymbolT.I sym) = do -- instance definition +instanceCode :: SymI Global -> StG [JDecl] +instanceCode sym = do -- instance definition g <- getST csym <- findC sym.clas @@ -342,14 +343,6 @@ instanceCode (SymbolT.I sym) = do -- instance definition ++ concat instImpls} pure [JComment (nice sym g ++ " :: " ++ nice sym.typ g), result] ---- If given something else than a type class this is a fatal compiler error -instanceCode sym = do - g ← getST - E.fatal sym.pos ( - text "instanceCode: argument is " - <+> text (nice sym g) - ) - instFun :: SymC Global -> SymI Global -> QName -> StG JDecl instFun symc symi mname = do g <- getST diff --git a/frege/compiler/passes/GenCode.fr b/frege/compiler/passes/GenCode.fr index f434ebb3..60f1643a 100644 --- a/frege/compiler/passes/GenCode.fr +++ b/frege/compiler/passes/GenCode.fr @@ -153,17 +153,17 @@ pass = do g ← getSTT -- classes - let classes = [ s | s@(SymbolT.C _) <- values g.thisTab ] + let classes = [ s | SymbolT.C s <- values g.thisTab ] liftStG (concat <$> mapM classCode classes) >>= liftIO . ppDecls g -- instances - let instances = [ s | s@(SymbolT.I _) <- values g.thisTab ] + let instances = [ s | SymbolT.I s <- values g.thisTab ] liftStG (concat <$> mapM instanceCode instances) >>= liftIO . ppDecls g -- data definitions - let datas = [ s | s@(SymbolT.T _) <- values g.thisTab ] + let datas = [ s | SymbolT.T s <- values g.thisTab ] liftStG (concat <$> mapM dataCode datas) >>= liftIO . ppDecls g From b2fec3f04c9b334ca8676d109cae21e86bf49b91 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 31 Oct 2019 13:07:07 +0900 Subject: [PATCH 94/95] Change transDatDcl.newtCheck to take SymT --- frege/compiler/passes/Transdef.fr | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index 7bdd1220..132fc0b2 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -471,10 +471,10 @@ transDatDcl env fname (d@DatDcl {pos}) = do foreach d.ctrs (transCon sym.typ (MName tname)) foreach d.defs (transdef [] (MName tname)) polymorphicFields tname - U.findT tname >>= newtCheck . SymbolT.T + U.findT tname >>= newtCheck other -> do E.fatal pos (text ("Cannot happen, data " ++ tname.nice g ++ " missing")) where - newtCheck (SymbolT.T (symt@SymT{newt=true})) -- this is declared as newtype + newtCheck (symt@SymT{newt=true}) -- this is declared as newtype | [con] ← [ c | SymbolT.D c <- values symt.env ], -- so it has 1 constructor [fld] ← [ f | f@Field {typ} <- con.flds ], -- with 1 field ForAll _ RhoTau{tau} ← fld.typ, -- which has some type tau @@ -489,7 +489,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do changeSym $ SymbolT.T symt.{newt=false} -- make it data changeSym $ SymbolT.D con.{flds <- map _.{strict=true}} -- with strict field pure () - newtCheck other = pure () + newtCheck _ = pure () polymorphicFields tname = do symt <- U.findT tname let cons = [ c | SymbolT.D c <- values symt.env ] From 11bdb3f7a853c895526d6b44124149925242ba74 Mon Sep 17 00:00:00 2001 From: matil019 Date: Thu, 31 Oct 2019 10:19:03 +0900 Subject: [PATCH 95/95] Clean up the code Removed unwanted diffs introduced by a series of modifications --- frege/compiler/Classes.fr | 6 +++--- frege/compiler/Kinds.fr | 4 ++-- frege/compiler/Typecheck.fr | 24 ++++++++++++------------ frege/compiler/Utilities.fr | 8 ++++---- frege/compiler/common/Lens.fr | 18 ++++++++---------- frege/compiler/common/SymbolTable.fr | 16 ++++++++-------- frege/compiler/common/Trans.fr | 2 +- frege/compiler/gen/java/Common.fr | 2 +- frege/compiler/gen/java/DataCode.fr | 2 +- frege/compiler/gen/java/InstanceCode.fr | 2 +- frege/compiler/gen/java/Match.fr | 6 +++--- frege/compiler/gen/java/MethodCall.fr | 6 +++--- frege/compiler/gen/java/VarCode.fr | 10 +++++----- frege/compiler/passes/Easy.fr | 6 +++--- frege/compiler/passes/Imp.fr | 12 ++++++------ frege/compiler/passes/Instances.fr | 5 ++--- frege/compiler/passes/LetUnroll.fr | 2 +- frege/compiler/passes/Strict.fr | 4 ++-- frege/compiler/passes/Transdef.fr | 9 ++++----- frege/compiler/tc/Methods.fr | 4 ++-- frege/compiler/tc/Util.fr | 2 +- frege/ide/Utilities.fr | 6 +++--- frege/tools/Doc.fr | 6 +++--- 23 files changed, 79 insertions(+), 83 deletions(-) diff --git a/frege/compiler/Classes.fr b/frege/compiler/Classes.fr index b3eb7f54..08ca2b91 100644 --- a/frege/compiler/Classes.fr +++ b/frege/compiler/Classes.fr @@ -243,7 +243,7 @@ passC = do [osym] | Just (SymbolT.V ali) <- g.findit msym.alias, ali.anno, -- symc.name == same, - Just (SymbolT.C ssym) <- g.findit osym.name.tynm = do + Just (SymbolT.C ssym) <- g.findit osym.name.tynm -> do sig <- mkanno symc msym.pos osym ssym T.subsCheck (SymbolT.V ali) ali.typ sig | otherwise = E.error pos (msgdoc (nicer msym g @@ -402,7 +402,7 @@ instForClass alien c iname = do csyms <- mapSt U.findC (csym.name:csym.supers) isym <- U.findI isym.name - when (not alien || g.our isym.name) do tcInstMethods csyms isym + when (not alien || g.our isym.name) do tcInstMethods csyms isym Nothing -> E.fatal isym.pos (text ("instForClass: bad instance type " ++ isym.typ.nice g)) {-- @@ -579,7 +579,7 @@ funForCIT cname iname tname (mname@MName _ base) = do linkq (MName tname base) $ SymbolT.V ivsym changeSym $ SymbolT.V ivsym.{op=msym.op} -- copy op | otherwise = E.error isym.pos (msgdoc ("implementation missing for " ++ ivsym.nice g)) - Just (SymMeth.L SymL{pos=ipos, name=member, alias}) -- imported instance with links to type methods? + Just (SymMeth.L SymL{pos=ipos, name=member, alias}) -- imported instance with links to type methods? | not (g.our iname), alias.{tynm?}, alias.tynm == tname = stio () | otherwise = case g.findit alias of Just symv' | SymbolT.V symv <- symv', not symv.anno && not (maybe false (const true) symv.nativ) = do diff --git a/frege/compiler/Kinds.fr b/frege/compiler/Kinds.fr index eaa1c34c..cd2daff5 100644 --- a/frege/compiler/Kinds.fr +++ b/frege/compiler/Kinds.fr @@ -89,10 +89,10 @@ kiTypeSym names sym = do g <- getST E.logmsg TRACEK sym.pos (text ("kind check for " ++ nice sym g)) -- kind check all constructor sigmas - let cons = [ con | SymbolT.D con <- values $ sym.env ] + let cons = [ con | SymbolT.D con <- values sym.env ] foreach cons (kiConSym names) g ← getST - sym <- U.findT $ sym.name + sym <- U.findT sym.name let kflat (KApp k ks) = k : kflat ks kflat ks = [ks] typ = ForAll (zipWith Tau.{kind=} (sym.typ.bound) (kflat sym.kind)) sym.typ.rho diff --git a/frege/compiler/Typecheck.fr b/frege/compiler/Typecheck.fr index d755f0c0..2e9b0ccf 100644 --- a/frege/compiler/Typecheck.fr +++ b/frege/compiler/Typecheck.fr @@ -425,7 +425,7 @@ resolveConstraints sym x <- x >>= resolveHas cxs <- collectConstrs x rho <- simplify symv.pos typ.rho.{context=cxs} - >>= simplify symv.pos -- remove duplicates + >>= simplify symv.pos -- remove duplicates -- Drop the contexts that contain a rigid tvar that is not occurring in the type itself. -- Those stem from typechecking applications of higher rank functions where -- there is a constraint in an inner forall. @@ -436,7 +436,7 @@ resolveConstraints sym ctxmetas = map (ctxTvs g) rho.context let filteredCtx = [ ctx | (metas, ctx) <- zip ctxmetas rho.context, all (`elem` rhometas) (filter (not . MetaTv.isFlexi) metas)] - changeSym $ SymbolT.V symv.{typ <- Sigma.{rho <- rmtrailing . Rho.{context=filteredCtx}}, + changeSym $ SymbolT.V symv.{typ <- Sigma.{rho <- rmtrailing . Rho.{context=filteredCtx}}, expr = Just (return x)} | otherwise = return () where @@ -942,9 +942,9 @@ tcRho' (x@Vbl {name}) ety = do case sym of SymVal.D _ -> tcRho' Con{pos=x.pos, name=x.name, typ=x.typ} ety SymVal.V symv -> case isPSigma symv.typ of - false -> if symv.state != Typechecked + false -> if symv.state != Typechecked then do - sig ← fst <$> K.kiSigma [] [] symv.typ + sig <- fst <$> K.kiSigma [] [] symv.typ changeSym $ SymbolT.V symv.{typ=sig} rho <- instantiate sig instRho x rho ety @@ -1110,10 +1110,10 @@ tcRho' (x@Mem {ex,member}) ety = do TCon{name=tcon}:_ <- ntau.flat, Just (SymbolT.T SymT{nativ=Just s}) <- g.findit tcon, (SymbolT.V SymV{name=m}):_ <- - [ h - | sup <- s:U.supersOfNativ s g - , q <- U.typesOfNativ sup g - , h <- g.findit (MName q member.value) ] + [ h + | sup <- s:U.supersOfNativ s g + , q <- U.typesOfNativ sup g + , h <- g.findit (MName q member.value) ] = do changeST Global.{sub <- SubSt.{ idKind <- insert (KeyTk original) (Right m)}} @@ -1427,7 +1427,7 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do return (Right v) ms:_ -> case sortBy (comparing arityV) ms of -- compare b arity to find -- the one that fits - cs -> case filter ((arityV (head cs) ==) . arityV) cs of -- remove the ones that don't + cs -> case filter ((arityV (head cs) ==) . arityV) cs of -- remove the ones that don't some -> do when (length some > 1) do E.warn v.pos (text "overloaded `" <> text (nicer v g) @@ -1465,15 +1465,15 @@ rHas flagerr (v@Vbl{pos, name, typ}) | not name.isLocal = do overloads :: Global -> SymV Global -> [SymV Global] overloads g sym = case sym of SymV{over=[]} -> [sym] - SymV{name = MName{tynm, base}, over=over@(_:_)} + SymV{name = MName{tynm, base}, over=(_:_)} | Just (SymbolT.T SymT{nativ = Just this}) <- g.findit tynm, - ov <- [ sy | m <- over, SymbolT.V sy <- g.findit m ], + ov <- [ sy | m <- sym.over, SymbolT.V sy <- g.findit m ], syms <- [ sy | s <- U.supersOfNativ this g, q <- U.typesOfNativ s g, SymbolT.V h <- g.findit (MName q base), sy <- overloads g h] = ov++syms - SymV{over} -> [ sy | m <- over, SymbolT.V sy <- g.findit m ] + SymV{} -> [ sy | m <- sym.over, SymbolT.V sy <- g.findit m ] arityV = arity . SymVal.V rHas _ x = pure (Left x) diff --git a/frege/compiler/Utilities.fr b/frege/compiler/Utilities.fr index b433bdde..8cc74843 100644 --- a/frege/compiler/Utilities.fr +++ b/frege/compiler/Utilities.fr @@ -232,7 +232,7 @@ freeTauTVars _ collected _ = collected --- return a list of constructors in this environment ordered by constructor number envConstructors :: Symtab -> [SymD Global] -envConstructors env = sortBy (comparing SymD.cid) [ syd | SymbolT.D syd <- values env ] +envConstructors env = sortBy (comparing _.cid) [ syd | SymbolT.D syd <- values env ] --- provide a new Position for a Pattern @@ -702,7 +702,7 @@ foldEx b f a ex = do Let {env,ex} | b = do syms <- mapSt findV env - xs <- sequence [ x | SymV{expr=Just x} <- syms ] + xs <- sequence [ x | SymV {expr=Just x} <- syms ] a <- foldSt (foldEx b f) a xs foldEx b f a ex | otherwise = foldEx b f a ex @@ -749,7 +749,7 @@ mapEx b f x = do Let {env,ex,typ} | b = do syms <- mapSt findV env - let xs = [ sy | sy@SymV{expr=Just _} <- syms ] + let xs = [ sy | sy@SymV {expr=Just _} <- syms ] foreach xs mapsub ex <- mapEx b f ex stio (Let {env,ex,typ}) @@ -942,7 +942,7 @@ fundep (SymV{name, expr=Just dx}) = do g <- getST x <- dx deptree <- ourGlobalFuns empty x - let dep = [ name | sy <- keys deptree, let name = sy.name, g.our name ] + let dep = [ sy.name | sy <- keys deptree, g.our sy.name ] stio (name, dep) fundep (SymV{name, expr=Nothing}) = stio (name, []) diff --git a/frege/compiler/common/Lens.fr b/frege/compiler/common/Lens.fr index 6dc78100..63ce09a9 100644 --- a/frege/compiler/common/Lens.fr +++ b/frege/compiler/common/Lens.fr @@ -1,8 +1,10 @@ ---- The code here is taken and modified from Haskell's "lens" packages. ---- ---- lens: ---- Copyright 2012-2016 Edward Kmett ---- License BSD-2-Clause +{-- + The code here is taken and modified from Haskell's "lens" packages. + + lens: + Copyright 2012-2016 Edward Kmett + License BSD-2-Clause + -} module frege.compiler.common.Lens where import frege.data.Monoid (First) @@ -12,6 +14,7 @@ import frege.data.wrapper.Identity (Identity) -- note: currently the compiler fails to infer the correct kinds of @f@ -- when incrementally compiling, so you have to write type annotations without the aliases +-- see GutHub issue #383 type ASetter s t a b = (a -> Identity b) -> s -> Identity t type ASetter' s a = ASetter s s a a @@ -73,8 +76,3 @@ _Just _ Nothing = pure Nothing _Nothing :: Traversal' (Maybe a) () _Nothing _ Nothing = pure Nothing _Nothing _ (Just x) = pure (Just x) - ---- warning: this function is partial --- TODO eliminate the uses of these functions -unsafePartialView :: Getting (First a) s a -> s -> a -unsafePartialView l s = unJust $ preview l s diff --git a/frege/compiler/common/SymbolTable.fr b/frege/compiler/common/SymbolTable.fr index 2b613170..90764cc3 100644 --- a/frege/compiler/common/SymbolTable.fr +++ b/frege/compiler/common/SymbolTable.fr @@ -53,11 +53,11 @@ private insertSym toSymbol tab key value = case tab.lookupS key of let on = (toSymbol old).nice g qn = (toSymbol value).nice g case toSymbol value of - SymbolT.V SymV{pos, name} -> E.error pos (msgdoc("duplicate function or pattern binding for `" + SymbolT.V SymV{pos, name} -> E.error pos $ msgdoc $ "duplicate function or pattern binding for `" ++ name.nice g ++ "`, already bound on line " - ++ show (toSymbol old).pos)) - _ -> E.error (toSymbol value).pos (msgdoc("redefinition of " ++ on ++ " with " ++ qn - ++ " introduced on line " ++ show (toSymbol old).pos)) + ++ show (toSymbol old).pos + _ -> E.error (toSymbol value).pos $ msgdoc $ "redefinition of " ++ on ++ " with " ++ qn + ++ " introduced on line " ++ show (toSymbol old).pos stio (tab.insertS key value) @@ -72,9 +72,9 @@ private updateSym toSymbol tab key value = case tab.lookupS key of stio (tab.insert key value) {-- - - Assume a Symbol is SymV because it's name is Local - - - - It is caller's responsibility to ensure that. + Assume a Symbol is SymV because it's name is Local + + It is caller's responsibility to ensure that. -} private toSymVBecauseLocal :: Symbol -> SymV Global private toSymVBecauseLocal (SymbolT.V symv) = symv @@ -112,7 +112,7 @@ enter sym = case sym of let symv = toSymVBecauseLocal sym case g.find sym.name of Nothing - | uid == symv.sid-> do + | uid == symv.sid -> do E.logmsg TRACE3 symv.pos (text("enterLocal: " ++ show symv.sid ++ " " ++ sym.nice g ++ " :: " ++ symv.typ.nice g ++ diff --git a/frege/compiler/common/Trans.fr b/frege/compiler/common/Trans.fr index e231a111..c3da289e 100644 --- a/frege/compiler/common/Trans.fr +++ b/frege/compiler/common/Trans.fr @@ -290,7 +290,7 @@ patsComplete g ps Just (SymbolT.T (SymT {env})) -> U.envConstructors env _ -> [] cons _ = [] - mkCon (SymD{name,flds}) = PCon {pos=Position.null, qname=name, + mkCon (SymD {name,flds}) = PCon {pos=Position.null, qname=name, pats = map (const pany) flds} group :: [Pattern] -> [(QName, [[Pattern]])] group [] = [] diff --git a/frege/compiler/gen/java/Common.fr b/frege/compiler/gen/java/Common.fr index 58a0ddf0..362c58ca 100644 --- a/frege/compiler/gen/java/Common.fr +++ b/frege/compiler/gen/java/Common.fr @@ -608,7 +608,7 @@ symInfo sym = do text "si.retSig " <+> text (nice si.retSig g) -- text " ) - zipWithM_ (\s j → E.logmsg TRACEG symv.pos ( + zipWithM_ (\s j -> E.logmsg TRACEG symv.pos ( text "arg :: " <+> text (nicer s g) <+> text " @@ " <+> text (show j) )) si.argSigs si.argJTs return si diff --git a/frege/compiler/gen/java/DataCode.fr b/frege/compiler/gen/java/DataCode.fr index 25560d2c..56b32619 100644 --- a/frege/compiler/gen/java/DataCode.fr +++ b/frege/compiler/gen/java/DataCode.fr @@ -336,4 +336,4 @@ subDecls sym = do g ← getST E.logmsg TRACEG sym.pos (text ("subDecls for " ++ nicer sym g)) let subdefs = mapMaybe SymMeth.fromSymbol (values sym.env) -- no constructors - concat <$> mapM (varCode emptyTree) subdefs \ No newline at end of file + concat <$> mapM (varCode emptyTree) subdefs diff --git a/frege/compiler/gen/java/InstanceCode.fr b/frege/compiler/gen/java/InstanceCode.fr index bfb48938..818ad7ba 100644 --- a/frege/compiler/gen/java/InstanceCode.fr +++ b/frege/compiler/gen/java/InstanceCode.fr @@ -382,7 +382,7 @@ instFun symc symi mname = do text (nicer cmem.name g) <+> text " :: " <+> text (nicer cmem.typ g) ) let otvs = filter ((`elem` symi.typ.vars) . Tau.var) cmem.typ.tvars - orep = filter (`notElem` cmem.typ.vars) (allBinders g) + orep = filter (`notElem` (cmem.typ.vars)) (allBinders g) substBound :: TreeMap String Tau -> [Tau] -> [Tau] substBound subst xs = map (\tv -> maybe tv _.{kind=tv.kind} (lookup tv.var subst)) xs subst1 = Map.fromList [ (tv.var, tv.{var=s}) | (s,tv) ← zip orep otvs] diff --git a/frege/compiler/gen/java/Match.fr b/frege/compiler/gen/java/Match.fr index aacde2e4..19029510 100644 --- a/frege/compiler/gen/java/Match.fr +++ b/frege/compiler/gen/java/Match.fr @@ -168,9 +168,9 @@ match assert (pat@PCon {pos,qname,pats}) bind cont binds = do if symt.enum then matchEnum symd else if symt.product then if symt.newt - then matchNew symd symt - else matchProd symd symt -- pat bind cont binds - else matchVariant symd symt -- pat bind cont binds + then matchNew symd symt + else matchProd symd symt -- pat bind cont binds + else matchVariant symd symt -- pat bind cont binds where unKindedStrict g lbnd = case strictBind g lbnd of kbnd -> case kbnd.jtype of diff --git a/frege/compiler/gen/java/MethodCall.fr b/frege/compiler/gen/java/MethodCall.fr index b427b368..a7fdf316 100644 --- a/frege/compiler/gen/java/MethodCall.fr +++ b/frege/compiler/gen/java/MethodCall.fr @@ -157,7 +157,7 @@ nativeCall g sym subst aexs = error ("nativeCall: no function " ++ ", " ++ nicer sym g) wrapCode :: Global -> (JExpr -> JStmt) -> Tau -> SymV Global -> TreeMap String Tau -> [JExpr] -> [JStmt] -wrapCode g jreturn rtau (sym@SymV{nativ = Just item, throwing}) subst aexs +wrapCode g jreturn rtau (sym@SymV {nativ = Just item, throwing}) subst aexs | Just (stau, atau) <- unST rtau = let sjt = tauJT g stau -- type #1 for parameterization of ST s a ajt = tauJT g atau -- return type of the ST action @@ -223,7 +223,7 @@ wrapCode g jreturn rtau (sym@SymV{nativ = Just item, throwing}) subst aexs catch rty = case tauJT g rty of Nativ{typ, gargs} -> "catch (" ++ typ ++ " ex)" other -> error ("bad exception type " ++ show other) -wrapCode _ _ _ _ _ _ = error "wrapCode: non-native SymV" +wrapCode _ _ _ _ _ _ = error "wrapCode - no native function" {-- @@ -236,7 +236,7 @@ methCode g (symv@SymV {nativ = Just item}) si = [ JComment ("the following type variables are probably wildcards: " ++ joined ", " (map _.var wildr)), JComment item] ++ (if arity then defs - else if wrapped g symv || niKind item != NIStatic + else if wrapped g symv || niKind item != NIStatic then [member] else []) where diff --git a/frege/compiler/gen/java/VarCode.fr b/frege/compiler/gen/java/VarCode.fr index 6e246506..053a6725 100644 --- a/frege/compiler/gen/java/VarCode.fr +++ b/frege/compiler/gen/java/VarCode.fr @@ -61,7 +61,7 @@ import Compiler.gen.java.Instantiation(instPatternBound, resolveConstraint, envC import Compiler.gen.java.PrettyJava(lambda7, thunkMarker) varCode :: TreeMap Int Binding -> SymMeth Global -> StG [JDecl] -varCode _ (SymMeth.L SymL{sid, pos, vis, name, alias}) = do +varCode _ (SymMeth.L SymL{sid, pos, vis, name, alias}) = do g ← getST pure [JComment ("alias " ++ name.base @@ -79,7 +79,7 @@ varCode binds (SymMeth.V symv) = do SymV{nativ = Just _, over} | null over = do g ← getST - E.logmsg TRACEG symv.pos (text "native var:" + E.logmsg TRACEG symv.pos (text "native var:" <+> text (nice symv.name g) <+> text "∷" <+> text (nicer symv.typ.rho g) <> text ", depth=" <> anno symv.depth @@ -88,7 +88,7 @@ varCode binds (SymMeth.V symv) = do return (comment : methCode g symv si) | otherwise = return [] -- there is no code for overloads where - comment = JComment (nicer symv g) + comment = JComment (nicer symv g) _ -> error ("varCode: bad SymV " ++ nicer symv g) --- Generate code for a function with arguments @@ -895,7 +895,7 @@ genLetEnvs jret rm before inclass after ex binds = do genLetClass binds [] = pure (binds, []) genLetClass binds syms = do g <- getST - forM syms (changeSym . SymbolT.V . _.{rkind ← (BitSet.`unionE` RMethod)}) + forM syms (changeSym . SymbolT.V . _.{rkind <- (BitSet.`unionE` RMethod)}) -- refresh the symbols syms <- mapM U.findV (map _.name syms) u <- uniqid @@ -916,7 +916,7 @@ genLetEnvs jret rm before inclass after ex binds = do -- stmts <- genStmts jret rm ex letbinds pure (letbinds, [JLocal letcl, JLocal var]) - mkbind :: Global -> (String -> JX) -> TreeMap Int Binding -> SymV Global -> TreeMap Int Binding + mkbind :: Global -> (String -> JX) -> TreeMap Int Binding -> SymV Global -> TreeMap Int Binding mkbind g prefix binds sym = insert sym.sid bind binds where bind = Bind{stype=nicer sym.typ g, diff --git a/frege/compiler/passes/Easy.fr b/frege/compiler/passes/Easy.fr index 6e084e7a..3c1d4a43 100644 --- a/frege/compiler/passes/Easy.fr +++ b/frege/compiler/passes/Easy.fr @@ -102,7 +102,7 @@ easySym (vsym@SymV {pos}) checkDepth :: SymMeth Global -> StG () -checkDepth (SymMeth.V (vsym@SymV {pos, name = MName inst base})) = do +checkDepth (SymMeth.V (vsym@SymV {pos, name = MName inst base})) = do g <- getST cmeth <- classMethodOfInstMethod pos inst base when (cmeth.depth > vsym.depth) do @@ -113,7 +113,7 @@ checkDepth (SymMeth.V (vsym@SymV {pos, name = MName inst base})) = do when (cmeth.depth < vsym.depth) do changeSym $ SymbolT.V vsym.{depth = cmeth.depth} return () -checkDepth (SymMeth.L (vsym@SymL {pos, alias, name = MName inst base})) = do +checkDepth (SymMeth.L (vsym@SymL {pos, alias, name = MName inst base})) = do g <- getST cmeth <- classMethodOfInstMethod pos inst base rmeth <- U.findVD alias @@ -153,7 +153,7 @@ depthSym (vsym@SymV {pos}) g <- getST -- depth < sigmas, eta expand it newx <- etaExpand nx let newd = U.lambdaDepth newx - E.logmsg TRACE9 vsym.pos (text ("eta expanded " + E.logmsg TRACE9 (vsym.pos) (text ("eta expanded " ++ nice vsym.name g ++ "::" ++ nice typ g ++ " to lambda depth " ++ show newd)) E.logmsg TRACE9 vsym.pos (text ("old expr: " ++ nice nx g ++ " :: " diff --git a/frege/compiler/passes/Imp.fr b/frege/compiler/passes/Imp.fr index a915652c..3674cea4 100644 --- a/frege/compiler/passes/Imp.fr +++ b/frege/compiler/passes/Imp.fr @@ -286,8 +286,8 @@ linkHere ns pack (item@Item {publik,name,members,alias=newn}) sym = do let conid = (newn.charAt 0).isUpperCase conidOk | TName _ _ <- sym.name = true - | SymbolT.D _ <- sym = true - | otherwise = false + | SymbolT.D _ <- sym = true + | otherwise = false vis = if publik then Public else Private g <- getST E.logmsg TRACE2 pos (text ("linkHere: " ++ ns ++ "." ++ newn ++ ", vis =" ++ show vis @@ -296,13 +296,13 @@ linkHere ns pack (item@Item {publik,name,members,alias=newn}) sym = do idKind <- insert (KeyTk pos.first) (Right sym.name)}} let !errors = case sym.name of - name@(TName _ b) - | newn == name.base || conid = linkqvp (TName g.thisPack newn) sym vis pos + TName _ b + | newn == sym.name.base || conid = linkqvp (TName g.thisPack newn) sym vis pos | otherwise = do E.error pos (msgdoc ("Alias for " ++ nice sym g ++ " must be a type name, not `" ++ newn ++ "'")) stio () - name - | newn == name.base || conid == conidOk = linkqvp (VName g.thisPack newn) sym vis pos + _ + | newn == sym.name.base || conid == conidOk = linkqvp (VName g.thisPack newn) sym vis pos -- allow variables that link to constructors | SymbolT.D _ <- sym, !conid = linkqvp (VName g.thisPack newn) sym vis pos | otherwise = do diff --git a/frege/compiler/passes/Instances.fr b/frege/compiler/passes/Instances.fr index 1efbd234..bbc90793 100644 --- a/frege/compiler/passes/Instances.fr +++ b/frege/compiler/passes/Instances.fr @@ -39,8 +39,7 @@ import frege.compiler.gen.java.Common(sigmaJT) -} pass () = do g <- getST - -- not sure if including InsDcl here is needed; if ordering doesn't matter, - -- it shouldn't be needed + -- filter sourcedefs to @Either InsDcl DrvDcl@ in a way the ordering is preserved let insdrv = flip mapMaybe g.sub.sourcedefs $ \d -> case d of DefinitionS.Ins ins -> Just $ Left ins @@ -60,7 +59,7 @@ deriveInst (d@DrvDcl{pos}) = do clas <- defaultXName pos (TName pPreludeBase "Eq") d.clas typ <- U.transSigma d.typ case instTSym typ g of - Just (sym@SymT{env}) | ctrs <- U.envConstructors env, + Just (sym@SymT {env}) | ctrs <- U.envConstructors env, not (null ctrs) || inPrelude clas.pack g && clas.base == "ArrayElement" || inPrelude clas.pack g && clas.base == "JavaType" diff --git a/frege/compiler/passes/LetUnroll.fr b/frege/compiler/passes/LetUnroll.fr index 134444dd..e0fd1181 100644 --- a/frege/compiler/passes/LetUnroll.fr +++ b/frege/compiler/passes/LetUnroll.fr @@ -167,7 +167,7 @@ unLet (x@Let {env,ex}) foreach syms (changeSym . SymbolT.V) foreach (map _.name syms) unLetName stio (Left newlet) - xs -> stio (Left x) + _ -> stio (Left x) where pos = getpos x diff --git a/frege/compiler/passes/Strict.fr b/frege/compiler/passes/Strict.fr index b28a3b5a..afb5dcbe 100644 --- a/frege/compiler/passes/Strict.fr +++ b/frege/compiler/passes/Strict.fr @@ -237,8 +237,8 @@ returnKind syms (sym@SymV {expr = Just dx}) = do else do -- let nkind = (xkind.differenceE RAlways).union cm.rkind changeSym $ SymbolT.V sym.{rkind = xkind} - other -> changeSym $ SymbolT.V sym.{rkind = xkind} - other -> changeSym $ SymbolT.V sym.{rkind = xkind} + _ -> changeSym $ SymbolT.V sym.{rkind = xkind} + _ -> changeSym $ SymbolT.V sym.{rkind = xkind} --- assume abstract class functions are tail call safe and return a value returnKind syms (sym@SymV {expr = Nothing, name = MName _ _}) diff --git a/frege/compiler/passes/Transdef.fr b/frege/compiler/passes/Transdef.fr index 132fc0b2..644408e4 100644 --- a/frege/compiler/passes/Transdef.fr +++ b/frege/compiler/passes/Transdef.fr @@ -518,7 +518,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do case find ((meth.name.base ==)•("upd$"++)•unJust•ConField.name) flds of Just cf -> do - E.logmsg TRACE5 meth.pos (text "polymorphic update " + E.logmsg TRACE5 meth.pos (text "polymorphic update " <+> text (nice meth g) <+> text " :: " <+> text (nice cf.typ g)) @@ -611,7 +611,7 @@ transDatDcl env fname (d@DatDcl {pos}) = do sig <- U.validSigma typ >>= kiSigma [] [] >>= pure . fst let additional = filter (`notElem` map _.var bndrs) (map _.var sig.bound) unless (null additional) do - E.error con.pos (text ("type variable(s) " + E.error con.pos (text ("type variable(s) " ++ joined ", " additional ++ " may not appear in fields of " ++ d.name)) changeSym $ SymbolT.D con.{typ=sig}.{flds=nfs . snd . U.returnType $ sig.rho} @@ -678,9 +678,8 @@ transClaDcl env fname (d@ClaDcl {pos}) = do transModDcl :: [QName] -> (String -> QName) -> ModDcl -> StG () transModDcl env fname ModDcl{pos, extending, implementing, code} = do g ← getST - case [m | DefinitionS.Mod m <- g.sub.sourcedefs] of - -- exactly one element - [_] = do + case length [m | DefinitionS.Mod m <- g.sub.sourcedefs] of + 1 = do ext ← case extending of Just t → Just <$> (transTau t >>= starSigma) _ → return Nothing diff --git a/frege/compiler/tc/Methods.fr b/frege/compiler/tc/Methods.fr index 295b998b..9c33e443 100644 --- a/frege/compiler/tc/Methods.fr +++ b/frege/compiler/tc/Methods.fr @@ -264,7 +264,7 @@ sanity (SymbolT.V (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, o ++ " could modify it.")) other = return () Nothing -> case instTauSym tau g of - Just (SymT{nativ = Just nt, pur = pureType}) + Just SymT{nativ = Just nt, pur = pureType} | !pureType = case phantom of Just ph -> E.error (getpos tau) ( text "Non pure native type " @@ -337,7 +337,7 @@ sanity (SymbolT.V (symv@SymV{pos, name, typ, nativ = Just item, pur, throwing, o E.error (getpos tau) (msgdoc ("`Int` expected.")) return () -- already in error, or ok | otherwise = case instTauSym tau g of - Just (SymT{nativ = Just nt, pur = pureType}) + Just SymT{nativ = Just nt, pur = pureType} | !pureType = case phantom of Just ph -> E.error (getpos tau) (msgdoc ( "Non pure native type " ++ nicer tau g diff --git a/frege/compiler/tc/Util.fr b/frege/compiler/tc/Util.fr index 271f9d7a..fa903050 100644 --- a/frege/compiler/tc/Util.fr +++ b/frege/compiler/tc/Util.fr @@ -696,7 +696,7 @@ contexts ex typ = do Let {env,ex} -> do let ectx = exContext g ex syms <- mapSt U.findV env - subexs <- sequence [ ex | SymV{expr = Just ex} <- syms ] + subexs <- sequence [ ex | SymV {expr = Just ex} <- syms ] let rctxss = map (exContext g) subexs let rctxs = [ ctx | ctxs <- rctxss, ctx <- ctxs ] -- take only contexts that have at least 1 flexi tv diff --git a/frege/ide/Utilities.fr b/frege/ide/Utilities.fr index be1c8620..61094d8a 100644 --- a/frege/ide/Utilities.fr +++ b/frege/ide/Utilities.fr @@ -333,7 +333,7 @@ proposeContent !global root !offset !tokens !index = propose traceLn ("rule fundef " ++ value ++ "¦") || true, Just (Right qname) <- Global.resolved global varid, traceLn ("resolved " ++ nicer qname global) || true, - Just (SymbolT.V sym) <- global.findit qname, + Just (SymbolT.V sym) <- global.findit qname, traceLn ("found " ++ sym.nice global) || true, sym.anno, traceLn (sym.nice global ++ " is annotated") || true, isNothing sym.nativ, traceLn (sym.nice global ++ " is not nativ") || true, @@ -493,7 +493,7 @@ proposeContent !global root !offset !tokens !index = propose enclosed it | parens, sym.name.base != ":", -- not list cons - sym.name.base !~ ´^\(´, -- not tuple + sym.name.base !~ ´^\(´, -- not tuple any (isNothing . ConField.name) sym.flds = "(" ++ it ++ ")" | otherwise = it @@ -513,7 +513,7 @@ proposeContent !global root !offset !tokens !index = propose tauProposal tau prop | traceLn ("tauProposal: " ++ nicer tau global) = undefined | tau <- TC.reduced tau global, - Just (SymT{env, nativ=mbs}) <- instTauSym tau global + Just SymT{env, nativ=mbs} <- instTauSym tau global = case mbs of Just s | ss <- s:U.supersOfNativ s global, -- the supertypes of s (including s) diff --git a/frege/tools/Doc.fr b/frege/tools/Doc.fr index 0a42dee4..b27d1e64 100644 --- a/frege/tools/Doc.fr +++ b/frege/tools/Doc.fr @@ -431,13 +431,13 @@ continueNamespaces fp = do links = sortBy (comparing _.name) [sym | sym@(SymbolT.L SymL{alias}) <- values g.thisTab, g.our alias, other <- g.findit alias, - not (Lens.has SymbolT._D other), -- no constructor aliases + Lens.hasn't SymbolT._D other, -- no constructor aliases noclassmember g other.name] where noclassmember g (MName tname _) = case g.findit tname of Just (SymbolT.C _) -> false other -> true - noclassmember f _ = true + noclassmember _ _ = true allfuns = funs ++ [ s | syms <- [csyms, isyms, dsyms] , sym :: Symbol <- syms @@ -451,7 +451,7 @@ continueNamespaces fp = do docTypes [] = undefined docTypes ss = (code typ, [par $ content ss]) where - typ = dRho g ((head ss).typ).rho (repeat false) + typ = dRho g (head ss).typ.rho (repeat false) content = fold (:-) (text "") . intersperse (text ", ") . map (flip fref g . _.name) -- h3 (text "Imports"), ul Nothing (map docImp (Tree.keyvalues ?S.packs Eq))]