[-*- Mode: emacs-lisp -*-]
[-----grammar
(gz start (prog))
(gz prog (module))
(gz module (id language-pragma-opt exports imports topdecl-star
::pr("[[language-pragma-opt]]"
"{-\n"
"Copyright 2011 Ken Takusagawa\n"
"This program is free software: you can redistribute it and/or modify\n"
"it under the terms of the GNU Affero General Public License as published by\n"
"the Free Software Foundation, either version 3 of the License, or\n"
"(at your option) any later version.\n\n"
"This program is distributed in the hope that it will be useful,\n"
"but WITHOUT ANY WARRANTY; without even the implied warranty of\n"
"MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n"
"GNU General Public License for more details.\n\n"
"You should have received a copy of the GNU Affero General Public License\n"
"along with this program. If not, see .\n"
"-}\n\n"
"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('(',',',')')]]"))
(f :hiding import id-non-star j
::pr("[[import]] hiding[[id-non-star('(',',',')')]]")
[dunno if this will work for complicated cases]
)
)
(gz type-class (f decl-mark (class-name ::is id) :type-class context-opt id-non-plus type-class-decl-star 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 decl-mark name :tysig 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 (name ::is id) :newtype type-vars-opt constr-or-wrap deriving-opt j
::pr("newtype [[name]] [[type-vars-opt]] = [[constr-or-wrap{my_name}]][[deriving-opt]]")))
(gz constr-or-wrap ::gets "tr-id*{name}" (constr)(wrap-constr ::pr("[[wrap-constr{name}]]")))
(gz wrap-constr ::gets "tr-id*{name}"
( :wrap id
::pr(
(::c "name->print();")
" {un_"
(::c "name->print();")
" :: [[id]]}")))
(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 haddock-opt ret-type-and-params expr j
::pr("[[haddock-opt]]"
"[[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 ("[]"))
(:paren id ::pr("([[id]])")) ["workaround for Qualified parenthesized constructors"]
)
(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]])"))
(:inforall f id-non-plus j type ::pr("(forall [[id-non-plus('',' ','')]] . [[type]])"))
(: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 :chain astring expr-plus j ::pr
([("[[expr-plus('(',' op ',')')]]")]
"("
(::c "for(many_trees::const_iterator pos=my_expr_plus->v.begin();pos!=my_expr_plus->v.end();++pos){")
(::c "if(pos!=my_expr_plus->v.begin()){")
"[[astring]]"
(::c "}(*pos)->print();}")
")"
))
(f :join expr-plus j ::pr("[[expr-plus('(',' >>= ',')')]]"))
(f :cc expr-star j ::pr ("[[expr-star('(',' ++ ',')')]]"))
(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
("("
(::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();" "}")
")"
)
)
(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 :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 :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]])"))
(f :field-edit expr field-edit-plus j
[plus is required by Haskell]
::pr("([[expr]][[field-edit-plus('{',',','}')]])"))
)
(gz field-edit (f id expr j ::pr ("[[id]] = [[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 :let-many decl-star j ::pr ("let {[[decl-star('\n',';\n','\n')]]};"))
(f :dlet id type expr j ::pr ("let {" " [[id]] :: [[type]];" " [[id]] = [[expr]];" "};"))
)
(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 (":"))
(gz haddock ( :doc f docline-star j
::pr ("[[docline-star('\n\x7b\x2d |','\n',' \x2d\x7d\n')]]")))
(gz docline (astring))
]
Main :language-pragma
(
ScopedTypeVariables
[GeneralizedNewtypeDeriving]
[RankNTypes]
)
(main)
(
Data.List
Data.Maybe
Control.Monad
)
(: main :fun (IO :unit) ()
(:do
(putStrLn "=============test1")
test1
(putStrLn "=============test2")
test
))
(: Btape :type-synonym (Listzipper Bool))
(: btape-initial :fun Btape ()
(infinite-repeat False))
(: siblings-blank :fun (Siblings a) ((x a))
(:mtuple (repeat x)(repeat x)))
(: infinite-repeat :fun (Listzipper a)((x a))
(Listzipper x (siblings-blank x)))
(: tape-left :fun (Listzipper a)
(((Listzipper middle (:ptuple (:cons h t)right))(Listzipper a)))
(Listzipper h (:mtuple t (:mcons middle right))))
(: tape-right :fun (Listzipper a)
(((Listzipper middle (:ptuple left (:cons h t)))(Listzipper a)))
(Listzipper h (:mtuple (:mcons middle left)t)))
(: Tt :type-synonym (Listzipper Btape))
(: tt-initial :fun Tt ()(infinite-repeat btape-initial))
(: left :fun Zipper (((Zipper n parents)Zipper))
(Zipper (tape-left n) parents))
(: right :fun Zipper (((Zipper n parents)Zipper))
(Zipper (tape-right n) parents))
(: up :fun Zipper (((Zipper n (:cons parent grandparents)) Zipper))
(Zipper (Listzipper (Internal n) parent) grandparents))
(: down :fun (m Zipper) (((Zipper(Listzipper n sibs)parents)Zipper))
:context((Monad m))
(:case n
((Internal t)(return(Zipper t(:mcons sibs parents))))
:else (fail "cannot descend leaf")
))
(: jdown :fun Zipper ((z Zipper))
(:rpipe z down fromJust))
(: get-node :fun Node (((Zipper(Listzipper n _)_)Zipper))n)
(: read-tape :fun (m Bool) ((z Zipper))
:context((Monad m))
(:case (get-node z)
((Leaf x)(return x))
:else(fail "cannot read internal node")))
(: is-leaf :fun Bool ((n Node))
(:case n((Leaf _)True)
:else False))
(: write-node-bool :fun (m Node)((n Node)(x Bool)):context((Monad m))
(:case n((Leaf _)(return(Leaf x)))
:else (fail "error: tried to write internal node")))
(: write-tape-bool :fun (m Zipper)
((x Bool)((Zipper(Listzipper n sibs)parents)Zipper))
:context((Monad m))
(:do
(:= new Node (write-node-bool n x))
(return (Zipper(Listzipper new sibs)parents))
))
(: set-tape :fun Zipper ((z Zipper))
(:rpipe z (write-tape-bool True) fromJust))
[never have to worry about empty lists for infinite lists]
(: Listzipper :data :args(a) (Listzipper a (Siblings a)))
[not enforcing that all nodes at the same level are the same kind]
(: Node :data (Leaf Bool)(Internal Tape))
(: Tape :type-synonym (Listzipper Node))
(: Zipper :data (Zipper Tape (:list (Siblings Node))))
(: Siblings :type-synonym :args(a) (:tuple(:list a)(:list a)))
(: empty-regular-tape :fun Tape ()(infinite-repeat (Leaf False)))
(: first-siblings :fun (Siblings Node)()
(siblings-blank (Internal empty-regular-tape)))
(: higher-tape :fun Tape ((t Tape))
(infinite-repeat (Internal t)))
(: get-sibs :fun (Siblings a)(((Listzipper _ sibs)(Listzipper a)))sibs)
(: initial-sibs :fun (:list (Siblings Node))()
(:rpipe empty-regular-tape
(iterate higher-tape)
tail
(map get-sibs)))
(: initial-zipper :fun :doc
("Infinite tapes of Falses are all on the same bottom level."
"Every level up, each cell is itself an infinite tape.")
Zipper ()
(Zipper empty-regular-tape initial-sibs))
(: test1 :fun (IO :unit)()
(:do
(:dlet z Zipper initial-zipper)
(:let-many
(: p :fun (IO :unit)((z Zipper))
[(:rpipe z read-tape print)]
(print
(:ty (Maybe Bool) (read-tape z)))
))
(:rpipe z p)
(:rpipe z left p)
(:rpipe z up p)
(:rpipe z up jdown p)
(:rpipe z left up jdown p)
(:rpipe z up left jdown p)
(:rpipe z set-tape up up jdown jdown p)
(:rpipe z set-tape left right p)
(:rpipe z set-tape left up left up left right jdown right jdown right p)
))
(: not-flat-sibs :fun (Siblings Node)()
(siblings-blank (Leaf False)))
(: not-flat-initial-zipper :fun
:doc("The current tape is at the base on an infinite tree."
"Going up yields a tape with Falses on either side, and an infinite tape under the current cell")
Zipper ()
(:rpipe False Leaf siblings-blank repeat (Zipper empty-regular-tape))
)
(: write-tape :fun :doc ("Replace the current cell with an empty subtape") Zipper
(((Zipper(Listzipper _ sibs)parents)Zipper))
(Zipper(Listzipper (Internal empty-regular-tape) sibs)parents))
(: test :fun (IO :unit)()
(:do
(:dlet z Zipper not-flat-initial-zipper)
(:let-many
(: p :fun (IO :unit)((z Zipper))
(print
(:ty (Maybe Bool)(read-tape z)))))
(:rpipe z p)
(:rpipe z write-tape p)
(:rpipe z left set-tape right write-tape jdown p)
(:rpipe z left set-tape right write-tape jdown up left p)
(:rpipe z left set-tape up left up right left jdown right jdown p)
))