[-*- Mode: emacs-lisp -*-] [-----grammar (gz start (prog)) (gz prog (module)) (gz module (id language-pragma-opt exports imports topdecl-star ::pr("[[language-pragma-opt]]module [[id]] [[exports]] where{\n[[imports]]\n" "[[topdecl-star('',';\n','\n')]]}\n\n"))) (gz language-pragma ( :language-pragma f id-non-star j ::pr ("{-# LANGUAGE [[id-non-star('',',','')]] #-}\n"))) (gz exports (f export-star j ::pr("[[export-star('(',', ',')')]]")) (:export-everything ::pr(""))) (gz export (id) (f :module-export id j ::pr("module [[id]]")) ) (gz imports (f import-star j ::pr("[[import-star('',';\n',';\n')]]"))) (gz import(id ::pr( "import [[id]]")) (f :qualified (original-name ::is id) (new-name ::is id) j ::pr ( "import qualified [[original-name]] as [[new-name]]")) (f :specific id id-non-star j ::pr ("import [[id]][[id-non-star('(',',',')')]]")) ) (gz type-class (f decl-mark (class-name ::is id) :type-class context-opt id-non-plus f type-class-decl-star j j ::pr("class [[context-opt]][[class-name]] [[id-non-plus('',' ','')]] where{\n" "[[type-class-decl-star('',';\n','\n')]]}"))) (gz topdecl (decl) (data)(type-synonym)(newtype)(instance)(type-class)) (gz type-class-decl (type-signature)(decl)) (gz type-signature (f :tysig name ret-type-and-params j ::pr("[[name]] :: [[ret-type-and-params]]"))) (gz instance (f :instance (type ::is id) (name ::is simpletype) decls j ::pr ("instance [[type]] ([[name]]) where [[decls]]"))) [(gz instance (f :instance context-opt (type ::is id) simpletype-plus :x decls j ::pr ("instance [[context-opt]][[type]] [[simpletype-plus('(',')(',')')]] where [[decls]]")))] (gz newtype (f decl-mark id :newtype type-vars-opt constr deriving-opt j ::pr("newtype [[id]] [[type-vars-opt]] = [[constr]][[deriving-opt]]"))) (gz deriving (:deriving f id-non-plus j ::pr(" deriving [[id-non-plus('(',', ',')')]]"))) (gz id-non (id)) (gz type-synonym (f decl-mark id :type-synonym type-vars-opt type j ::pr("type [[id]] [[type-vars-opt]] = [[type]]"))) (gz data (f decl-mark id :data type-vars-opt constrs deriving-opt j ::pr("data [[id]] [[type-vars-opt]] = [[constrs]][[deriving-opt]]"))) (gz simpletype (f id-non-plus j ::pr ("[[id-non-plus('',' ','')]]"))) (gz type-vars (:args f id-non-star j ::pr ("[[id-non-star('',' ','')]]"))) (gz constrs(constr-star ::pr("[[constr-star('',' | ','')]]")) ) (gz field-type-and-param (f param type j ::pr("[[param]] :: [[type]]"))) (gz type-and-param ( f param type j ::pr("[[type]]"))) (gz constr(positional-constructor) (field-label-constructor) ) (gz field-label-constructor(f type-ctor :field field-type-and-param-star j ::pr("[[type-ctor]][[field-type-and-param-star('{',', ','}')]]"))) (gz decls ( decl-star ::pr("{[[decl-star('\n',';\n','\n')]]}\n"))) (gz context (:context f a-context-plus j ::pr ("[[a-context-plus('(',', ',')')]] => "))) (gz a-context [(f (type ::is id) id-non-plus j ::pr("[[type]] [[id-non-plus('',' ','')]]"))] (f (class ::is id) type-plus j ::pr("[[class]] [[type-plus('(',')(',')')]]")) ) (gz forall (:forall f id-non-plus j ::pr("forall [[id-non-plus('',' ','')]] . "))) (gz ret-type-and-params (type f type-and-param-star j forall-opt context-opt ::pr("[[forall-opt]][[context-opt]][[type-and-param-star('',' \x2d> ','')]]" (::c "if(my_type_and_param_star->v.size()>0)out(' \x2d> ');") "[[type]]"))) (gz decl (f decl-mark name :fun ret-type-and-params expr j ::pr("[[name]] :: [[ret-type-and-params]];\n" "[[name]]" (::c "for(many_trees::const_iterator pos = my_ret_type_and_params->my_type_and_param_star->v.begin();pos!= my_ret_type_and_params->my_type_and_param_star->v.end();++pos){" "const tr_type_and_param* t=dynamic_cast(*pos);" "assert(t);" "out(' ');" "t->my_param->print();" "}") " = [[expr]]")) (f decl-mark name :fun :no-sig ret-type-and-params expr j ::pr("[[name]]" (::c "for(many_trees::const_iterator pos = my_ret_type_and_params->my_type_and_param_star->v.begin();pos!= my_ret_type_and_params->my_type_and_param_star->v.end();++pos){" "const tr_type_and_param* t=dynamic_cast(*pos);" "assert(t);" "out(' ');" "t->my_param->print();" "}") " = [[expr]]")) (f decl-mark name :simple expr j ::pr("[[name]] = [[expr]]")) ) (gz name (id)) (gz positional-constructor ["this one is sketchy"] (type-ctor ::pr("[[type-ctor]]")) (f type-ctor typepls-opt j ::pr("[[type-ctor]][[typepls-opt]]")) (f :tuple type-plus j ::pr("[[type-plus('(',', ',')')]]")) ) (gz pattern (id) (f pattern-ctor pattern-star j ::pr ("([[pattern-ctor]] [[pattern-star('',' ','')]])")) (f pattern-ctor :fpat f fpat-star j j ::pr ("[[pattern-ctor]][[fpat-star('{',', ','}')]]")) (f :ptuple pattern-plus j [pattern-plus cuz :nil exists for empty lists] ::pr("[[pattern-plus('(',', ',')')]]")) (f :plist pattern-plus j [pattern-plus cuz :nil exists for empty lists] ::pr("[[pattern-plus('\x5b',', ','\x5d')]]")) (f :pchar astring j ::pr("(\x27[[astring]]\x27)")) (f :pstring astring j ::pr("\x22[[astring]]\x22")) (f :as id pattern j ::pr("[[id]]@[[pattern]]")) ) (gz pattern-ctor (id) (:cons ::pr ("(:)")) (:nil ::pr ("[]"))) (gz fpat (f (variable ::is id) pattern j ::pr("[[variable]] = [[pattern]]"))) (gz type (f :fn ret-type-and-params j ::pr ("([[ret-type-and-params]])")) (:unit ::pr("()")) (positional-constructor)) (gz typepls (paren-type-plus)) (gz paren-type (type ::pr( "([[type]])")) (f :strict type j ::pr("!([[type]])")) (f :generic id j ::pr (" [[id]] "))) (gz type-ctor(id)(:list ::pr ("[]"))(:nondet ::pr ("[]"))) (gz param (pattern)) (gz qastring (astring ::pr("\x22[[astring]]\x22"))) (gz expr (id) (:mcons ::pr ("(:)")) [(:nil ::pr ("[]"))] [(f :pipe expr-plus j ::pr[("[[expr-star('(',' $ ',')')]]")] ( (::c "for(many_trees::const_iterator pos = my_expr_plus->v.begin();" "pos!=my_expr_plus->v.end();++pos){") "(" (::c "(*pos)->print();" "}") (::c "for(many_trees::const_iterator pos = my_expr_plus->v.begin();" "pos!=my_expr_plus->v.end();++pos){") ")" (::c "}") ) )] (f :join expr-plus j ::pr("[[expr-plus('(',' >>= ',')')]]")) (f :rpipe expr-plus j ::pr[("[[expr-star('(',' $ ',')')]]")] (["http;//gcc.gnu.org/bugzilla/show_bug.cgi?id=11729"] (::c "for(many_trees::reverse_iterator pos = my_expr_plus->v.rbegin();" "pos!=my_expr_plus->v.rend();++pos){") "(" (::c "(*pos)->print();" "}") (::c "for(many_trees::const_iterator pos = my_expr_plus->v.begin();" "pos!=my_expr_plus->v.end();++pos){") ")" (::c "}") ) ) (f :rcompose expr-plus j ::pr [("[[expr-plus('(',' . ',')')]]")] ("(" (::c "for(many_trees::reverse_iterator pos = my_expr_plus->v.rbegin();" "pos!=my_expr_plus->v.rend();++pos){") (::c "if(pos!=my_expr_plus->v.rbegin())") " . " (::c "(*pos)->print();" "}") ")" ) ) (f :cc expr-star j ::pr ("[[expr-star('(',' ++ ',')')]]")) (qastring) (f :lit astring j ::pr("[[astring]]")) (f :ty type expr j ::pr("([[expr]] :: [[type]])")) (f (fun-name ::is expr) expr-star j ::pr ("([[fun-name]][[expr-star(' ',' ','')]])")) [(f :construct ctor expr-star j ::pr ("([[ctor]] [[expr-star('',' ','')]])"))] (f :do stmt-star j ::pr("(do{\n[[stmt-star(' ','\n ','\n')]]})")) (f :case expr alt-star j ::pr("(case [[expr]] of {\n[[alt-star(' ',';\n ','\n')]]})")) (f :case expr alt-star :else (underbar ::is expr) j ["the else is there so the grammar does not have a reduce/reduce conflict"] ::pr("(case [[expr]] of {\n[[alt-star(' ',';\n ',';\n')]]" " _ -> [[underbar]]\n" "})")) (f :lcase alt-star j ::pr("(\x5clambda_case_var ->" "case lambda_case_var of {\n" "[[alt-star(' ',';\n ','\n')]]})")) (f :lcase alt-star :else (underbar ::is expr) j ::pr("(\x5clambda_case_var ->" "case lambda_case_var of {\n" "[[alt-star(' ',';\n ',';\n')]]" " _ -> [[underbar]]\n" "})")) (f :let decl-star expr j ::pr("(let {[[decl-star('\n',';\n','\n')]]}\n in [[expr]])")) (f :rlet expr decl-star j ::pr("(let {[[decl-star('\n',';\n','\n')]]}\n in [[expr]])")) (f :cfd expr assignments-star j ::pr("([[expr]][[assignments-star('{',', ','}')]])")) [(f :compose (a ::is expr) (b ::is expr) j ::pr("((.)[[a]] [[b]])"))] [(:compose ::pr ("(.)"))] [(f :compose expr-plus j ::pr ("[[expr-plus('(',' . ',')')]]"))] (f :mlist expr-star j ::pr("[[expr-star('\x5b',', ','\x5d')]]")) (f :cons-list expr-star j ::pr("[[expr-star('(',':',')')]]")) (f :mtuple expr-star j ::pr("[[expr-star('(',', ',')')]]")) (:nothing ::pr ("()")) (f :lambda name ret-type-and-params expr j ::pr("(let {[[name]] :: [[ret-type-and-params]];\n" "[[name]]" (::c "for(many_trees::const_iterator pos = my_ret_type_and_params->my_type_and_param_star->v.begin();pos!= my_ret_type_and_params->my_type_and_param_star->v.end();++pos){" "const tr_type_and_param* t=dynamic_cast(*pos);" "assert(t);" "out(' ');" "t->my_param->print();" "}") " = [[expr]]} in [[name]])")) (f :lambda-simple id-non expr j [recommended only for reordering arguments to functions and other simple expressions] [only one variable to keep it simple] ::pr ("(\x5c[[id-non]] -> [[expr]])")) ) (gz assignments (f id expr j ::pr("[[id]] = [[expr]]"))) (gz stmt (expr ::pr("[[expr]];")) (f ":=" pattern type expr j ::pr("[[pattern]] :: [[type]] <- [[expr]];")) (f :dlet decl-star j ::pr ("let {[[decl-star('\n',';\n','\n')]]};")) ) (gz alt (f pattern expr-or-gpat j ::pr("[[pattern]][[expr-or-gpat]]"))) (gz expr-or-gpat (expr ::pr ("-> [[expr]]")) (where-opt :gpats pred-expr-star [silly lookahead limitation] ::pr ("\n[[pred-expr-star('','','')]] [[where-opt]]" ))) (gz pred-expr ( f (pred ::is expr) (do ::is expr) j ::pr ("| [[pred]]\n -> [[do]]\n"))) (gz where (:where decls ::pr ("where [[decls]]"))) (gz decl-mark (":")) ] Main :language-pragma ( ScopedTypeVariables [PatternSignatures] GeneralizedNewtypeDeriving ) (main) ( ) (: main :fun (IO :unit) () (:join getContents (:rcompose bubble-babble putStrLn ))) (: one-index :fun a ((l(:list a))(i Int)) (!! l (pred i))) (: checksum-series :fun (:list Int) ((d(:list Int))) (:let (: c :fun (:list Int)() (:mcons 1 (map f (enumFrom 2)))) (: f :fun Int ((n Int)) (mod-flip 36 (sum (:mlist (* 5 (one-index c (pred n))) (* 7 (one-index d (- (* 2 n) 3))) (one-index d (- (* 2 n) 2)))))) c)) (: mod-flip :fun (:fn Int ((x Int)(y Int))) () (flip mod)) (: shr-flip :fun Int ((x Int)(y Int)) [y/2^x] (div y (^ 2 x))) (: fa :fun Int ((d Int)(c Int)) (:rpipe d (shr-flip 6) (mod-flip 8) (+ c) (mod-flip 6)) ) (: fb :fun Int ((d Int)(c Int)) (:rpipe d (shr-flip 2) (mod-flip 16)) ) (: fc :fun Int ((d Int)(c Int)) (:rpipe d (mod-flip 4) (+ (div c 6)) (mod-flip 6)) ) (: full-tuple :fun (:list Int) ((d3 Int)(d2 Int)(c Int)) (:mlist (fa d3 c) (fb d3 c) (fc d3 c) (:rpipe d2[not 3] (shr-flip 4) (mod-flip 16)) (:rpipe d2 (mod-flip 16)) ["another bug?"] )) (: even-partial-tuple :fun (:list Int)((c Int)) (:mlist (fa 0 c) 16 (fc 0 c) )) (: odd-partial-tuple :fun (:list Int)((d Int)(c Int)) (:mlist (fa d c) (fb d c) (fc d c))) (: vowel :fun String () "aeiouy") (: conso :fun String () "bcdfghklmnprstvzx") (: encode-tuple :fun String ((t(:list Int))) (:case t ((:plist(a)(b)(c)(d)(e)) (:mlist (!! vowel a) (!! conso b) (!! vowel c) (!! conso d) (head "-") (!! conso e) )) ((:plist(a)(b)(c)) (:mlist (!! vowel a) (!! conso b) (!! vowel c) )) )) (: make-t :fun (:list(:list Int)) ((d (:list Int))) (:rlet (++ (map t (enumFromTo 1 (div k 2))) (:mlist partial-tuple)) (: k :fun Int ()(length d)) (: c :fun (:list Int)() (checksum-series d)) ["I think the checksum series goes one more term than the spec says"] (: partial-tuple :fun (:list Int) () (:let (: lastc :fun Int () (one-index c (+ 1 (div k 2)))) (:case (mod k 2) (0 (even-partial-tuple lastc)) (1 (odd-partial-tuple (last d) lastc)) ))) (: t :fun (:list Int) ((i-half Int)) (:let (: i2 :fun Int () (* 2 i-half)) (full-tuple (one-index d (- i2 1)) (one-index d (- i2 0)) (one-index c i-half)))) ["bug in spec?"] )) (: bubble-babble :fun String ((d String)) (:cc "x" (:rpipe d (map fromEnum) make-t (map encode-tuple) concat) "x"))