diff --git a/lam4-backend/gf-grammar/Lam4.gf b/lam4-backend/gf-grammar/Lam4.gf index d6ffd78d..02be0d7c 100644 --- a/lam4-backend/gf-grammar/Lam4.gf +++ b/lam4-backend/gf-grammar/Lam4.gf @@ -14,14 +14,25 @@ abstract Lam4 = { Name ; [Name]{0} ; + -- Special values for aggregation + ListOp ; + LExpr ; + [LExpr]{2} ; + + -- (condition, value) + -- in order to flatten nested if-then-elses into if-elif-elif-…-else + IfThen ; + [IfThen]{2} ; fun -- Placeholder, or skip some constructs? EmptyS : S ; - TypeDeclS : TypeDecl -> S ; + TypeDeclS : (id : String) -> TypeDecl -> S ; EvalS, EvalWhetherS, - ExprS : Expr -> S ; - AssignS : Name -> Expr -> S ; + ExprS : (id : String) -> Expr -> S ; + AssignS : (id : String) -> Name -> Expr -> S ; + LetIsTrue : (id : String) -> Name -> Expr -> S ; + AtomicConcept : (id : String) -> Name -> S ; -- Metadata MkMetadata : String -> Metadata ; @@ -38,17 +49,89 @@ abstract Lam4 = { Lit, QuoteVar, Var : Name -> Expr ; - -- | Cons Expr Expr -- list cons - -- | List [Expr] -- construct a list - -- | ListExpr ListOp [Expr] + + -- the following correspond to List and ListExpr in Lam4 AST, + -- named differently because of a bug in GF, + -- see https://github.com/GrammaticalFramework/gf-core/issues/163 + ConjExpr : [Expr] -> Expr ; -- construct a list + + coerceListExpr : Expr -> LExpr ; + ApplyListOp : ListOp -> [LExpr] -> Expr ; + + ListAnd, ListOr : ListOp ; + Unary : UnaryOp -> Expr -> Expr ; + VerboseBinExpr, -- newline + quotes around args BinExpr : BinOp -> Expr -> Expr -> Expr ; + + UnaryMinusExpr : Expr -> Expr ; + Round : (expr, prec : Expr) -> Expr ; + Default : (val, default : Expr) -> Expr ; + IfThenElse : Expr -> Expr -> Expr -> Expr ; + + -- Flatten nested If Then Elses + FirstIfThen : Expr -> Expr -> IfThen ; + MiddleIfThen : Expr -> Expr -> IfThen ; + NilIfThen : Expr -> IfThen ; -- the original IfThenElse + Elif: [IfThen] -> Expr ; + {- + + IF i's `the business's number of past and current clients` is larger than + * 10.0: => the business's client bonus factor is 1.5 + * 4.0 => the business's client bonus factor is 1.35 + * 1.0 => the business's client bonus factor is 1.2 + * ELSE => the business's client bonus factor is 1.0 + + -} + + -- For linearizing functions that have a NLG annotation + FunApp1 : (description : String) -> (arg : Expr) -> Expr ; + FunApp2 : (desc1 : String) -> (arg1 : Expr) -> (desc2 : String) -> (arg2 : Expr) -> Expr ; + + -- For linearizing functions that don't have NLG annotation FunApp : Expr -> [Expr] -> Expr ; -- Record : (Row Expr) -> Expr ; -- record construction + OnlyFieldProject, Project : Expr -> Name -> Expr ; -- record projection Fun : (funname : Name) -> Metadata -> (args : [Name]) -> Expr -> Expr ; -- Function - -- Let : Decl Expr + Sig : [Name] -> [Expr] -> Expr ; -- TODO: what is this? only `Sig [] []` present in royalflush data + + {- TODO: this is used in context like + + LET { foo + , bar + , baz + } + IN { expression that uses definitions + , another expression + , yet another + … } + + as AST it looks like + Let (foo + Let (bar + Let baz ))) + + transform into: + + [all variables] + + [all Exprs] + + and linearize as + -- Definitions --- + foo = … + bar = … + baz = … + + -- Expressions -- + if they are just like + `the business eligibility text` = `the business eligibility text`, + then don't print them. + -} + Let : S -> Expr -> Expr ; + Record : Name -> Expr -> Expr ; -- StatementBlock : (NonEmpty Statement) NormIsInfringed : Name -> Expr ; -- NormIsInfringed NameOfNorm. @@ -56,9 +139,19 @@ abstract Lam4 = { Predicate : (predname : Name) -> Metadata -> (args : [Name]) -> Expr -> Expr ; -- Differs from a function when doing symbolic evaluation. Exact way in which they should differ is WIP. - PredApp : Expr -> [Expr] -> Expr ; + + PredApp : (pred : Expr) -> (args : [Expr]) -> Expr ; + + -- Aggregation of multiple PredApps being applied to the same argument(s). + PredAppMany : BinOp -> (preds : [Expr]) -> (args : [Expr]) -> Expr ; Fold : Expr -> Expr -> Expr -> Expr ; + -- When generating natural language for some file that defines a bunch of stuff like cons, map, filter, + -- apply this function instead to keep it in the AST + -- but skip linearization. + KnownFunction : Name -> Expr ; + + -- Unary and binary operators Not, Floor, @@ -79,24 +172,4 @@ abstract Lam4 = { Ge : BinOp ; -- ^ greater-than-or-equal Eq : BinOp ; -- ^ equality (of Booleans, numbers or atoms) Ne : BinOp ; -- ^ inequality (of Booleans, numbers or atoms) -} - -{- -— -LOTTERY { - — how much can be won from the jackpot - `total jackpot`: Integer, - — whether buying tickets from this lottery is tax deductible - `tax deductible status`: Boolean -} - - -This can be rendered as: - -MkTypeDecl (MkMetadata "a game where you lose money") "Lottery" (ConsRowTypeDecl (MkRowDecl (MkMetadata "how much can be won from the jackpot") "‘total jackpot’") (ConsRowTypeDecl (MkRowDecl (MkMetadata "whether buying tickets from this lottery is tax deductible") "‘tax deductible status’") BaseRowTypeDecl)) - -A/An ‘Lottery’ is . -Each lottery has associated with it information like - * its ‘total jackpot’; i.e., how much can be won from the jackpot - * its ‘tax deductible status’; i.e., whether buying tickets from this lottery is tax deductible --} \ No newline at end of file +} \ No newline at end of file diff --git a/lam4-backend/gf-grammar/Lam4.pgf b/lam4-backend/gf-grammar/Lam4.pgf index 129515e9..891a51b8 100644 Binary files a/lam4-backend/gf-grammar/Lam4.pgf and b/lam4-backend/gf-grammar/Lam4.pgf differ diff --git a/lam4-backend/gf-grammar/Lam4Eng.gf b/lam4-backend/gf-grammar/Lam4Eng.gf index be55e24e..8fa2c70d 100644 --- a/lam4-backend/gf-grammar/Lam4Eng.gf +++ b/lam4-backend/gf-grammar/Lam4Eng.gf @@ -6,31 +6,45 @@ concrete Lam4Eng of Lam4 = open Prelude, Coordination in { Metadata = LinMetadata ; ListExpr = ListX0 ; ListName = ListX0 ; + BinOp = {s : Verbosity => Str} ; + ListLExpr = LinLExpr ; + ListOp = LinListOp ; + param IsEmpty = Empty | NonEmpty ; MyListSize = Zero | One | Many ; + PListOp = PListAnd | PListOr ; + Verbosity = Concise | Verbose ; + + Hilight = Strong | Emph | Underline ; oper - ListX0 : Type = ListX ** {size : MyListSize} ; - baseListX0 : ListX0 = { - s1, s2 = "" ; - size = Zero + -- Keywords + + hilight : Hilight -> Str -> Str ; + hilight emph str = + openTag emph ++ str ++ closeTag emph ; + + openTag : Hilight -> Str = \t -> case t of { + Strong => "" ; + Emph => "" ; + Underling => "" } ; - consListX0 : SS -> ListX0 -> ListX0 = \x,xs -> case xs.size of { - Many => xs ** { - s1 = x.s ++ bindComma ++ xs.s1 - } ; - One => xs ** { - s1 = x.s ; - size = Many - } ; - Zero => xs ** { - s2 = x.s ; - size = One - } - } ; + closeTag : Hilight -> Str = \t -> case t of { + Strong => "" ; + Emph => "" ; + Underling => "" + } ; + + ifKw : Str = hilight Strong "if" ; + thenKw : Str = hilight Strong "then" ; + elseKw : Str = hilight Strong "else" ; + andKw : Str = hilight Strong "and" ; + orKw : Str = hilight Strong "or" ; + allKw : Str = hilight Strong (hilight Emph "all of") ; + anyKw : Str = hilight Strong (hilight Emph "any of") ; LinMetadata : Type = {s : Str ; isEmpty : IsEmpty} ; linRowMd : LinMetadata -> Str = \md -> @@ -48,49 +62,65 @@ concrete Lam4Eng of Lam4 = open Prelude, Coordination in { lin -- Placeholder, or skip some constructs? EmptyS = {s = ""} ; - TypeDeclS td = td ; - ExprS expr = expr ; - EvalS expr = {s = "evaluate" ++ expr.s} ; - EvalWhetherS expr = {s = "evaluate whether" ++ expr.s} ; - AssignS name expr = {s = quote name.s ++ "is assigned the value" ++ quote expr.s} ; + TypeDeclS id td = {s = paragraph id.s td.s} ; + ExprS id expr = {s = paragraph id.s expr.s} ; + EvalS id expr = {s = paragraph id.s ("evaluate" ++ expr.s)} ; + EvalWhetherS id expr = {s = paragraph id.s ("evaluate whether" ++ expr.s)} ; + AssignS id name expr = { + s = paragraph id.s ( + dl (quote name.s ++ hilight Strong "is calculated by") + expr.s + ) + } ; + LetIsTrue id name expr = { + s = paragraph id.s ( + dl (quote name.s ++ ifKw) + expr.s + ) + } ; + AtomicConcept id name = {s = paragraph id.s (name.s ++ "is an atomic concept.")} ; -- Metadata MkMetadata str = str ** {isEmpty = NonEmpty} ; NoMetadata = {s = [] ; isEmpty = Empty} ; -- Type declarations - MkRowTypeDecl md field typ = {s = bullet ++ "its" ++ field.s ++ linType typ ++ linRowMd md} ; - MkRowDecl md field = {s = bullet ++ "its" ++ field.s ++ linRowMd md} ; + MkRowTypeDecl md field typ = {s = "its" ++ field.s ++ linType typ ++ linRowMd md} ; + MkRowDecl md field = {s = "its" ++ field.s ++ linRowMd md} ; -- These funs are automatically generated from cat [RowTypeDecl]{0} ; -- : [RowTypeDecl] BaseRowTypeDecl = {s = [] ; isEmpty = Empty} ; -- : RowTypeDecl -> [RowTypeDecl] -> [RowTypeDecl] - ConsRowTypeDecl t ts = - let sep : Str = case ts.isEmpty of { - Empty => [] ; - NonEmpty => linebreak } ; - in {s = tab ++ t.s ++ sep ++ ts.s ; isEmpty = NonEmpty} ; + ConsRowTypeDecl t ts = { + s = li t.s ++ ts.s ; + isEmpty = NonEmpty + } ; MkTypeDecl md name rtds = { - s = artIndef ++ name.s ++ linTypeDeclMd md ++ "." ++ - case rtds.isEmpty of { - Empty => [] ; - NonEmpty => "Each" ++ name.s ++ - "has associated with it information like" ++ - linebreak ++ rtds.s - } ; + s = artIndef ++ name.s ++ linTypeDeclMd md ++ + case rtds.isEmpty of { + Empty => [] ; + NonEmpty => "Each" ++ name.s ++ + "has associated with it information like" ++ + ul rtds.s + } } ; oper - bullet = "*" ; - -- just ad hoc characters to `tr "°∞" "\t\n"` in shell - tab = "°" ; linebreak = "∞" ; + hr = linebreak ++ "
" ++ linebreak ; quote : Str -> Str ; - quote str = "‘" ++ BIND ++ str ++ BIND ++ "’" ; + quote str = "" ++ BIND ++ str ++ BIND ++ "" ; + quoteSS : SS -> SS ; + quoteSS ss = {s = quote ss.s} ; + + paragraph = overload { + paragraph : Str -> Str = \s -> "

" ++ s ++ "

" ; + paragraph : (id : Str) -> Str -> Str = \i,s -> "

" ++ s ++ "

" + } ; artIndef = pre { "eu" | "Eu" | "uni" | "Uni" => "A" ; @@ -99,6 +129,11 @@ concrete Lam4Eng of Lam4 = open Prelude, Coordination in { _ => "A" } ; + conjXss = overload { + conjXss : ListX0 -> SS = \xs -> ss (conjX "" xs) ; + conjXss : Str -> ListX0 -> SS = \c,xs -> ss (conjX c xs) + } ; + conjX : Str -> ListX0 -> Str = \conj,xs -> case xs.size of { Many => conjunctX (ss conj) xs ; _ => xs.s2 @@ -114,6 +149,41 @@ concrete Lam4Eng of Lam4 = open Prelude, Coordination in { _ => pr ++ conjX "and" xs ++ pst } } ; + -- Bin expr + mkBinExpr : Str -> Str -> {s : Verbosity => Str} ; + mkBinExpr short long = { + s = table { + Concise => hilight Strong short ; + Verbose => long } + } ; + + -- ul = overload { + ul,li : Str -> Str ; + ul str = "" ; + li str = "
  • " ++ str ++ "
    • " ; + + -- } + + dl = overload { + dl : (t,d : Str) -> Str = \t,d -> + "
    " + ++ "
    " ++ t ++ "
    " + ++ "
    " ++ d ++ "
    " + ++ "
    " + ; + dl : Hilight -> (t, d : Str) -> Str = \emph,t,d -> + "
    " + ++ "
    " ++ hilight emph t ++ "
    " + ++ "
    " ++ d ++ "
    " + ++ "
    " + } ; + + + ite : (i,t,e : Str) -> Str ; + ite i t e = + dl ifKw i ++ + (dl thenKw t ++ + dl elseKw e) ; lin @@ -123,28 +193,98 @@ concrete Lam4Eng of Lam4 = open Prelude, Coordination in { QuoteVar name = {s = quote name.s} ; Var name = name ; Lit name = name ; - Unary op expr = cc2 op expr ; - BinExpr op e1 e2 = cc3 e1 op e2 ; + Unary op expr = { + s = dl op.s expr.s + } ; + BinExpr op e1 e2 = { + s = e1.s + ++ op.s ! Concise + ++ e2.s + } ; + + VerboseBinExpr op e1 e2 = { + s = dl "" e1.s + ++ dl (op.s ! Verbose) e2.s + } ; + + Round expr precision = expr ; + -- { -- for being extra verbose + -- s = dl "rounding" expr.s + -- ++ dl "to precision of" (precision.s ++ "decimals") + -- } ; + + Default expr default = { + s = dl ("if" ++ expr.s ++ "is uncertain, then") default.s + ++ dl "else" expr.s + } ; IfThenElse if then else = { - s = "if" ++ if.s ++ linebreak ++ tab - ++ "then" ++ then.s ++ linebreak ++ tab - ++ "else" ++ else.s + s = ite if.s then.s else.s } ; + FirstIfThen i t = { + s = dl "if" i.s + ++ dl "then" t.s + } ; + MiddleIfThen i t = { + s = dl "else if" i.s + ++ dl "then" t.s + } ; + NilIfThen e = { + s = dl "else" e.s + } ; + + BaseIfThen = baseIfThen ; + ConsIfThen = consIfThen ; + Elif its = its ; -- {s = ul its.s} ; + + + -- : (description : String) -> (arg : Expr) -> Expr ; + FunApp1 adding_up entities = { + s = dl adding_up.s entities.s + } ; + + -- : (desc1 : String) -> (arg1 : Expr) -> (desc2 : String) -> (arg2 : Expr) -> Expr ; + FunApp2 desc1 entities desc2 condition = { + s = dl desc1.s entities.s + ++ dl desc2.s condition.s + } ; + + -- If no annotation available, just put together function and arguments in a definition list -- : Expr -> [Expr] -> Expr ; - FunApp f xs = {s = f.s ++ linArgs "of" xs} ; + FunApp f xs = { + s = dl f.s (linArgs "" xs) + } ; -- Record : (Row Expr) -> Expr ; -- record construction -- : Expr -> Name -> Expr ; -- record projection - Project rec field = {s = glue rec.s "'s" ++ field.s} ; + Project rec field = { + s = glue rec.s "'s" ++ + field.s + } ; + + -- don't print out the record, only the field. + -- Whether to choose this or Project should depend on annotations in the Lam4 program. + OnlyFieldProject _rec field = { + s = field.s + } ; -- : Name -> Metadata -> [Name] -> Expr -> Expr ; -- Function Fun funname md args body = { - s = "Function" ++ funname.s ++ ":" ++ linebreak - ++ linArgs "given" args "," - ++ "return" ++ body.s + s = + -- "Function" ++ funname.s ++ ":" ++ linebreak ++ + -- ++ linArgs "given" args ", return" ++ + body.s } ; + + -- : S -> Expr -> Expr ; + Let decl expr = { + s = decl.s ++ hr ++ expr.s + } ; + + -- : Name -> Expr -> Expr ; + Record name field = {s = glue name.s "'s" ++ field.s} ; + Sig parents relations = cc2 (conjXss parents) (conjXss relations) ; -- Let : Decl Expr -- StatementBlock : (NonEmpty Statement) @@ -163,7 +303,16 @@ concrete Lam4Eng of Lam4 = open Prelude, Coordination in { } ; -- : Expr -> [Expr] -> Expr ; - PredApp = FunApp ; + PredApp f xs = { + s = case xs.size of { + One => conjX "and" xs ++ "is" ++ f.s ; -- business plan is known + _ => f.s ++ "holds for" ++ conjX "and" xs } + } ; + + PredAppMany op preds args = { + s = quote (conjX "and" args) ++ "is" ++ conjX (op.s ! Verbose) preds + } ; + Fold combine nil over = { s = linebreak ++ "Combine" ++ quote over.s ++ "into one value," ++ linebreak @@ -171,29 +320,133 @@ concrete Lam4Eng of Lam4 = open Prelude, Coordination in { ++ "starting from" ++ nil.s } ; + -- When generating natural language for some file that defines a bunch of stuff like cons, map, filter, + -- apply this function instead to keep it in the AST + -- but skip linearization. + -- : Name -> Expr + KnownFunction _ = {s = ""} ; + -- Unary and binary operators - Not = ss "not" ; + Not = ss (hilight Strong "it is not the case that") ; Floor = ss "floor of" ; Ceiling = ss "ceiling of" ; IntegerToFraction = ss "" ; -- not important in NLG UnaryMinus = ss "-" ; - Or = ss "or" ; - And = ss "and" ; - Plus = ss "+" ; - Minus = ss "-" ; - Modulo = ss "%" ; - Mult = ss "*" ; - Divide = ss "/" ; - Lt = ss "<" ; - Le = ss "≤" ; - Gt = ss ">" ; - Ge = ss "≥" ; - Eq = ss "equals to" ; - Ne = ss "≠" ; + UnaryMinusExpr expr = {s = glue "-" expr.s} ; + + Or = mkBinExpr "||" "or" ; + And = mkBinExpr "&&" "and" ; + Plus = mkBinExpr "+" "added to" ; + Minus = mkBinExpr "-" "subtracted from" ; + Modulo = mkBinExpr "%" "modulo" ; + Mult = mkBinExpr "*" "multiplied by" ; + Divide = mkBinExpr "/" "divided by" ; + Lt = mkBinExpr "<" "is less than" ; + Le = mkBinExpr "≤" "is less than or equal" ; + Gt = mkBinExpr ">" "is greater than" ; + Ge = mkBinExpr "≥" "is greater than or equal to" ; + Eq = mkBinExpr "=" "equals to" ; + Ne = mkBinExpr "≠" "is not equal to" ; + + +------------------------- + -- List operations + oper + ListX0 : Type = ListX ** {size : MyListSize} ; + + baseListX0 : ListX0 = { + s1, s2 = "" ; + size = Zero + } ; + + conslListX0 : SS -> ListX0 -> ListX0 = \x,xs -> case xs.size of { + Many => xs ** { + s1 = xs.s1 ++ bindComma ++ xs.s2 ; + s2 = x.s + } ; + One => xs ** { + s2 = x.s ; + size = Many + } ; + Zero => xs ** { + s1 = x.s ; + size = One + } + } ; + + consrListX0 : SS -> ListX0 -> ListX0 = \x,xs -> case xs.size of { + Many => xs ** { + s1 = x.s ++ bindComma ++ xs.s1 ; + } ; + One => xs ** { + s1 = x.s ; + size = Many + } ; + Zero => xs ** { + s2 = x.s ; + size = One + } + } ; + + baseIfThen : SS -> SS -> SS = \s1,s2 -> { + s = + -- li + s1.s + ++ + -- li + s2.s + } ; + + consIfThen : SS -> SS -> SS = \s,ss -> ss ** { + s = + -- li + s.s + ++ ss.s + } ; + -- Special for flattening nested And/Or + LinLExpr : Type = {s : PListOp => Str} ; + LinListOp : Type = {s : Str ; op : PListOp} ; + + conjTable : PListOp => Str = table { + PListAnd => andKw ; + PListOr => orKw } ; + + headerTable : PListOp => Str = table { + PListAnd => allKw ; + PListOr => anyKw } ; + + baseLExpr : SS -> SS -> LinLExpr = \s1,s2 -> { + s = \\conj => + dl (conjTable ! conj) s1.s + ++ + dl (conjTable ! conj) s2.s + } ; + + consLExpr : SS -> LinLExpr -> LinLExpr = \s,ss -> ss ** { + s = \\conj => + dl (conjTable ! conj) s.s + ++ + ss.s ! conj + } ; + + conjLExpr : LinListOp -> LinLExpr -> SS = \co,ss -> { + s = ss.s ! co.op + } ; + +lin BaseExpr, BaseName = baseListX0 ; - ConsExpr, ConsName = consListX0 ; + ConsExpr, ConsName = consrListX0 ; + ConjExpr = conjXss ; + + BaseLExpr = baseLExpr ; + ConsLExpr = consLExpr ; + ApplyListOp = conjLExpr ; + + ListAnd = {s = "" ; op = PListAnd} ; + ListOr = {s = "" ; op = PListOr} ; + coerceListExpr = id SS ; } {- diff --git a/lam4-backend/gf-grammar/README.md b/lam4-backend/gf-grammar/README.md index 612d9b13..db5bcab1 100644 --- a/lam4-backend/gf-grammar/README.md +++ b/lam4-backend/gf-grammar/README.md @@ -10,7 +10,7 @@ $ gf Lam4Eng.gf linking ... OK Languages: Lam4Eng -Lam4> l -unlextext MkTypeDecl (MkMetadata "a game where you lose money") (MkName "Lottery") (ConsRowTypeDecl (MkRowDecl (MkMetadata "how much can be won from the jackpot") (MkName "‘total jackpot’")) (ConsRcowTypeDecl (MkRowDecl (MkMetadata "whether buying tickets from this lottery is tax deductible") (MkName "‘tax deductible status’")) BaseRowTypeDecl)) | ? tr "°∞" " \n" +Lam4> l -unlextext MkTypeDecl (MkMetadata "a game where you lose money") (MkName "Lottery") (ConsRowTypeDecl (MkRowDecl (MkMetadata "how much can be won from the jackpot") (MkName "‘total jackpot’")) (ConsRowTypeDecl (MkRowDecl (MkMetadata "whether buying tickets from this lottery is tax deductible") (MkName "‘tax deductible status’")) BaseRowTypeDecl)) | ? tr "°∞" " \n" ``` should linearize into the following ``` diff --git a/lam4-backend/lam4-backend.cabal b/lam4-backend/lam4-backend.cabal index 651eeb50..d0b670b6 100644 --- a/lam4-backend/lam4-backend.cabal +++ b/lam4-backend/lam4-backend.cabal @@ -87,7 +87,8 @@ library cgi ^>= 3001.5.0.1, multipart ^>= 0.2.1, lens-regex-pcre, - string-interpolate + string-interpolate, + raw-strings-qq diff --git a/lam4-backend/src/Lam4/Render/Lam4Gf.hs b/lam4-backend/src/Lam4/Render/Lam4Gf.hs index d5b5e94b..d4343cce 100644 --- a/lam4-backend/src/Lam4/Render/Lam4Gf.hs +++ b/lam4-backend/src/Lam4/Render/Lam4Gf.hs @@ -44,10 +44,20 @@ type GBinOp = Tree GBinOp_ data GBinOp_ type GExpr = Tree GExpr_ data GExpr_ +type GIfThen = Tree GIfThen_ +data GIfThen_ +type GLExpr = Tree GLExpr_ +data GLExpr_ type GListExpr = Tree GListExpr_ data GListExpr_ +type GListIfThen = Tree GListIfThen_ +data GListIfThen_ +type GListLExpr = Tree GListLExpr_ +data GListLExpr_ type GListName = Tree GListName_ data GListName_ +type GListOp = Tree GListOp_ +data GListOp_ type GListRowTypeDecl = Tree GListRowTypeDecl_ data GListRowTypeDecl_ type GMetadata = Tree GMetadata_ @@ -83,33 +93,58 @@ data Tree :: * -> * where GNe :: Tree GBinOp_ GOr :: Tree GBinOp_ GPlus :: Tree GBinOp_ + GApplyListOp :: GListOp -> GListLExpr -> Tree GExpr_ GBinExpr :: GBinOp -> GExpr -> GExpr -> Tree GExpr_ + GConjExpr :: GListExpr -> Tree GExpr_ + GDefault :: GExpr -> GExpr -> Tree GExpr_ + GElif :: GListIfThen -> Tree GExpr_ GFold :: GExpr -> GExpr -> GExpr -> Tree GExpr_ GFun :: GName -> GMetadata -> GListName -> GExpr -> Tree GExpr_ GFunApp :: GExpr -> GListExpr -> Tree GExpr_ + GFunApp1 :: GString -> GExpr -> Tree GExpr_ + GFunApp2 :: GString -> GExpr -> GString -> GExpr -> Tree GExpr_ GIfThenElse :: GExpr -> GExpr -> GExpr -> Tree GExpr_ + GKnownFunction :: GName -> Tree GExpr_ + GLet :: GS -> GExpr -> Tree GExpr_ GLit :: GName -> Tree GExpr_ GNormIsInfringed :: GName -> Tree GExpr_ + GOnlyFieldProject :: GExpr -> GName -> Tree GExpr_ GPredApp :: GExpr -> GListExpr -> Tree GExpr_ + GPredAppMany :: GBinOp -> GListExpr -> GListExpr -> Tree GExpr_ GPredicate :: GName -> GMetadata -> GListName -> GExpr -> Tree GExpr_ GProject :: GExpr -> GName -> Tree GExpr_ GQuoteVar :: GName -> Tree GExpr_ + GRecord :: GName -> GExpr -> Tree GExpr_ + GRound :: GExpr -> GExpr -> Tree GExpr_ + GSig :: GListName -> GListExpr -> Tree GExpr_ GUnary :: GUnaryOp -> GExpr -> Tree GExpr_ + GUnaryMinusExpr :: GExpr -> Tree GExpr_ GVar :: GName -> Tree GExpr_ + GVerboseBinExpr :: GBinOp -> GExpr -> GExpr -> Tree GExpr_ + GFirstIfThen :: GExpr -> GExpr -> Tree GIfThen_ + GMiddleIfThen :: GExpr -> GExpr -> Tree GIfThen_ + GNilIfThen :: GExpr -> Tree GIfThen_ + GcoerceListExpr :: GExpr -> Tree GLExpr_ GListExpr :: [GExpr] -> Tree GListExpr_ + GListIfThen :: [GIfThen] -> Tree GListIfThen_ + GListLExpr :: [GLExpr] -> Tree GListLExpr_ GListName :: [GName] -> Tree GListName_ + GListAnd :: Tree GListOp_ + GListOr :: Tree GListOp_ GListRowTypeDecl :: [GRowTypeDecl] -> Tree GListRowTypeDecl_ GMkMetadata :: GString -> Tree GMetadata_ GNoMetadata :: Tree GMetadata_ GMkName :: GString -> Tree GName_ GMkRowDecl :: GMetadata -> GName -> Tree GRowTypeDecl_ GMkRowTypeDecl :: GMetadata -> GName -> GName -> Tree GRowTypeDecl_ - GAssignS :: GName -> GExpr -> Tree GS_ + GAssignS :: GString -> GName -> GExpr -> Tree GS_ + GAtomicConcept :: GString -> GName -> Tree GS_ GEmptyS :: Tree GS_ - GEvalS :: GExpr -> Tree GS_ - GEvalWhetherS :: GExpr -> Tree GS_ - GExprS :: GExpr -> Tree GS_ - GTypeDeclS :: GTypeDecl -> Tree GS_ + GEvalS :: GString -> GExpr -> Tree GS_ + GEvalWhetherS :: GString -> GExpr -> Tree GS_ + GExprS :: GString -> GExpr -> Tree GS_ + GLetIsTrue :: GString -> GName -> GExpr -> Tree GS_ + GTypeDeclS :: GString -> GTypeDecl -> Tree GS_ GMkTypeDecl :: GMetadata -> GName -> GListRowTypeDecl -> Tree GTypeDecl_ GCeiling :: Tree GUnaryOp_ GFloor :: Tree GUnaryOp_ @@ -135,33 +170,58 @@ instance Eq (Tree a) where (GNe,GNe) -> and [ ] (GOr,GOr) -> and [ ] (GPlus,GPlus) -> and [ ] + (GApplyListOp x1 x2,GApplyListOp y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GBinExpr x1 x2 x3,GBinExpr y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] + (GConjExpr x1,GConjExpr y1) -> and [ x1 == y1 ] + (GDefault x1 x2,GDefault y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GElif x1,GElif y1) -> and [ x1 == y1 ] (GFold x1 x2 x3,GFold y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] (GFun x1 x2 x3 x4,GFun y1 y2 y3 y4) -> and [ x1 == y1 , x2 == y2 , x3 == y3 , x4 == y4 ] (GFunApp x1 x2,GFunApp y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GFunApp1 x1 x2,GFunApp1 y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GFunApp2 x1 x2 x3 x4,GFunApp2 y1 y2 y3 y4) -> and [ x1 == y1 , x2 == y2 , x3 == y3 , x4 == y4 ] (GIfThenElse x1 x2 x3,GIfThenElse y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] + (GKnownFunction x1,GKnownFunction y1) -> and [ x1 == y1 ] + (GLet x1 x2,GLet y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GLit x1,GLit y1) -> and [ x1 == y1 ] (GNormIsInfringed x1,GNormIsInfringed y1) -> and [ x1 == y1 ] + (GOnlyFieldProject x1 x2,GOnlyFieldProject y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GPredApp x1 x2,GPredApp y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GPredAppMany x1 x2 x3,GPredAppMany y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] (GPredicate x1 x2 x3 x4,GPredicate y1 y2 y3 y4) -> and [ x1 == y1 , x2 == y2 , x3 == y3 , x4 == y4 ] (GProject x1 x2,GProject y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GQuoteVar x1,GQuoteVar y1) -> and [ x1 == y1 ] + (GRecord x1 x2,GRecord y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GRound x1 x2,GRound y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GSig x1 x2,GSig y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GUnary x1 x2,GUnary y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GUnaryMinusExpr x1,GUnaryMinusExpr y1) -> and [ x1 == y1 ] (GVar x1,GVar y1) -> and [ x1 == y1 ] + (GVerboseBinExpr x1 x2 x3,GVerboseBinExpr y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] + (GFirstIfThen x1 x2,GFirstIfThen y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GMiddleIfThen x1 x2,GMiddleIfThen y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GNilIfThen x1,GNilIfThen y1) -> and [ x1 == y1 ] + (GcoerceListExpr x1,GcoerceListExpr y1) -> and [ x1 == y1 ] (GListExpr x1,GListExpr y1) -> and [x == y | (x,y) <- zip x1 y1] + (GListIfThen x1,GListIfThen y1) -> and [x == y | (x,y) <- zip x1 y1] + (GListLExpr x1,GListLExpr y1) -> and [x == y | (x,y) <- zip x1 y1] (GListName x1,GListName y1) -> and [x == y | (x,y) <- zip x1 y1] + (GListAnd,GListAnd) -> and [ ] + (GListOr,GListOr) -> and [ ] (GListRowTypeDecl x1,GListRowTypeDecl y1) -> and [x == y | (x,y) <- zip x1 y1] (GMkMetadata x1,GMkMetadata y1) -> and [ x1 == y1 ] (GNoMetadata,GNoMetadata) -> and [ ] (GMkName x1,GMkName y1) -> and [ x1 == y1 ] (GMkRowDecl x1 x2,GMkRowDecl y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GMkRowTypeDecl x1 x2 x3,GMkRowTypeDecl y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] - (GAssignS x1 x2,GAssignS y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GAssignS x1 x2 x3,GAssignS y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] + (GAtomicConcept x1 x2,GAtomicConcept y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GEmptyS,GEmptyS) -> and [ ] - (GEvalS x1,GEvalS y1) -> and [ x1 == y1 ] - (GEvalWhetherS x1,GEvalWhetherS y1) -> and [ x1 == y1 ] - (GExprS x1,GExprS y1) -> and [ x1 == y1 ] - (GTypeDeclS x1,GTypeDeclS y1) -> and [ x1 == y1 ] + (GEvalS x1 x2,GEvalS y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GEvalWhetherS x1 x2,GEvalWhetherS y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GExprS x1 x2,GExprS y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GLetIsTrue x1 x2 x3,GLetIsTrue y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] + (GTypeDeclS x1 x2,GTypeDeclS y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GMkTypeDecl x1 x2 x3,GMkTypeDecl y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] (GCeiling,GCeiling) -> and [ ] (GFloor,GFloor) -> and [ ] @@ -208,39 +268,93 @@ instance Gf GBinOp where _ -> error ("no BinOp " ++ show t) instance Gf GExpr where + gf (GApplyListOp x1 x2) = mkApp (mkCId "ApplyListOp") [gf x1, gf x2] gf (GBinExpr x1 x2 x3) = mkApp (mkCId "BinExpr") [gf x1, gf x2, gf x3] + gf (GConjExpr x1) = mkApp (mkCId "ConjExpr") [gf x1] + gf (GDefault x1 x2) = mkApp (mkCId "Default") [gf x1, gf x2] + gf (GElif x1) = mkApp (mkCId "Elif") [gf x1] gf (GFold x1 x2 x3) = mkApp (mkCId "Fold") [gf x1, gf x2, gf x3] gf (GFun x1 x2 x3 x4) = mkApp (mkCId "Fun") [gf x1, gf x2, gf x3, gf x4] gf (GFunApp x1 x2) = mkApp (mkCId "FunApp") [gf x1, gf x2] + gf (GFunApp1 x1 x2) = mkApp (mkCId "FunApp1") [gf x1, gf x2] + gf (GFunApp2 x1 x2 x3 x4) = mkApp (mkCId "FunApp2") [gf x1, gf x2, gf x3, gf x4] gf (GIfThenElse x1 x2 x3) = mkApp (mkCId "IfThenElse") [gf x1, gf x2, gf x3] + gf (GKnownFunction x1) = mkApp (mkCId "KnownFunction") [gf x1] + gf (GLet x1 x2) = mkApp (mkCId "Let") [gf x1, gf x2] gf (GLit x1) = mkApp (mkCId "Lit") [gf x1] gf (GNormIsInfringed x1) = mkApp (mkCId "NormIsInfringed") [gf x1] + gf (GOnlyFieldProject x1 x2) = mkApp (mkCId "OnlyFieldProject") [gf x1, gf x2] gf (GPredApp x1 x2) = mkApp (mkCId "PredApp") [gf x1, gf x2] + gf (GPredAppMany x1 x2 x3) = mkApp (mkCId "PredAppMany") [gf x1, gf x2, gf x3] gf (GPredicate x1 x2 x3 x4) = mkApp (mkCId "Predicate") [gf x1, gf x2, gf x3, gf x4] gf (GProject x1 x2) = mkApp (mkCId "Project") [gf x1, gf x2] gf (GQuoteVar x1) = mkApp (mkCId "QuoteVar") [gf x1] + gf (GRecord x1 x2) = mkApp (mkCId "Record") [gf x1, gf x2] + gf (GRound x1 x2) = mkApp (mkCId "Round") [gf x1, gf x2] + gf (GSig x1 x2) = mkApp (mkCId "Sig") [gf x1, gf x2] gf (GUnary x1 x2) = mkApp (mkCId "Unary") [gf x1, gf x2] + gf (GUnaryMinusExpr x1) = mkApp (mkCId "UnaryMinusExpr") [gf x1] gf (GVar x1) = mkApp (mkCId "Var") [gf x1] + gf (GVerboseBinExpr x1 x2 x3) = mkApp (mkCId "VerboseBinExpr") [gf x1, gf x2, gf x3] fg t = case unApp t of + Just (i,[x1,x2]) | i == mkCId "ApplyListOp" -> GApplyListOp (fg x1) (fg x2) Just (i,[x1,x2,x3]) | i == mkCId "BinExpr" -> GBinExpr (fg x1) (fg x2) (fg x3) + Just (i,[x1]) | i == mkCId "ConjExpr" -> GConjExpr (fg x1) + Just (i,[x1,x2]) | i == mkCId "Default" -> GDefault (fg x1) (fg x2) + Just (i,[x1]) | i == mkCId "Elif" -> GElif (fg x1) Just (i,[x1,x2,x3]) | i == mkCId "Fold" -> GFold (fg x1) (fg x2) (fg x3) Just (i,[x1,x2,x3,x4]) | i == mkCId "Fun" -> GFun (fg x1) (fg x2) (fg x3) (fg x4) Just (i,[x1,x2]) | i == mkCId "FunApp" -> GFunApp (fg x1) (fg x2) + Just (i,[x1,x2]) | i == mkCId "FunApp1" -> GFunApp1 (fg x1) (fg x2) + Just (i,[x1,x2,x3,x4]) | i == mkCId "FunApp2" -> GFunApp2 (fg x1) (fg x2) (fg x3) (fg x4) Just (i,[x1,x2,x3]) | i == mkCId "IfThenElse" -> GIfThenElse (fg x1) (fg x2) (fg x3) + Just (i,[x1]) | i == mkCId "KnownFunction" -> GKnownFunction (fg x1) + Just (i,[x1,x2]) | i == mkCId "Let" -> GLet (fg x1) (fg x2) Just (i,[x1]) | i == mkCId "Lit" -> GLit (fg x1) Just (i,[x1]) | i == mkCId "NormIsInfringed" -> GNormIsInfringed (fg x1) + Just (i,[x1,x2]) | i == mkCId "OnlyFieldProject" -> GOnlyFieldProject (fg x1) (fg x2) Just (i,[x1,x2]) | i == mkCId "PredApp" -> GPredApp (fg x1) (fg x2) + Just (i,[x1,x2,x3]) | i == mkCId "PredAppMany" -> GPredAppMany (fg x1) (fg x2) (fg x3) Just (i,[x1,x2,x3,x4]) | i == mkCId "Predicate" -> GPredicate (fg x1) (fg x2) (fg x3) (fg x4) Just (i,[x1,x2]) | i == mkCId "Project" -> GProject (fg x1) (fg x2) Just (i,[x1]) | i == mkCId "QuoteVar" -> GQuoteVar (fg x1) + Just (i,[x1,x2]) | i == mkCId "Record" -> GRecord (fg x1) (fg x2) + Just (i,[x1,x2]) | i == mkCId "Round" -> GRound (fg x1) (fg x2) + Just (i,[x1,x2]) | i == mkCId "Sig" -> GSig (fg x1) (fg x2) Just (i,[x1,x2]) | i == mkCId "Unary" -> GUnary (fg x1) (fg x2) + Just (i,[x1]) | i == mkCId "UnaryMinusExpr" -> GUnaryMinusExpr (fg x1) Just (i,[x1]) | i == mkCId "Var" -> GVar (fg x1) + Just (i,[x1,x2,x3]) | i == mkCId "VerboseBinExpr" -> GVerboseBinExpr (fg x1) (fg x2) (fg x3) _ -> error ("no Expr " ++ show t) +instance Gf GIfThen where + gf (GFirstIfThen x1 x2) = mkApp (mkCId "FirstIfThen") [gf x1, gf x2] + gf (GMiddleIfThen x1 x2) = mkApp (mkCId "MiddleIfThen") [gf x1, gf x2] + gf (GNilIfThen x1) = mkApp (mkCId "NilIfThen") [gf x1] + + fg t = + case unApp t of + Just (i,[x1,x2]) | i == mkCId "FirstIfThen" -> GFirstIfThen (fg x1) (fg x2) + Just (i,[x1,x2]) | i == mkCId "MiddleIfThen" -> GMiddleIfThen (fg x1) (fg x2) + Just (i,[x1]) | i == mkCId "NilIfThen" -> GNilIfThen (fg x1) + + + _ -> error ("no IfThen " ++ show t) + +instance Gf GLExpr where + gf (GcoerceListExpr x1) = mkApp (mkCId "coerceListExpr") [gf x1] + + fg t = + case unApp t of + Just (i,[x1]) | i == mkCId "coerceListExpr" -> GcoerceListExpr (fg x1) + + + _ -> error ("no LExpr " ++ show t) + instance Gf GListExpr where gf (GListExpr []) = mkApp (mkCId "BaseExpr") [] gf (GListExpr (x:xs)) = mkApp (mkCId "ConsExpr") [gf x, gf (GListExpr xs)] @@ -253,6 +367,30 @@ instance Gf GListExpr where _ -> error ("no ListExpr " ++ show t) +instance Gf GListIfThen where + gf (GListIfThen [x1,x2]) = mkApp (mkCId "BaseIfThen") [gf x1, gf x2] + gf (GListIfThen (x:xs)) = mkApp (mkCId "ConsIfThen") [gf x, gf (GListIfThen xs)] + fg t = + GListIfThen (fgs t) where + fgs t = case unApp t of + Just (i,[x1,x2]) | i == mkCId "BaseIfThen" -> [fg x1, fg x2] + Just (i,[x1,x2]) | i == mkCId "ConsIfThen" -> fg x1 : fgs x2 + + + _ -> error ("no ListIfThen " ++ show t) + +instance Gf GListLExpr where + gf (GListLExpr [x1,x2]) = mkApp (mkCId "BaseLExpr") [gf x1, gf x2] + gf (GListLExpr (x:xs)) = mkApp (mkCId "ConsLExpr") [gf x, gf (GListLExpr xs)] + fg t = + GListLExpr (fgs t) where + fgs t = case unApp t of + Just (i,[x1,x2]) | i == mkCId "BaseLExpr" -> [fg x1, fg x2] + Just (i,[x1,x2]) | i == mkCId "ConsLExpr" -> fg x1 : fgs x2 + + + _ -> error ("no ListLExpr " ++ show t) + instance Gf GListName where gf (GListName []) = mkApp (mkCId "BaseName") [] gf (GListName (x:xs)) = mkApp (mkCId "ConsName") [gf x, gf (GListName xs)] @@ -265,6 +403,18 @@ instance Gf GListName where _ -> error ("no ListName " ++ show t) +instance Gf GListOp where + gf GListAnd = mkApp (mkCId "ListAnd") [] + gf GListOr = mkApp (mkCId "ListOr") [] + + fg t = + case unApp t of + Just (i,[]) | i == mkCId "ListAnd" -> GListAnd + Just (i,[]) | i == mkCId "ListOr" -> GListOr + + + _ -> error ("no ListOp " ++ show t) + instance Gf GListRowTypeDecl where gf (GListRowTypeDecl []) = mkApp (mkCId "BaseRowTypeDecl") [] gf (GListRowTypeDecl (x:xs)) = mkApp (mkCId "ConsRowTypeDecl") [gf x, gf (GListRowTypeDecl xs)] @@ -312,21 +462,25 @@ instance Gf GRowTypeDecl where _ -> error ("no RowTypeDecl " ++ show t) instance Gf GS where - gf (GAssignS x1 x2) = mkApp (mkCId "AssignS") [gf x1, gf x2] + gf (GAssignS x1 x2 x3) = mkApp (mkCId "AssignS") [gf x1, gf x2, gf x3] + gf (GAtomicConcept x1 x2) = mkApp (mkCId "AtomicConcept") [gf x1, gf x2] gf GEmptyS = mkApp (mkCId "EmptyS") [] - gf (GEvalS x1) = mkApp (mkCId "EvalS") [gf x1] - gf (GEvalWhetherS x1) = mkApp (mkCId "EvalWhetherS") [gf x1] - gf (GExprS x1) = mkApp (mkCId "ExprS") [gf x1] - gf (GTypeDeclS x1) = mkApp (mkCId "TypeDeclS") [gf x1] + gf (GEvalS x1 x2) = mkApp (mkCId "EvalS") [gf x1, gf x2] + gf (GEvalWhetherS x1 x2) = mkApp (mkCId "EvalWhetherS") [gf x1, gf x2] + gf (GExprS x1 x2) = mkApp (mkCId "ExprS") [gf x1, gf x2] + gf (GLetIsTrue x1 x2 x3) = mkApp (mkCId "LetIsTrue") [gf x1, gf x2, gf x3] + gf (GTypeDeclS x1 x2) = mkApp (mkCId "TypeDeclS") [gf x1, gf x2] fg t = case unApp t of - Just (i,[x1,x2]) | i == mkCId "AssignS" -> GAssignS (fg x1) (fg x2) + Just (i,[x1,x2,x3]) | i == mkCId "AssignS" -> GAssignS (fg x1) (fg x2) (fg x3) + Just (i,[x1,x2]) | i == mkCId "AtomicConcept" -> GAtomicConcept (fg x1) (fg x2) Just (i,[]) | i == mkCId "EmptyS" -> GEmptyS - Just (i,[x1]) | i == mkCId "EvalS" -> GEvalS (fg x1) - Just (i,[x1]) | i == mkCId "EvalWhetherS" -> GEvalWhetherS (fg x1) - Just (i,[x1]) | i == mkCId "ExprS" -> GExprS (fg x1) - Just (i,[x1]) | i == mkCId "TypeDeclS" -> GTypeDeclS (fg x1) + Just (i,[x1,x2]) | i == mkCId "EvalS" -> GEvalS (fg x1) (fg x2) + Just (i,[x1,x2]) | i == mkCId "EvalWhetherS" -> GEvalWhetherS (fg x1) (fg x2) + Just (i,[x1,x2]) | i == mkCId "ExprS" -> GExprS (fg x1) (fg x2) + Just (i,[x1,x2,x3]) | i == mkCId "LetIsTrue" -> GLetIsTrue (fg x1) (fg x2) (fg x3) + Just (i,[x1,x2]) | i == mkCId "TypeDeclS" -> GTypeDeclS (fg x1) (fg x2) _ -> error ("no S " ++ show t) @@ -362,30 +516,53 @@ instance Gf GUnaryOp where instance Compos Tree where compos r a f t = case t of + GApplyListOp x1 x2 -> r GApplyListOp `a` f x1 `a` f x2 GBinExpr x1 x2 x3 -> r GBinExpr `a` f x1 `a` f x2 `a` f x3 + GConjExpr x1 -> r GConjExpr `a` f x1 + GDefault x1 x2 -> r GDefault `a` f x1 `a` f x2 + GElif x1 -> r GElif `a` f x1 GFold x1 x2 x3 -> r GFold `a` f x1 `a` f x2 `a` f x3 GFun x1 x2 x3 x4 -> r GFun `a` f x1 `a` f x2 `a` f x3 `a` f x4 GFunApp x1 x2 -> r GFunApp `a` f x1 `a` f x2 + GFunApp1 x1 x2 -> r GFunApp1 `a` f x1 `a` f x2 + GFunApp2 x1 x2 x3 x4 -> r GFunApp2 `a` f x1 `a` f x2 `a` f x3 `a` f x4 GIfThenElse x1 x2 x3 -> r GIfThenElse `a` f x1 `a` f x2 `a` f x3 + GKnownFunction x1 -> r GKnownFunction `a` f x1 + GLet x1 x2 -> r GLet `a` f x1 `a` f x2 GLit x1 -> r GLit `a` f x1 GNormIsInfringed x1 -> r GNormIsInfringed `a` f x1 + GOnlyFieldProject x1 x2 -> r GOnlyFieldProject `a` f x1 `a` f x2 GPredApp x1 x2 -> r GPredApp `a` f x1 `a` f x2 + GPredAppMany x1 x2 x3 -> r GPredAppMany `a` f x1 `a` f x2 `a` f x3 GPredicate x1 x2 x3 x4 -> r GPredicate `a` f x1 `a` f x2 `a` f x3 `a` f x4 GProject x1 x2 -> r GProject `a` f x1 `a` f x2 GQuoteVar x1 -> r GQuoteVar `a` f x1 + GRecord x1 x2 -> r GRecord `a` f x1 `a` f x2 + GRound x1 x2 -> r GRound `a` f x1 `a` f x2 + GSig x1 x2 -> r GSig `a` f x1 `a` f x2 GUnary x1 x2 -> r GUnary `a` f x1 `a` f x2 + GUnaryMinusExpr x1 -> r GUnaryMinusExpr `a` f x1 GVar x1 -> r GVar `a` f x1 + GVerboseBinExpr x1 x2 x3 -> r GVerboseBinExpr `a` f x1 `a` f x2 `a` f x3 + GFirstIfThen x1 x2 -> r GFirstIfThen `a` f x1 `a` f x2 + GMiddleIfThen x1 x2 -> r GMiddleIfThen `a` f x1 `a` f x2 + GNilIfThen x1 -> r GNilIfThen `a` f x1 + GcoerceListExpr x1 -> r GcoerceListExpr `a` f x1 GMkMetadata x1 -> r GMkMetadata `a` f x1 GMkName x1 -> r GMkName `a` f x1 GMkRowDecl x1 x2 -> r GMkRowDecl `a` f x1 `a` f x2 GMkRowTypeDecl x1 x2 x3 -> r GMkRowTypeDecl `a` f x1 `a` f x2 `a` f x3 - GAssignS x1 x2 -> r GAssignS `a` f x1 `a` f x2 - GEvalS x1 -> r GEvalS `a` f x1 - GEvalWhetherS x1 -> r GEvalWhetherS `a` f x1 - GExprS x1 -> r GExprS `a` f x1 - GTypeDeclS x1 -> r GTypeDeclS `a` f x1 + GAssignS x1 x2 x3 -> r GAssignS `a` f x1 `a` f x2 `a` f x3 + GAtomicConcept x1 x2 -> r GAtomicConcept `a` f x1 `a` f x2 + GEvalS x1 x2 -> r GEvalS `a` f x1 `a` f x2 + GEvalWhetherS x1 x2 -> r GEvalWhetherS `a` f x1 `a` f x2 + GExprS x1 x2 -> r GExprS `a` f x1 `a` f x2 + GLetIsTrue x1 x2 x3 -> r GLetIsTrue `a` f x1 `a` f x2 `a` f x3 + GTypeDeclS x1 x2 -> r GTypeDeclS `a` f x1 `a` f x2 GMkTypeDecl x1 x2 x3 -> r GMkTypeDecl `a` f x1 `a` f x2 `a` f x3 GListExpr x1 -> r GListExpr `a` foldr (a . a (r (:)) . f) (r []) x1 + GListIfThen x1 -> r GListIfThen `a` foldr (a . a (r (:)) . f) (r []) x1 + GListLExpr x1 -> r GListLExpr `a` foldr (a . a (r (:)) . f) (r []) x1 GListName x1 -> r GListName `a` foldr (a . a (r (:)) . f) (r []) x1 GListRowTypeDecl x1 -> r GListRowTypeDecl `a` foldr (a . a (r (:)) . f) (r []) x1 _ -> r t diff --git a/lam4-backend/src/Lam4/Render/Render.hs b/lam4-backend/src/Lam4/Render/Render.hs index 81a1f8d9..902c3d17 100644 --- a/lam4-backend/src/Lam4/Render/Render.hs +++ b/lam4-backend/src/Lam4/Render/Render.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ViewPatterns #-} module Lam4.Render.Render (NLGConfig (..), NLGEnv, makeNLGEnv, renderCstProgramToNL) where @@ -8,6 +9,7 @@ import qualified Base.Text as T import Control.Lens ((%~), (&)) import Control.Lens.Regex.Text (match, regex) import Data.String.Interpolate (i) +import Text.RawString.QQ import Lam4.Expr.CommonSyntax import Lam4.Expr.ConcreteSyntax import qualified Lam4.Expr.Name as N (Name (..), ReferentStatus (..)) @@ -49,7 +51,7 @@ makeNLGEnv config = do gr <- PGF.readPGF grammarFile -- Set up PGF Language and GF Linearizer - let lang = initializeGFLang config.concreteSyntaxName gr + let lang = initializeGFLang config.concreteSyntaxName gr linearizer = makeGFLinearizer gr lang pure $ NLGEnv linearizer @@ -68,33 +70,140 @@ initializeGFLang str gr = postprocessText :: T.Text -> T.Text -postprocessText = newlines . tabs . rmBIND +postprocessText = rmBIND . newlines -- . any other postprocessing functions here where -- TODO: the following could be cleaned up / made clearer rmBIND :: T.Text -> T.Text rmBIND input = input & [regex|\s+&\+\s+|] . match %~ const "" - tabs :: T.Text -> T.Text - tabs = T.map (\c -> if c == '°' then ' ' else c) - newlines :: T.Text -> T.Text newlines = T.map (\c -> if c == '∞' then '\n' else c) +style :: T.Text +style = [r| + |] + -- | Entrypoint renderCstProgramToNL :: NLGEnv -> CSTProgram -> T.Text -renderCstProgramToNL env = T.unlines . fmap (renderCstDeclToNL env) +renderCstProgramToNL env decls = T.unlines ( + ["", "", style, "", ""] <> + fmap (renderCstDeclToNL env) decls <> + ["", ""] +-- <> fmap (renderCstDeclToGFtrees env) decls + ) renderCstDeclToNL :: NLGEnv -> Decl -> T.Text -renderCstDeclToNL env = gfLin env . gf . parseDecl - -parseDecl :: Decl -> GS -parseDecl = \case - DataDecl name typedecl -> GTypeDeclS $ parseTypeDecl name typedecl - Rec name expr -> GExprS $ parseExpr name expr - NonRec name expr -> GAssignS (parseName name) $ parseExpr noName expr +renderCstDeclToNL env = gfLin env . gf . genericTreeTrans . parseDecl env + +-- TODO: do we flatten nested Let-definitions? +-- for royalflush case, that'd be the best thing to do +-- how about generally? +parseDecl :: NLGEnv -> Decl -> GS +parseDecl env = \case + DataDecl name typedecl -> GTypeDeclS dummyId $ parseTypeDecl name typedecl + Rec name expr -> + if commonFunction name.name + then GExprS dummyId $ GKnownFunction $ parseName name + else GExprS dummyId $ parseExpr env name expr + NonRec name (Sig [] []) -> GAtomicConcept dummyId (parseName name) + NonRec name expr@(BinExpr binop _ _) -> + if booleanOp binop + then GLetIsTrue dummyId (parseName name) $ parseExpr env noName expr + else GAssignS dummyId (parseName name) $ parseExpr env noName expr + NonRec name expr -> GAssignS dummyId (parseName name) $ parseExpr env noName expr Eval expr -> quoteVars $ if isBool expr - then GEvalWhetherS $ parseExpr noName expr - else GEvalS $ parseExpr noName expr + then GEvalWhetherS dummyId $ parseExpr env noName expr + else GEvalS dummyId $ parseExpr env noName expr + +-- to wrap all declarations in

    …

    +dummyId :: GString +dummyId = GString "paragraph_999999" noName :: N.Name noName = N.MkName mempty Nothing N.NotEntrypoint @@ -102,10 +211,101 @@ noName = N.MkName mempty Nothing N.NotEntrypoint parseName :: N.Name -> GName parseName = GMkName . GString . T.unpack . N.name +commonFunction :: T.Text -> Bool +commonFunction x = T.unpack x `elem` ["id", "map", "filter", "cons", "nil", "minus", "plus", "div", "mult", "add", "modulo", "pow", "round", "certain", "uncertain", "known", "unknown", "default", "instanceSumIf", "instanceSum"] + +booleanOp :: BinOp -> Bool +booleanOp op = op `elem` [Eq, Lt, Gt, Le, Ge, Ne, And, Or] + +getName :: Expr -> Maybe String +getName = \case + Var (N.MkName name _ _) -> Just $ T.unpack name + _ -> Nothing + +isPredicate :: Expr -> Bool +isPredicate (getName -> Just name) = name `elem` ["certain", "known", "uncertain", "unknown"] +isPredicate _ = False + +---- Tree transformations ----- + +genericTreeTrans :: Tree a -> Tree a +genericTreeTrans = flattenITE . flattenNestedAndOr . aggregatePredApp . binExprVerbosity + quoteVars :: Tree a -> Tree a quoteVars (GVar x) = GQuoteVar x quoteVars x = composOp quoteVars x +-- Control verbosity of BinExpr in specific contexts +binExprVerbosity :: Tree a -> Tree a +binExprVerbosity (GAssignS id_ e (GBinExpr op lc rc)) = GAssignS id_ e (GVerboseBinExpr op (unVerboseBinExpr lc) (unVerboseBinExpr rc)) +binExprVerbosity (GLetIsTrue id_ e (GBinExpr op lc rc)) = GLetIsTrue id_ e (GVerboseBinExpr op (unVerboseBinExpr lc) (unVerboseBinExpr rc)) +binExprVerbosity (GVerboseBinExpr op lc rc) = GVerboseBinExpr op (unVerboseBinExpr lc) (unVerboseBinExpr rc) +binExprVerbosity x = composOp binExprVerbosity x + +-- helper function for binExprVerbosity +unVerboseBinExpr :: Tree a -> Tree a +unVerboseBinExpr (GVerboseBinExpr op lc rc) = GBinExpr op lc rc +unVerboseBinExpr x = composOp unVerboseBinExpr x + +aggregatePredApp :: Tree a -> Tree a +aggregatePredApp tree@(GBinExpr op (GPredApp f arg) (GPredApp g arg')) = + if sameTree arg arg' + then GPredAppMany op (GListExpr [f,g]) arg + else tree +aggregatePredApp tree@(GVerboseBinExpr op (GPredApp f arg) (GPredApp g arg')) = + if sameTree arg arg' + then GPredAppMany op (GListExpr [f,g]) arg + else tree +aggregatePredApp x = composOp aggregatePredApp x + +flattenITE :: Tree a -> Tree a +flattenITE expr@GIfThenElse{} = + case collectITE expr of + ites@(_:_:_) -> GElif $ GListIfThen (rmElseFromFirst ites) + _ -> expr + where + rmElseFromFirst (GMiddleIfThen i t : rest) = GFirstIfThen i t : rest + rmElseFromFirst x = x +flattenITE x = composOp flattenITE x + +collectITE :: GExpr -> [GIfThen] +collectITE (GIfThenElse i t e@GIfThenElse{}) = GMiddleIfThen i t : collectITE e +collectITE (GIfThenElse i t e) = [GMiddleIfThen i t, GNilIfThen e] +collectITE e = [GNilIfThen e] + +flattenNestedAndOr :: Tree a -> Tree a +flattenNestedAndOr e@GBinExpr{} = composOp flattenNestedAndOr (flattenIfLongEnough e) +flattenNestedAndOr e@GVerboseBinExpr{} = composOp flattenNestedAndOr (flattenIfLongEnough e) +flattenNestedAndOr x = composOp flattenNestedAndOr x + +flattenIfLongEnough :: GExpr -> GExpr +flattenIfLongEnough e = + case orExprs of + (_:_:_) -> GApplyListOp GListOr (GListLExpr orExprs) + _ -> case andExprs of + (_:_:_) -> GApplyListOp GListAnd (GListLExpr andExprs) + _ -> e + where + orExprs = GcoerceListExpr <$> collectOr e + andExprs = GcoerceListExpr <$> collectAnd e + + collectOr :: GExpr -> [GExpr] + collectOr = \case + GBinExpr GOr left right -> collectOr left <> collectOr right + GVerboseBinExpr GOr left right -> collectOr left <> collectOr right + expr -> [expr] + + collectAnd :: GExpr -> [GExpr] + collectAnd = \case + GBinExpr GAnd left right -> collectAnd left <> collectAnd right + GVerboseBinExpr GAnd left right -> collectAnd left <> collectAnd right + expr -> [expr] + +-------------------------------- + +sameTree :: forall a. Gf (Tree a) => Tree a -> Tree a -> Bool +sameTree a b = show a == show b + isBool :: Expr -> Bool isBool = \case BinExpr Eq _ _ -> True @@ -154,27 +354,86 @@ parseLit = \case BoolLit bool -> GMkName $ GString $ show bool StringLit string -> GMkName $ GString $ T.unpack string -parseExpr :: N.Name -> Expr -> GExpr -parseExpr name = - let f = parseExpr name in \case +parseExpr :: NLGEnv -> N.Name -> Expr -> GExpr +parseExpr env name = + let f = parseExpr env name in \case Var var -> GVar (parseName var) Lit lit -> GLit (parseLit lit) + -- Totally generic transformation—treat unary minus differently from other unary functions + Unary UnaryMinus expr -> GUnaryMinusExpr (f expr) Unary op expr -> GUnary (parseUnaOp op) (f expr) - BinExpr op l r -> GBinExpr (parseBinOp op) (f l) (f r) + + -- Specific decisions about verbosity of binary operations + -- e.g. "x / y" + BinExpr op lc@Var{} rc@Var{} -> GBinExpr (parseBinOp op) (f lc) (f rc) + + -- e.g. "x / b's y" + BinExpr op lc@Var{} rc@Project{} -> GBinExpr (parseBinOp op) (f lc) (f rc) + + -- e.g. "a's x / y" + BinExpr op lc@Project{} rc@Var{} -> GBinExpr (parseBinOp op) (f lc) (f rc) + + -- e.g. "a's x / b's y" + BinExpr op lc@Project{} rc@Project{} -> GBinExpr (parseBinOp op) (f lc) (f rc) + + -- other BinExprs are "verbose" = newlines and stuff + BinExpr op lc rc -> GVerboseBinExpr (parseBinOp op) (f lc) (f rc) + + IfThenElse cond thn els -> GIfThenElse (f cond) (f thn) (f els) - FunApp fun args -> GFunApp (f fun) (GListExpr $ fmap f args) --- Record rows -> GRecord - Project record label -> GProject (f record) (parseName label) + + -- Basic arithmetic operations that have been defined as custom function + + FunApp (getName -> Just "div") [lc,rc] -> f (BinExpr Divide lc rc) + FunApp (getName -> Just "mult") [lc,rc] -> f (BinExpr Mult lc rc) + FunApp (getName -> Just "add") [lc,rc] -> f (BinExpr Plus lc rc) + + -- Basic arithmetic operation that is hardly domain-specific + -- Current linearization of Round takes Expr, Int + -- and just outputs the Expr instead of "Expr rounded into precision of Int decimals" + -- But this should be configurable. + FunApp (getName -> Just "round") [expr, prec] -> GRound (f expr) (f prec) + + + FunApp fun args -> if isPredicate fun + then f (PredApp fun args) + else case getAnnotation env (f <$> args) fun of + [(ann, i)] -> GFunApp1 ann (f $ args !! i) + [(ann1, i), (ann2, j)] -> GFunApp2 ann1 (f $ args !! i) ann2 (f $ args !! j) + _ -> GFunApp (f fun) (GListExpr $ fmap f args) + Project record label -> GOnlyFieldProject (f record) (parseName label) -- TODO: annotation to decide whether to print out the record name or only label? Fun md args body -> GFun (parseName name) (parseFunMetadata md) (GListName $ fmap parseName args) (f body) --- Let decl body -> Let decl (f body) Predicate md args body -> GPredicate (parseName name) (parseFunMetadata md) (GListName $ fmap parseName args) (f body) PredApp predicate args -> GPredApp (f predicate) (GListExpr $ fmap f args) Foldr combine nil over -> GFold (f combine) (f nil) (f over) Foldl combine nil over -> GFold (f combine) (f nil) (f over) --- Sig parents relations -> Sig parents (traverse f) (tions + Sig parents relations -> GSig (GListName $ fmap parseName parents) (GListExpr $ fmap f relations) + Let decl expr -> GLet (parseDecl env decl) (f expr) + Cons e1 e2 -> GConjExpr (GListExpr [f e1, f e2]) + List es -> GConjExpr (GListExpr $ fmap f es) + Record rows -> GConjExpr (GListExpr [GRecord (parseName rname) (f row) | (rname,row) <- rows]) --) StatementBlock statements -> undefined -- TODO x -> error [i|parseExpr: not yet implemented #{x}|] +-- TODO: This whole thing should come from external annotation +-- Not hardcoded into Haskell code (nor GF code) +-- NB. Indices start from 0, we just happen to have examples where 0th isn't used +getAnnotation :: NLGEnv -> [GExpr] -> Expr -> [(GString, Int)] +getAnnotation env args (getName -> Just name) = case name of + "default" -> [ (GString [i|if #{gfLin env $ gf $ head args} is uncertain, then|], 1) + , (GString "else", 0) ] + "instanceSumIf" -> [ (GString "adding up those of", 1) + , (GString "where", 2) ] + "instanceSum" -> [ (GString "adding up", 1) ] + _ -> [] +getAnnotation _ _ _ = [] +{- +The annotation needs to include the following: +- name of the function +- which of its arguments are used +- what text is put before/after which argument +- currently only puts stuff before argument, TODO also support after argument +-} parseTypeDecl :: N.Name -> DataDecl -> GTypeDecl