(*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)
(
System.Environment
Data.Time
Data.List
Network.CGI
Text.Printf
Factor_cmd
Control.Monad
System.Locale
)
(: cgi-main :fun (CGI CGIResult)()
(:do
(:= yr (Maybe Integer) (readInput "yr"))
(:= mo (Maybe Int) (readInput "mo"))
(:= dy (Maybe Int) (readInput "dy"))
(:= offset (Maybe Integer) (readInput "offset"))
(:= action (Maybe String) (getInput "action"))
(:case (:mtuple yr mo dy offset)
((:ptuple(Just yr)(Just mo)(Just dy)(Just offset))
(:rlet
(:join (liftIO (f yr mo dy offset)) output)
(: f :fun (:fn(IO String) ((yr Integer)(mo Int)(dy Int)(offset Integer)))()
(:case action
((Just(:pstring "list"))gen-list)
:else gen-test))))
:else
(outputInternalServerError (:mlist (show yr)(show mo)(show dy)(show offset))))
[only one output line is permitted, the last one takes precedence]
))
(: main :fun (IO :unit)()
(runCGI (handleErrors cgi-main))
)
(: main2 :fun (IO :unit)()
(:do
(:= args (:list String) getArgs)
(:join
(gen-test (read (!! args 0)) (read (!! args 1))(read (!! args 2)) (read (!! args 3)))
putStrLn
)))
(: gen-test :fun (IO String)((yr Integer)(mo Int)(dy Int)(offset Integer))
(:do
(:dlet start Day (fromGregorian yr mo dy))
(:= today Day (:join getToday
(:rcompose (addDays offset) return)))
(:dlet interval Integer (diffDays today start))
(:dlet today-string String (:cc "\n"))
(:= info-today String
(:case (compare interval 0)
(EQ (return "You are born today!"))
(LT (return "Requested date is in the future."))
:else
(:do
(:= fs (:list Integer) (factor interval))
(:case (length fs)
(0 (return "You are 1 day old."))
(1 (do-prime-day today))
:else
(find-from-composite today interval fs)
))))
(:= nextp String (:case (compare interval 0)
(LT (return "") )
:else (next-prime-day interval today) ))
(:rpipe
(:cc "Peek tomorrow
\n"
today-string "" info-today "
"nextp"
\n"
(:case (its-your-birthday today start)
(True "Also, happy birthday!
\n")
:else "")
(:case offset
(0 "Bookmark this page to automatically recalculate whenever you open the bookmark.
\n")
:else "")
"\n
\n"
"List all your Prime Days this year
"
"Back to Prime Day Calculator
"
"Leave comments on this blog post
"
"View source code
"
)
(create-html (:cc (show start) " birthday Prime Day calculator"))
return)
))
(: getToday :fun (IO Day) ()
(:join
getZonedTime (:rcompose zonedTimeToLocalTime localDay return)))
(: make-day :fun Day ((x(:list String)))
(:case x
((:plist(yr)(mo)(dy))(fromGregorian (read yr)(read mo)(read dy)))
:else
(error (:cc "expecting [year,month,day], but got " (show x)))))
(: do-prime-day :fun (IO String)((today Day))
(return (:cc
"Happy Prime Day!You have lived a prime number of days, as of "
(show-day today)".")))
(: find-from-composite :fun (IO String)((today Day)(total Integer)(factors(:list Integer)))
(:do
(:dlet dm (:tuple Integer Integer) (divMod total (last factors)))
(:dlet last-chapter-ago Integer (fst dm))
(:dlet last-chapter-start Day (addDays (negate last-chapter-ago) today))
(:case (snd dm)
(0 (return :nothing))
:else (error "did not divide cleanly"))
[(putStrLn (:cc "Composite " (show total)" = " (show factors)))]
(return (:cc "Happy Composite Day!
"
"As of today, " (show-day today) ", your life may be divided into exactly "
(:rpipe factors last show)
" chapters"
" of " (show last-chapter-ago) " days each."
[", each an equal number of days."]
"
The latest chapter started on "
(show-day last-chapter-start)
" and ended yesterday. The next chapter begins today!"
))
))
(: plural :fun String ((i Integer))
(:case i
(1 "")
:else "s"))
(: next-prime-day :fun (IO String) ((total Integer)(today Day))
[(:= np Day (:join (next-prime total) (:rcompose (- total) negate ((flip addDays) today) return)))]
(:do
(:= np Integer (next-prime (+ 1 total)))
(:dlet interval Integer (- np total))
(:dlet the-day Day (addDays interval today))
(return (:cc "Your next Prime Day is "
(:case interval
(1 "tomorrow")
:else
(:cc "in "(show interval)" days")
)", on "(show-day the-day)
".
"
(:case (compare total 0)
(GT
(:cc
"Your average spacing between Prime Days is "
(printf "%.4f" (:ty Double (:rpipe total fromInteger log )))
" days."))
:else "")
))
))
(: create-html :fun String ((title String)(body String))
(unlines (:mlist ""
(:cc "
" title "")
body
" ")))
(: gen-list :fun (IO String)( (yr Integer)(mo Int)(dy Int) (offset Integer))
(:do
(:dlet start Day (fromGregorian yr mo dy))
(:= today Day getToday)
(:dlet target Integer (:rpipe today get-year (+ offset)))
(:= prime-days (:list Day) (get-prime-days start target))
(:let-many
(: link :fun String ((offset Integer))
(:cc
"\"primeday.cgi?action=list"
"&yr="(show yr)
"&mo="(show mo)
"&dy="(show dy)
"&offset="(show offset)
"\"")))
(return (create-html (:cc "Your Prime Days for "(show target))
(:cc
"Your Prime Days for "(show target)"
\n"
(:rpipe
prime-days
(map show-day)
(intersperse "
\n")
concat)
"
\n"
"Previous year - "
"Next year"
"
"
"\n
Back to Prime Day Calculator
"
"View source code"
)))
))
(: get-year :fun Integer ((d Day))
(:case (toGregorian d)
((:ptuple yr _ _)yr)))
(: days-of-the-year :fun (:list Day)((yr Integer))
(:rlet
(takeWhile this-year (enumFrom (fromGregorian yr 1 1)))
(: this-year :fun Bool ((d Day))
(== yr (get-year d)))))
(: is-prime-day :fun (IO Bool) ((start Day)(today Day))
(is-prime (diffDays today start)))
(: get-prime-days :fun (IO (:list Day)) ((start Day)(yr Integer))
(filterM (is-prime-day start) (days-of-the-year yr)))
(: its-your-birthday :fun Bool ((x Day)(y Day))
(:case (:mtuple (toGregorian x)(toGregorian y))
((:ptuple(:ptuple _ xm xd)(:ptuple _ ym yd))
(&& (== xm ym)(== xd yd)))))
(: show-day :fun String ((d Day))
(:cc (show d) " "(formatTime defaultTimeLocale "%A" d) ))