prosidy
/
prosidy
1
0
Fork 1
Code Issues 1 Pull Requests Releases Wiki Activity
Browse Source

Start cleaning up prosidyc a touch

master
Alex Feldman-Crough 1 year ago
parent
b0378e241b
commit
a2441464aa
16 changed files with 590 additions and 573 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 169
      .ghc.environment.x86_64-linux-8.6.5
  2. 19
      .hlint.yaml
  3. 38
      src/poetic/Main.hs
  4. 159
      src/prosidy-manual/Prosidy/Manual.hs
  5. 6
      src/prosidy-manual/Prosidy/Manual/TableOfContents.hs
  6. 1
      src/prosidy-manual/prosidy-manual.cabal
  7. 263
      src/prosidy-markup/Main.hs
  8. 68
      src/prosidy-markup/syntax-guide.pro
  9. 2
      src/prosidy/Prosidy.hs
  10. 31
      src/prosidy/Prosidy/Parse.hs
  11. 76
      src/prosidy/Prosidy/Source.hs
  12. 37
      src/prosidy/Prosidy/Types.hs
  13. 267
      src/prosidyc/Prosidy/Compile.hs
  14. 13
      src/prosidyc/Prosidy/Compile/Internal/Eval.hs
  15. 13
      src/prosidyc/Prosidy/Compile/Internal/Spec.hs
  16. 1
      src/prosidyc/prosidyc.cabal

169
.ghc.environment.x86_64-linux-8.6.5
View File

@ -1,169 +0,0 @@
-- This is a GHC environment file written by cabal. This means you can
-- run ghc or ghci and get the environment of the project as a whole.
-- But you still need to use cabal repl $target to get the environment
-- of specific components (libs, exes, tests etc) because each one can
-- have its own source dirs, cpp flags etc.
--
clear-package-db
global-package-db
package-db /home/alex/.cabal/store/ghc-8.6.5/package.db
package-db dist-newstyle/packagedb/ghc-8.6.5
package-id ansi-terminal-0.10.2-eb5a0374566fbec86fbb30c8199b3548bcc6893e19daf660ba94ef1746fdfc90
package-id base-4.12.0.0
package-id ghc-prim-0.5.3
package-id rts
package-id integer-gmp-1.0.2.0
package-id colour-2.3.5-11d8a9d0f1dd817600055ee7992da3be937d74157c6f96d6f36a7d34f9622a2c
package-id ansi-wl-pprint-0.6.9-7585bb10f507337b515ae28bfa0df7fabd1bac4d786cba3bf91c68a2e5b99181
package-id fast-logger-3.0.0-83d9c5ec024c66b7d10ffd04dd1a391209bfb18153fb7b0517b246e737707a3b
package-id array-0.5.3.0
package-id auto-update-0.1.6-98d10e8ce5e7e536de6a6d8df954db48dad48614f7863699b472384743e5a67e
package-id bytestring-0.10.8.2
package-id deepseq-1.4.4.0
package-id directory-1.3.3.0
package-id filepath-1.4.2.1
package-id time-1.8.0.2
package-id unix-2.7.2.2
package-id easy-file-0.2.2-92959ba478d985b735ee481b34063b4e8efdd2296cd24868cf663c413bac4e35
package-id text-1.2.4.0-6a64a71c95fbc671920ed3189029bc8e7a37784468705530c021e47f6c20c191
package-id binary-0.8.6.0
package-id containers-0.6.0.1
package-id template-haskell-2.14.0.0
package-id ghc-boot-th-8.6.5
package-id pretty-1.1.3.6
package-id unix-compat-0.5.2-e8c0930470a3a86997ae9007ace019f1e92a2c46b634fabc805da56a407bfa40
package-id unix-time-0.4.7-14e71c2afb8f9ed1844ba0233d174ad63fbf20b3551ea6cb3ddc943371523497
package-id old-time-1.1.0.3-3fbbb271748fe85ec95f6d8873c8c4a7156105e6a65559d42d01837f279fc17b
package-id old-locale-1.0.0.7-58671cc4ea8d5b273ae350b66f0eaf77474e14edfbf3ee86adbed945f34aaccd
package-id hakyll-contrib-prosidy-0.0.1.0-inplace
package-id hakyll-4.13.0.1-006d94c43bf01abf22a230606af4e4f64020afbc1e1b48d4f9f0b43dc160b36e
package-id blaze-html-0.9.1.2-ad79b70f90accd2586f0666301841cdfbec487acdf10efe19098f403b2d6c94b
package-id blaze-builder-0.4.1.0-f7bd132eab7dd74c3b53e3f9d01f9200aef9c1b91bd827cf090255d8c746f796
package-id blaze-markup-0.8.2.3-e2df728971177f9e408c100ae0198d1d892e9a81a715fa827e2f180a32133e29
package-id cryptohash-0.11.9-9a6602af89d99e4338b83f33c68529c6f369938324b63e6fee296999a207c040
package-id byteable-0.1.1-6548e4c21697b16f145fac52ca0e5f13a743cc015d726323602efed317a52cec
package-id cryptonite-0.26-79a12060bfb40c8d445368eab392b5062c96974e58be40bf8b1d5f91b06736ba
package-id basement-0.0.11-38532f63ac41ee25f79180d0aebc5d51a7f85240f3af4570924ee715119bffbf
package-id memory-0.15.0-549285929d34c97b7a5c17bb2fd3c145c7ac71ad64e65ed54027efa8e974e327
package-id data-default-0.7.1.1-ccc6450ed34c0e987777ce21e9835b41580a9dc150c0a4f802ed2f6605c500ae
package-id data-default-class-0.1.2.0-01d59e93053477e5cb5ca050a336f3368653512a1c2f97404c571bfb92df8b65
package-id data-default-instances-containers-0.0.1-76921bf40e996a3fea9e44cb467b70a5a93a585ccca9fc015f16c599db0f62e8
package-id data-default-instances-dlist-0.0.1-896b2116fba54c2a2af378c0f0169cb2a97030a62c54212a1ddac7225a2e2a06
package-id dlist-0.8.0.7-da03f2ce7442c62f1f5b68ddf986c090639399cb6078c8a1e5f2a16b1622035c
package-id data-default-instances-old-locale-0.0.1-a48bc854e512f8954f69cceafedfe169a8b37a4587bdc0e64d93ff0d89467945
package-id file-embed-0.0.11.1-4d4bf2c711a9f6b86b78415058da50ab1ccc21e25bc487528f36b0d6afb8a456
package-id fsnotify-0.3.0.1-4f6b7a36f4f228ae8c55957ebd4868f1115546bdcc7f7bf85bc7677bfaed3aaa
package-id async-2.2.2-2b9e19a9330da018ae63bcb6812f19775efaee286c07fe900152bc90ef7cddf6
package-id hashable-1.2.7.0-21fb2b38319e2d18c888022b0f688a40c224dfb23fadb735d065e59bca28f559
package-id stm-2.5.0.0-e049910490d4e2ba21e661ca904b81c40b1de7bb9f63251965dcca509de0a39f
package-id hinotify-0.4-2f062a25ce01166fb608bd9ef2e8e49febbdbe69a0d16e60dd26ac8db4ae7e7c
package-id shelly-1.9.0-7b36643056ff92013f919d37312362432610987cb6e925eb99e370126a9bf2b2
package-id enclosed-exceptions-1.0.3-d26b7792cef774ec6feb5b1e7fa342efcf7e07e33ec2fa415ecb8e80a74907f9
package-id lifted-base-0.2.3.12-3825944fb4403aecc3c2196af285a4e7ac5d527f34a1036febd3d88997b3f811
package-id monad-control-1.0.2.3-4285a3a6e25327905f1acc5cfce445597c51813a3eef9e04f569adde766e33f5
package-id transformers-0.5.6.2
package-id transformers-base-0.4.5.2-e7e33e1c834cbce84b56a49a06a45f9404b89d7651e939617df5cc18fc5be51e
package-id base-orphans-0.8.1-99dc1c0697d9413d421778aa6eea34823901c0f8c76b5e04ddda8ad1918c36df
package-id transformers-compat-0.6.5-399db18553cb81c91cd9653bf5f7a848415a4c527c693fdb86c36121c7d98202
package-id exceptions-0.10.4-9e7e4aa3377e742622a393ae806f6b4209631c9f59ce95f2730d6f14314d8e46
package-id mtl-2.2.2-69bfbf038a9b16049174c8702d4d3c7d25bc6b377e4134d85103648ca4ef4823
package-id lifted-async-0.10.0.4-0595d2471f2a9110f4b60cee6b4a35a5cd3c12a1dc090dc06c059fce0ad97461
package-id constraints-0.11.2-e34e43c6a09cf182cbbe3c4be5d3d1d37563801df30ab0ab40261596be362f0a
package-id semigroups-0.19.1-56347f200f9be7b7a03a55f212a5043cebf270cd13617b68a03df3d192253afa
package-id type-equality-1-4c3d65a37b12c32f5eac7a07002b8fddce3573b3fb8bf2442ddda171105eec25
package-id process-1.6.5.0
package-id http-conduit-2.3.7.3-ccd049c05ce18943e860f6839f26697222c8105d77af7175a1dcb2876b7c0362
package-id aeson-1.4.6.0-cf2dcc0e3e6db2331aefb4379f226a1081a2a2ddb733d717ac5da53a5bde3763
package-id attoparsec-0.13.2.3-a4b8619ef397033935da571305a489f7bf54aa3c5ea0ed2183c210c6a84c36e1
package-id scientific-0.3.6.2-f656a28d32f0c18391c8a48c1b9f70822bcef217b5621b60297bd09cf64f17bf
package-id integer-logarithms-1.0.3-d7222ca945adf334fa850ee737a78c4927440073ecb63bb967e413065b3448d4
package-id primitive-0.7.0.0-e340afa20c7e9a1f3d985b3769a1ffd567535f95b3520f2c4e6c89df59b0cc63
package-id base-compat-0.11.0-116755de95c7b772c47d8c705e8b92853bc497eb64a3bb6d314ac21b57789b3f
package-id tagged-0.8.6-2f19f3c6c44e30ab01a22df2c8ea1e0877504211be6c1093389ad03acd021567
package-id th-abstraction-0.3.1.0-e3ed11a231372a062757e3ff7ba5356b9e56168d1b4b15e38e17a473cf6cf0a1
package-id time-compat-1.9.2.2-fba5d329eeec079337bb3cf6e669b8238db7782dacd4b43e77fcd02e9a3a5957
package-id unordered-containers-0.2.10.0-3d412cb9402016c80ece9eabe38397e5cb111c0ca6dbe876d52fc5c7f40593e4
package-id uuid-types-1.0.3-e408aa2c0edd3779e2bcbf385d0f497067c2679f7ba4b5f79f0b684f2af1f6fa
package-id random-1.1-63aa7c3c583465efc9380b3e51afd52f388da2d7f7591ed7ed7eff3246a64ce6
package-id vector-0.12.0.3-cd09c2557f0567a02d9f4aab823c713e340fb052681a0af44c168a4b80c8f1cd
package-id conduit-1.3.1.2-6a041bed26d91d3fa3656521bf8810ab816ab625c99a3c5636222722d98ef2e4
package-id mono-traversable-1.0.15.1-468c0b3b4fce2ba6c2c40c6861373f2b34072b3d1c5b767ecc5825cd0d6490b9
package-id split-0.2.3.3-4e26f9909d36230ea289fb66c3308a8c396dfa2e32972539237e00b5608bb288
package-id vector-algorithms-0.8.0.3-7300a6ba42ba517a24edaf96a5ebb86693000186dc3145f260b61f3e28ba8be5
package-id resourcet-1.2.2-eb0d709472fb9dedb70972345ca035d726ac334af932f87535e2032d32637b63
package-id unliftio-core-0.1.2.0-7a40320c3f2d13531341c25515efb7e13cb69b065f980f0a800c9b22e88f1a7d
package-id conduit-extra-1.3.4-9941c2e4071887e04e691de4abd1d7abceca173f90ccea2f55667598d4a6f739
package-id network-3.1.1.1-3d16d7f515edf7f6ba7fafff4b8a26862e69b1be89534fa75786428fa36fdbdd
package-id streaming-commons-0.2.1.1-969379f83927c229116a949c389593c2e5f4c7c3858d54c307723edf0980e26a
package-id zlib-0.6.2.1-51eb00754354cdc4220fcebf194ee393f922486aef2f669256e561444d19f779
package-id typed-process-0.2.6.0-6488f19593cdba4aa375c251c06a1994626121e329caf8be2f5847fb0c0e8972
package-id http-client-0.6.4-37ee7397a67eea7a6a0341bd2a1bff04342360efb74dde0ffff7c15c9e2a2b00
package-id case-insensitive-1.2.1.0-c9f7a67fe14ace09ee0fbf304e8c02bbf7da87b21c4b6844191f3893cdc3aeb5
package-id cookie-0.4.5-fa94fd53b8eb97cabeec74062a05afef0653edc57e6131f4c1a88222920feb4d
package-id http-types-0.12.3-797a7967e15de068627e7379f7a9737e1d663e49e7228926d04ff1eac91f4c03
package-id mime-types-0.1.0.9-b770335e4f52450b3871359a6d7f204730eb749b10b0e046ac8dbb1e8ec4b9cd
package-id network-uri-2.6.1.0-cd11fe27cd8ea544bf9396b809b6cb55b85c023b26a6f5a2dc13a2476ec61eb3
package-id parsec-3.1.14.0-8f68ee29e81364cfc6d09b124bbd3c73014e7f0a99bb73a6479f939c3594bdd4
package-id http-client-tls-0.3.5.3-d159cd86681c88d58688acf1a6081673a98f6d58f00ec30cde9cd3c6093f266f
package-id connection-0.3.1-a82fc9f545e3992b96a8858462ab9c0ee3144572e7eb7d4b89cf6c6e4ee57e24
package-id socks-0.6.1-74df46af60676e9c0e1bd3bdcb531f7d8d9a189fecc5fef25779f002bac70ea5
package-id cereal-0.5.8.1-baec3a1fd3cd9d21ad6a81006b3f74d82c1b91008386877a2a9d03e8f026e450
package-id tls-1.5.2-304b758c2af9520ef0d91bb9025b69e84b93e757314de2697ef84c4c077fff41
package-id asn1-encoding-0.9.6-b6a6d999252fa73e93129cdc1d073fa7abbe06034cbf21a231356f3c2bb6a920
package-id asn1-types-0.3.3-595756d7e0f1ff750c588717c3f5e00224d242cc55c71508cc13bc2387b6df99
package-id hourglass-0.2.12-5c068289284b36d035a50c8e63f0277f63c9d4ded3cab76c0f3e45d83b3ae5ba
package-id x509-1.7.5-b7e9dc74c2fad4bec063ce6bc5aa3b1f6704464870a606d6027ec8ba0ff35cb0
package-id asn1-parse-0.9.5-6cd37e26020abc77a580a179d3d8ae2f33c115c548d724b765cd255f518301d8
package-id pem-0.2.4-ea1f6bc60dd5f8f41d717f0ed3a7fdf01051a2d0e9bdf13be779b14d01ac3569
package-id x509-store-1.6.7-03c53b8fc24e44019990192a121e87bd5ef2a173625c20d50cd57f4b8aae48c5
package-id x509-validation-1.6.11-c35e811001935e94fc17b7a354bd4529d87692be7efa124a9accaaebc0ebd06a
package-id x509-system-1.6.6-97a138d2ca033432f14ae2af39268c0bc7d6edcfc8a04fb9c53d9032ed752d16
package-id lrucache-1.2.0.1-b7251a2ba8357e17eabe0820f889d3eaf17ae4d3b8b197629b037080cf16a444
package-id contravariant-1.5.2-53e1daf216d7b2698eeb082a7c178c93ca891317544afabdda915ce3075a033f
package-id StateVar-1.2-5ba894e6b82d78728f0af00098e4727e22628c5818c0bf43bd2a7cc73377062a
package-id optparse-applicative-0.14.3.0-180b99805f5801f615fb595777a133886c2b7d0cbf1a8ee8388c6297b53f7098
package-id regex-tdfa-1.2.3.2-d55f80f8fb2ac9011511fd2974e22be139170f2550b917d329a3ab5ef27f1cf6
package-id regex-base-0.93.2-8062a6c89bd9abe11f6a96e9ff6d8214995b200da645182af4cbe38d934236a8
package-id tagsoup-0.14.8-9a1e7ee931023af787b9170cd754266ed7f2ad1af84d6c6b278ec711bf69867c
package-id time-locale-compat-0.1.1.5-f37a5aac942a41e6780a8abb1517c53c2cc304468c13573920ef621ca3ed03af
package-id wai-3.2.2.1-99ac886a432d8948478fb079a3e85bb291b6958393ce75bd3520a7571e637bd7
package-id vault-0.3.1.3-81696e579d6da82a6f8847eacbd9c633dd58a2363008f7ffd64529129bb02806
package-id wai-app-static-3.1.6.3-8025412fa64868b78b55a48c5205bd56013bb600f3ad6ae52bb28885c23d47e0
package-id http-date-0.0.8-2cb106bb8c49027aba87ff7809aacff2b8cab0a5590a768c4adfc210bd4b9f26
package-id wai-extra-3.0.28-de7c772d40f70cb69f52036e833af70ae7b1ca8f146dab2bfb8171a5edc87f51
package-id base64-bytestring-1.0.0.2-3b54703609d783a48d9dabea878d22eac89870a10e661c7cae20c7db9c322ce0
package-id http2-1.6.5-d4a4291d020303291f92701b127d7cc38eb1488b275f1ecfa5a7bc5ca255cca2
package-id network-byte-order-0.1.2.0-c3ae51950c2e277b2bc1652b725cdd9b31f6660f1d9763954db60da2e271413f
package-id psqueues-0.2.7.2-5577a6f59f5d42284405da8375083029f6e75a87c80c3bb510ca420710ba46d2
package-id iproute-1.7.8-d342ad618265ab97fc213238852f1fbcbc958f76d2379d255f5504afb12d4b7b
package-id appar-0.1.8-ebde66dea8ace87cc510ee94f9cd5d1a11b65f07c09adc06da2d04c76f64205b
package-id byteorder-1.0.4-215e9424aa02a05de726b3cdb3985d5120bebaca0c6682665d29bc0db363e58d
package-id void-0.7.3-9fff23e9061d34f7a5d304342fd79c9ca6ce8fa3f847129e5d4cf875096104e2
package-id wai-logger-2.3.6-80a618632f5db5b26e07358096a228ecb0df7dab5980ee0d90a3d2162b73671c
package-id word8-0.1.3-f26d845bf10077b8aff56014497707e6a6a3be6edfcb80991f070a34d0b4102a
package-id warp-3.2.28-aa171d2f0905fcf82b27ba12ddc60fd8bed2981db2c97d0acbfe172a62005f9b
package-id bsb-http-chunked-0.0.0.4-d479e55c1eb8fc4d0b278100762e8e972554dae7fddc2f402eef29462a95748d
package-id simple-sendfile-0.2.30-e72d79db6c62874ac3e96c8473321f47ce211ce9943eaa9a64f2173ad67358ec
package-id time-manager-0.0.0-42786a4cf5691c215a0b12049759e9959361ddb7210afa74e1218844643d7be7
package-id yaml-0.11.2.0-6eb02c7f5592bb917bf7ad9e2e1fdeb5be3760e9c24b9b8a9977e25dbb5f43ac
package-id libyaml-0.1.1.1-a5cd6ebdb890df2d848b28accfa5498653e6de75e0d1fa225ec6ac6cb8b4b1bf
package-id prosidy-1.0.0.0-inplace
package-id megaparsec-8.0.0-3a27d3b1d0e3238bd96df58a33855bdbb8be116f0014a505b77aac2c36cb7ab4
package-id parser-combinators-1.2.1-bf907f540f14b6d236685da6a1ffa2e32ac243d10cc4ac15f89c8f38b2520057
package-id prettyprinter-1.5.1-99a68aa88c01e94ba3018a9f543e5ad8f44993e0220f1880625ed21ad35a5652
package-id profunctors-5.3-4494fca0ca071fc25fe94c7020c5fdd7c7283a36c48c4b40e1cea27fc0421606
package-id bifunctors-5.5.6-def9e38b481d106ea2978d245e5f0f4dd0b57fd1b2b02ddf3318d58b01b09004
package-id comonad-5.0.6-7705edea51f583056f6f1d74a42c731d33fd709bbd32403bba674e5b4cc09f61
package-id distributive-0.6.1-3ccd8e5f33dada2232778caa2080923ca37bd1ec83257434d5f5361b1d4d9ed6
package-id lens-4.17.1-bb65352b52862d4bfefbab6ac2ef7d36ba6d5604f5607eda7dfc3cfd4665800e
package-id call-stack-0.2.0-a3afaa8512cdbb9d372b9e53f68b0742a9d9654a0df7ec6fefcb0396efe90440
package-id free-5.1.3-129fcb7250a4bf05b1e19d6fda5e508d5df6a658c7d8366dde716dd65b622dcc
package-id semigroupoids-5.3.4-45679b787ec342e8df4787892e1277bce05c3a611bf59bfe61f8cf14e4d380cb
package-id kan-extensions-5.2-b61e1a6a49b58f166621b4857fee39a36f90b780b064c2c425c3e5ac380b9547
package-id adjunctions-4.4-9c8816fef394b0490157bc7300e64699712495e5e0b476af01a850d3dbbe8655
package-id invariant-0.5.3-fac715cfc7e11054d8ec1f01f2e67bc8678c3dd0dcc1ff286d2cd605909da8a6
package-id parallel-3.2.2.0-d352a01b5245a9ca01a5b46d5ed949f8f3597de47897be96541495d67b5e5e67
package-id reflection-2.1.5-7d6092ba397f57d8367c6a8a956f769db842ca9b4805e785c824a8515f998e9f
package-id generic-lens-1.1.0.0-808f2d31e353e4ff02212928c60caf2c6a3b633656a8979b434e6674bafe0bd4
package-id mmorph-1.1.3-981978dcfca8bd7aa72b62f4b8af45366c2f13899196d86b2773c2534f925407
package-id prosidyc-0.1.0.0-inplace

19
.hlint.yaml
View File

@ -0,0 +1,19 @@
# HLint configuration file
# https://github.com/ndmitchell/hlint
##########################
# This file contains a template configuration file, which is typically
# placed as .hlint.yaml in the root of your project
# Specify additional command line arguments
#
# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
- arguments:
- --git
- -XNoCPP
- '--extension=hs'
- ignore: {name: 'Redundant $'}
- ignore: {name: 'Redundant do'}
- ignore: {name: 'Use <$>'}

38
src/poetic/Main.hs
View File

@ -4,13 +4,14 @@
{-# LANGUAGE RecordWildCards #-}
module Main where
import Prosidy hiding (NonEmpty, nonEmpty)
import Prosidy
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Control.Lens
import qualified Data.Text.IO as Text.IO
import qualified Options.Applicative as A
import qualified Options.Applicative.Builder as AB
import qualified System.IO as IO
import Data.Foldable (for_)
import Data.Text (Text)
import qualified Data.Text as Text
import Control.Applicative (Alternative(..), optional)
@ -20,13 +21,18 @@ main :: IO ()
main = do
options <- getOptions
document <- readDocument $ inputPath options
let lines = document ^.. allBlocks . _BlockLiteral
. filtered (optionsFilter options)
. content . _Literal
Text.IO.writeFile (outputPath options) . Text.unlines $
optionsPrefix options lines
let lits = document ^.. allBlocks . _BlockLiteral . spanning
. filtered (optionsFilter options)
. spannedContent
IO.withFile (outputPath options) IO.WriteMode $ \hdl ->
for_ lits $ \lit -> do
for_ (sourceLabelFor options lit) $ \label ->
Text.IO.hPutStrLn hdl label
Text.IO.hPutStrLn hdl $ lit ^. spanning . _Literal
where
allBlocks = cosmosOnOf (content . folded) (_BlockTag . content . folded)
allBlocks = cosmosOnOf
(content . folded)
(_BlockTag . spanning . content . folded)
data Options = Options
{ sourceLabel :: Maybe Text
@ -76,13 +82,17 @@ getOptions = A.execParser $ A.info parse info
readKey :: A.ReadM Key
readKey = A.maybeReader (toKey . Text.pack)
optionsPrefix :: Options -> [Text] -> [Text]
optionsPrefix Options{sourceLabel} =
case sourceLabel of
Nothing ->
id
Just lbl ->
(:) (mconcat ["#line 1 \"", lbl, "\""])
sourceLabelFor :: Options -> Spanned Literal -> Maybe Text
sourceLabelFor Options{sourceLabel} lit = do
label <- sourceLabel
aSpan <- view spanOfMaybe lit
let lineNumber = spanDetail aSpan ^. spanDetailBegin . positionLine . _Line
pure $ mconcat
[ "{-# LINE "
, Text.pack . show $ succ lineNumber
, " \""
, label
, "\" #-}"]
optionsFilter :: Options -> LiteralTag -> Bool
optionsFilter Options{tagFilter} =

159
src/prosidy-manual/Prosidy/Manual.lhs → src/prosidy-manual/Prosidy/Manual.hs
View File

@ -1,33 +1,20 @@
## vi: ft=prosidy wrap
title: Manual.lhs
created: 2020-01-01T17:22-8000
updated: 2020-01-01T17:22-8000
---
#=haskell:
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
#:
#=haskell[hide]:
module Prosidy.Manual
( compileDocument
, compileToc
, ManualError(..)
) where
#:
#=haskell:
import Prosidy
import Prosidy.Compile
import Prosidy.Manual.Monad
import Prosidy.Manual.TableOfContents
import Data.Tuple (swap)
import Data.Functor (($>))
import Data.Bifunctor (Bifunctor(..))
import Data.Text (Text)
@ -42,86 +29,61 @@ import Control.Lens.Operators
import Data.Traversable (sequenceA)
import System.FilePath((-<.>))
import Data.Maybe (fromMaybe)
import Data.Text.Encoding (encodeUtf8)
import qualified Hakyll as Ha (Item, Identifier, toFilePath, itemIdentifier, itemBody)
import qualified Control.Lens as L
import qualified Data.Text as Text
import qualified Data.ByteString as BS
import qualified Data.Char as Char
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
#:
#=haskell:
type Html input = RuleT input Manual H.Html
#:
Our rules for parsing are all contained inside of the #lit{document} rule. Prosidy requires that a rule must be registered before it can be used to prevent some issues with non-termination.
Because rules are mutually recursive, we have to use #lit{MonadFix} for this to work! #lit{RecursiveDo} is a wonderful extension that provides from syntactic sugar for this.
#=haskell:
document :: FilePath -> [Ha.Item TocItem] -> Html Document
document currentPath toc = mdo
#:
Let's start with the non-recursive rules.
For text nodes, we should just convert their content directly into HTML. The #lit{self} descriptor returns the focus of a rule directly.
#=haskell:
plainText <- rule @Text @Manual @H.Html "plain text" $
fmap H.text self
#:
Prosidy inserts empty markers called #def{breaks} between lines in a paragraph and before or after an inline tag (if it has a space on that side). Because #i{CJKV} languages don't really care about spacing, we don't assume the user wants a space in these situations.
The Prosidy manual, however, is in English, which #i{does} want spaces in these locations. When we encounter a break, we should render a single space.
#=haskell:
break <- rule "break" $
pure $ H.text " "
#:
#=haskell:
plainTextText <- rule "plain text (as text)" $ self
plainText <- rule "plain text" $ fmap H.text self
breakText <- rule "break (text)" $ pure (" " :: Text)
break <- rule "break" $ pure $ H.text " "
block <- choose "block context"
[ _BlockParagraph @? paragraph
, _BlockTag @? blockTag
[ _BlockParagraph . spanning @? paragraph
, _BlockTag . spanning @? blockTag
]
inline <- choose "inline context"
[ _Break @? break
, _InlineTag @? inlineTag
, _InlineText @? plainText
, _InlineTag . spanning @? inlineTag
, _InlineText . spanning @? plainText
]
onlyText <- choose "inline context (only text)"
[ _Break @? breakText
, _InlineText . spanning @? plainTextText
]
#:
#=haskell:
paragraph <- rule "paragraph" $ do
body <- descend inline $ _Paragraph . L.folded
pure $ H.p body
#:
#=haskell:
blockTag <- choose "block tag"
[ _Tagged "section" @? section
, _Tagged "note" @? note
, _Tagged "list" @? list
]
inlineTag <- choose "inline tag"
[ _Tagged "b" @? bold
, _Tagged "i" @? italics
, _Tagged "chars" @? chars
, _Tagged "lit" @? inlineLiteral
, _Tagged "def" @? definition
, _Tagged "ref" @? reference
, _Tagged "term" @? reference
, _Tagged "link" @? link
]
#:
With that out of the way, lets start defining custom elements for the manual.
#-section[title='Custom Markup']:
#=haskell:
bold <- rule "boldface" $ do
body <- descend inline $ content . L.folded
pure $ H.strong body
@ -129,15 +91,47 @@ With that out of the way, lets start defining custom elements for the manual.
italics <- rule "italics" $ do
body <- descend inline $ content . L.folded
pure $ H.em body
#:
#=haskell:
inlineLiteral <- rule "inline literal" $ do
body <- descend inline $ content . L.folded
pure $ H.code body
#:
#=haskell:
listItemBody <- rule "list item body" $ do
body <- descend block $ content . L.folded
pure $ H.li body
listItem <- choose "list item"
[ _BlockTag . spanning . _Tagged "item" @? listItemBody
]
list <- rule "list" $ do
body <- descend listItem $ content . L.folded
pure $ H.ul body
chars <- rule "chars" $ do
noEscape <- prop "no-escape" "Do not escape the `rep` setting."
rep <- reqText "rep" "The literal representation of the inner text."
text <- descend onlyText $ content . L.folded
pure $ do
let pickHex = (!!) "0123456789ABCDEF" . fromIntegral
toHex 0 acc = acc
toHex n acc = uncurry toHex
. second ((: acc) . pickHex)
$ n `quotRem` 16
H.span ! A.class_ "char-sequence" $ do
H.text text
" ("
H.code ! A.class_ "char-sequence-literal" $
foldMap (H.span . H.toHtml) $
if noEscape
then Text.unpack rep
else foldMap Char.showLitChar (Text.unpack rep) ""
"; "
H.code ! A.class_ "char-sequence-utf-8" $ do
for_ (Text.unpack rep) $ \ch -> H.span $
H.toHtml . foldr toHex [] . BS.unpack . encodeUtf8 $
Text.singleton ch
")"
note <- rule "note" $ do
level <- req readNote "level"
"The level of the note. Can be 'caution', 'note', or 'wip'"
@ -149,9 +143,7 @@ With that out of the way, lets start defining custom elements for the manual.
WIP -> "wip"
H.aside ! A.class_ levelHtml $ do
body
#:
#=haskell:
link <- rule "link" $ do
url <- reqText "url" "The URL to link to."
external <- prop "external" "If provided, open links in a new window."
@ -160,19 +152,25 @@ With that out of the way, lets start defining custom elements for the manual.
H.a ! A.href (H.toValue url)
! (if external then A.target "blank" else mempty)
$ body
#:
#=haskell:
definition <- rule "term definition" $ do
body <- descend inline $ content . L.folded
pure $ H.dfn body
body <- descend onlyText $ content . L.folded
lemma <- optText "lemma"
"The optional, canonical form of a definition\
\ used when the term being defined is declined to fit the sentence."
pure $ do
let id = H.toValue . ("term-" <>) . toSlug $ fromMaybe body lemma
H.dfn (H.text body) ! A.id id
reference <- rule "term reference" $ do
body <- descend inline $ content . L.folded
pure $ H.a body
#:
body <- descend onlyText $ content . L.folded
lemma <- optText "lemma"
"The optional, canonical form of a definition\
\ used when the term being defined is declined to fit the sentence."
pure $ do
let id = H.toValue . ("term-" <>) . toSlug $ fromMaybe body lemma
H.a (H.text body) ! A.href ("#" <> id) ! A.class_ "term-reference"
#=haskell:
section <- rule "section" $ do
sTitle <- reqText "title" "The title of the section."
sSlug <- optText "slug" "The anchor tag associated with the section.\
@ -191,13 +189,6 @@ With that out of the way, lets start defining custom elements for the manual.
H.section ! A.id (H.toValue slug) $ do
H.h1 title
body
#:
#:
Finally, we wrap up all of the rules we previously defined into a final rule which processes the whole #lit{Document}:
#=haskell:
rule "manual page" $ do
title <- reqText "title" "The manual page's title."
subtitle <- optText "subtitle" "The manual page's subtitle."
@ -238,9 +229,6 @@ Finally, we wrap up all of the rules we previously defined into a final rule whi
"Copyright ©2020 to Prosidy.org. Available under the "
H.a "MPL v2.0" ! A.href "https://www.mozilla.org/en-US/MPL/2.0/"
" license."
#:
#=haskell:
data NoteLevel = Caution | Note | WIP
deriving Show
@ -253,9 +241,6 @@ readNote unknown = Left $ mconcat
, show unknown
, ". Expected 'caution', 'note', or 'wip'"
]
#:
#=haskell:
compileToc :: FilePath -> [Ha.Item TocItem] -> H.Html
compileToc currentPath = H.ol . foldMap (compileTocItem $ Just currentPath)
@ -273,9 +258,6 @@ compileTocItem currentPath item =
itemURI = itemPath -<.> ".html"
itemUrl = Text.pack itemURI <> "#" <> slug
isCurrent = Just itemPath == currentPath
#:
#=haskell:
compileDocument :: [Ha.Item TocItem] -> Ha.Item Document -> Either ManualError H.Html
compileDocument toc item =
runManual (compileM (document currentPath toc) doc) >>= first CompileError
@ -298,4 +280,3 @@ reqText = req Right
optText :: (HasMetadata input, Monad context) => Key -> Text -> Desc input context (Maybe Text)
optText = opt Right
#:

6
src/prosidy-manual/Prosidy/Manual/TableOfContents.hs
View File

@ -2,7 +2,7 @@
{-# LANGUAGE RankNTypes #-}
module Prosidy.Manual.TableOfContents where
import Prosidy.Types
import Prosidy
import Data.Sequence (Seq)
import Data.Text (Text)
@ -44,7 +44,9 @@ foldToc 0 = const pure
foldToc depth = content . L.folded . allSections . L.to (toTocItem depth)
where
allSections :: L.Fold Block (Region (Seq Block))
allSections = L.deepOf (_BlockTag . content . L.folded) (_BlockTag . _Tagged "section")
allSections = L.deepOf
(_BlockTag . spanning . content . L.folded)
(_BlockTag . spanning . _Tagged "section")
toTocItem :: Natural -> Region (Seq Block) -> TocItem
toTocItem depth r = TocItem navTitle slug $ r ^.. foldToc (pred depth)

1
src/prosidy-manual/prosidy-manual.cabal
View File

@ -44,4 +44,5 @@ executable prosidy-manual
, bytestring
, mmorph
, binary
, bytestring

263
src/prosidy-markup/Main.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
module Main
@ -12,6 +12,8 @@ where
import Prosidy
import Prosidy.Compile
import Data.Maybe (fromMaybe)
import Data.Functor.Identity (Identity)
import Options.Applicative
import Data.Text ( Text )
import Control.Exception ( throwIO
@ -24,8 +26,10 @@ import qualified Text.Blaze.Internal as Blaze
import qualified System.IO as IO
import qualified Data.Text.IO as Text.IO
import Data.Foldable (for_)
import qualified Control.Lens as L
import Control.Lens.Operators
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
@ -34,91 +38,38 @@ main = do
opts@Opts {..} <- getOpts
input <- withFile' IO.stdin inputFile IO.ReadMode Text.IO.hGetContents
document <- either throwIO pure
$ parseDocument (maybe "<stdin>" id inputFile) input
html <- either (fail . show) (pure . toStrict . renderHtml)
$ compile (compiler standalone breakUsing) document
withFile' IO.stdout outputFile IO.WriteMode (`Text.IO.hPutStrLn` html)
$ parseDocument (fromMaybe "<stdin>" inputFile) input
case compile (compiler standalone breakUsing) document of
Left err -> fail $ show err
Right html -> do
withFile' IO.stdout outputFile IO.WriteMode $ \handle ->
Text.IO.hPutStrLn handle . toStrict . renderHtml $ html
withFile'
:: IO.Handle -> Maybe FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
withFile' hdl path mode =
bracket (maybe (pure hdl) (`IO.openFile` mode) path) IO.hClose
compiler :: Bool -> Text -> Rule Document H.Html
compiler standalone space = mdo
break <- rule "break" $ pure $ H.text space
text <- rule "plain text" $ do
body <- self
pure $ H.text body
literalText <- rule "literal text" $ do
body <- descend text _Literal
pure $ H.code body
block <- choose
"block context"
[ _BlockTag @? blockTag
, _BlockLiteral @? codeBlock
, _BlockParagraph @? paragraph
]
inline <- choose
"inline context"
[_Break @? break, _InlineTag @? inlineTag, _InlineText @? text]
blockTag <- choose
"block tag"
[ _Tagged [keyQ|h|] @? heading
, _Tagged [keyQ|h+|] @? subheading
, _Tagged [keyQ|h++|] @? subsubheading
, _Tagged [keyQ|list|] @? list
, _Tagged [keyQ|section|] @? section
, _Tagged [keyQ|quote|] @? quote
, _Tagged [keyQ|image|] @? blockImage
]
compileBlockTag :: Item (Spanned Paragraph) Identity H.Html -> Item Block Identity H.Html -> ProductT (Spanned BlockTag) Identity H.Html
compileBlockTag paragraph block = do
textOnly <- blockRule "text only block"
paragraph
(disallow "literal tags not allowed in this context")
(disallow "nested block tags are not allowed in this context")
finalBlock <- choose "final block tag" [_BlockParagraph @? paragraph]
heading <- tagRule "h" "first-level heading" $
H.h2 <$> children textOnly
inlineTag <- choose
"inline tag"
[ _Tagged [keyQ|b|] @? bold
, _Tagged [keyQ|i|] @? italic
, _Tagged [keyQ|image|] @? image
, _Tagged [keyQ|link|] @? link
, _Tagged [keyQ|lit|] @? lit
]
codeBlock <- rule "codeBlock" $ do
body <- descend literalText content
pure $ H.pre body
paragraph <- rule "paragraph" $ do
body <- descend inline (_Paragraph . L.folded)
pure $ H.p body
heading <- rule "heading" $ do
body <- descend finalBlock (content . L.folded)
pure $ H.h2 body
subheading <- tagRule "h+" "second-level heading" $ do
H.h3 <$> children textOnly
subheading <- rule "subheading" $ do
body <- descend finalBlock (content . L.folded)
pure $ H.h3 body
subsubheading <- rule "subsubheading" $ do
body <- descend finalBlock (content . L.folded)
pure $ H.h4 body
image <- rule "image" $ do
url <- req Right [keyQ|url|] "The URL of the image to embed."
title <- opt Right [keyQ|title|] "The title/alt-text of the image."
pure $ do
H.img ! A.src (H.toValue url) ! foldMap (A.title . H.toValue) title
subsubheading <- tagRule "h++" "third-level heading" $ do
H.h4 <$> children textOnly
blockImage <- rule "blockImage" $ do
url <- req Right [keyQ|url|] "The URL of the image to embed."
title <- opt Right [keyQ|title|] "The title/alt-text of the image."
body <- descend finalBlock $ content . L.folded
blockImage <- tagRule "image" "block image with optional caption" $ do
url <- req Right "url" "The URL of the image to embed."
title <- opt Right "title" "The title/alt-text of the image."
body <- children textOnly
pure $ do
H.figure $ do
H.img
@ -126,76 +77,124 @@ compiler standalone space = mdo
! foldMap (A.title . H.toValue) title
H.figcaption body
bold <- rule "bold" $ do
body <- descend inline (content . L.folded)
pure $ H.strong body
blockQuote <- tagRule "quote" "a blockquote" $ do
body <- children block
pure $ H.blockquote body
italic <- rule "italic" $ do
body <- descend inline (content . L.folded)
pure $ H.em body
list <- compileList block
link <- rule "link" $ do
url <- req Right [keyQ|url|] "The URL to link to."
body <- descend inline $ content . L.folded
pure $ H.a body ! A.href (H.toValue url)
tags "block tags"
[ heading
, subheading
, subsubheading
, list
, blockImage
, blockQuote
]
lit <- rule "literal" $ do
body <- descend inline $ content . L.folded
pure $ H.code body
compileList :: Item Block Identity H.Html -> SumT (Spanned BlockTag) Identity H.Html
compileList block = do
item <- tagRule "item" "A single item within a list." $ do
content <- children block
pure $ H.li content
onlyItems <- tags "inside of a list" [item]
insideList <- blockRule "inside of a list"
(disallow "paragraphs are not permitted in this context")
(disallow "literal blocks are not permitted in this context")
onlyItems
tagRule "list" "A listing. All children must be 'item' block tags." $ do
isOrdered <- prop "ord" "If provided, the list is numerically ordered."
content <- children insideList
pure $ (if isOrdered then H.ol else H.ul) content
compileInlineTag :: Item Inline Identity H.Html -> ProductT (Spanned InlineTag) Identity H.Html
compileInlineTag inline = do
image <- tagRule "image" "images, inline with text" $ do
url <- req Right "url" "The URL of the image to embed."
title <- opt Right "title" "The title/alt-text of the image."
pure $ do
H.img ! A.src (H.toValue url) ! foldMap (A.title . H.toValue) title
listItem <- choose "list item"
[_BlockTag . _Tagged [keyQ|item|] @? listBody]
bold <- tagRule "b" "bold text" $ do
H.strong <$> children inline
listBody <- rule "list body" $ do
body <- descend block (content . L.folded)
pure $ H.li body
italic <- tagRule "i" "italic text" $ do
H.em <$> children inline
list <- rule "list" $ do
isOrdered <- prop [keyQ|ord|]
"If provided, treat the list as a ordered-list."
body <- descend listItem (content . L.folded)
pure $ do
(if isOrdered then H.ol else H.ul) body
literal <- tagRule "lit" "inline literal text" $ do
H.code <$> children inline
quote <- rule "quote" $ do
body <- descend block (content . L.folded)
pure $ H.blockquote body
link <- tagRule "link" "hyperlinks" $ do
url <- req Right "url" "The destination URL."
content <- children inline
pure $ H.a content ! A.href (H.toValue url)
section <- rule "section" $ do
class_ <- opt Right [keyQ|class|] "Optional classes to be attached."
body <- descend block (content . L.folded)
pure $ H.section body ! foldMap (A.class_ . H.toValue) class_
rule "document" $ do
title <- req Right
[keyQ|title|]
"The document's title, used as the header."
style <- if standalone
then opt Right
[keyQ|style|]
"A stylesheet to attach to the document"
else pure Nothing
body <- descend block (content . L.folded)
tags "inline tags"
[ bold
, image
, italic
, literal
, link
]
compileLiteralTag :: ProductT (Spanned LiteralTag) Identity H.Html
compileLiteralTag = do
literalText <- rule "literal-text" "text inside of a literal tag" $ do
content <- self
pure $ H.text (content ^. _Literal)
code <- tagRule "code" "embedded source code" $ do
content <- child literalText
pure $
H.pre . H.code $ content
tags "literal tags"
[ code
]
compiler :: Bool -> Text -> ProductT Document Identity H.Html
compiler standalone space = mdo
block <- blockRule "top-level block items"
paragraph
literalTag
blockTag
inline <- inlineRule "top-level inline items"
(pure " ")
(pure . H.text)
inlineTag
paragraph <- paragraphRule inline (pure . H.p)
inlineTag <- compileInlineTag inline
blockTag <- compileBlockTag paragraph block
literalTag <- compileLiteralTag
documentRule $ do
content <- children block
title <- req Right "title" "The document's title, used in the header."
maybeStyle <- if
| standalone -> opt Right "style" "A stylesheet to attach to the document."
| otherwise -> pure Nothing
pure $ do
let titleHtml = H.text title
if standalone
then H.html $ do
if
| standalone -> do
H.html $ do
H.head $ do
H.title titleHtml
foldMap
(\s ->
H.link
! A.rel "stylesheet"
! A.type_ "text/css"
! A.href (H.toValue s)
)
style
for_ maybeStyle $ \style ->
H.link ! A.rel "stylesheet"
! A.type_ "text/css"
! A.href (H.toValue style)
H.body $ do
H.header $ H.h1 titleHtml
H.main body
else do
H.h1 titleHtml
body
H.main content
| otherwise -> do
H.h1 titleHtml
content
data Opts = Opts
{ breakUsing :: Text

68
src/prosidy-markup/syntax-guide.pro
View File

@ -2,43 +2,33 @@ title: Syntax Guide
style: style.css
---
#-section:endsection
#-h{Headers}
#=prosidy:
#=code[lang='prosidy']:
#-h{This will be rendered as an h2 tag.}
#-h+{This will be rendered as an h3 tag.}
#-h++{This will be rendered as an h4 tag.}
#:
#-section[class='out']:
#-h{This will be rendered as an h2 tag.}
#-h+{This will be rendered as an h3 tag.}
#-h++{This will be rendered as an h4 tag.}
#:
#:endsection
#-section:endsection
#-h{Emphasis}
#=prosidy:
#=code[lang='prosidy']:
#i{This text will be italic,} #b{and this text will be bold.}
You #i{#b{can}} combine them if you like.
#:
#-section[class='out']:
#i{This text will be italic,} #b{and this text will be bold.}
You #i{#b{can}} combine them if you like.
#:
#:endsection
#-section:endsection
#-h{Lists}
#-section:endsubsection
#-h+{Unordered}
#=prosidy:end
#=code[lang='prosidy']:end
#-list:
#-item{Item 1}
#-item:
@ -58,7 +48,6 @@ You #i{#b{can}} combine them if you like.
#:
#:end
#-section[class='out']:
#-list:
#-item{Item 1}
#-item:
@ -76,12 +65,9 @@ You #i{#b{can}} combine them if you like.
#:
#:
#:
#:
#:endsubsection
#-section:endsubsection
#-h+{Ordered}
#=prosidy:end
#=code[lang='prosidy']:end
#-list[ord]:
#-item{Item 1}
@ -103,7 +89,6 @@ You #i{#b{can}} combine them if you like.
#:
#:end
#-section[class='out']:
#-list[ord]:
#-item{Item 1}
@ -123,13 +108,9 @@ You #i{#b{can}} combine them if you like.
#:
#:
#:
#:
#:endsubsection
#:endsection
#-section:endsection
#-h{Images}
#=prosidy:end
#=code[lang='prosidy']:end
These images are inline—
#image[url='https://placekitten.com/32/32?1'],
#image[url='https://placekitten.com/32/32?2', title='The "title" key attaches "alt-text"'],
@ -138,54 +119,41 @@ but block images are also supported!
#-image[url='https://placekitten.com/400/200?3']{And block images support captions!}
#:end
#-section[class='out']:
These images are inline—
#image[url='https://placekitten.com/32/32?1'],
#image[url='https://placekitten.com/32/32?2', title='The "title" key attaches "alt-text"'],
but block images are also supported!
#-image[url='https://placekitten.com/400/200?3']{And block images support captions!}
#:
#:endsection
#-section:endsection
#-h{Links}
#=prosidy:end
#=code[lang='prosidy']:end
Here's a link to the #link[url='https://prosidy.org']{Prosidy homepage}.
#:end
#-section[class='out']:
Here's a link to the #link[url='https://prosidy.org']{Prosidy homepage}.
#:
#:endsection
#-section:endsection
#-h{Blockquotes}
#=prosidy:end
#=code[lang='prosidy']:end
#-quote:
Everything within a "quote" block is rendered as block quotes.
#:
#:end
#-section[class='out']:
#-quote:
Everything within a "quote" block is rendered as block quotes.
#:
#:
#:endsection
#-section:endsection
#-h{Code}
#-section:endsubsection
#-h+{Code blocks}
#=prosidy:end
#=haskell:
#=code[lang='prosidy']:end
#=code[lang='haskell']:
fibonacci :: [Integer]
fibonacci = 0 : 1 : zipWith (+) fib (tail fib)
#:
#=python:
#=code[lang='python']:
def fibonacci(n):
a = 0
b = 1
@ -195,13 +163,12 @@ def fibonacci(n):
#:
#:end
#-section[class='out']:
#=haskell:
#=code[lang='haskell']:
fibonacci :: [Integer]
fibonacci = 0 : 1 : zipWith (+) fib (tail fib)
#:
#=python:
#=code[lang='python']:
def fibonacci(n):
a = 0
b = 1
@ -209,17 +176,10 @@ def fibonacci(n):
(a, b) = (b, a + b)
return a
#:
#:
#:endsubsection
#-section:endsubsection
#-h+{Inline code}
#=prosidy:end
#=code[lang='prosidy']:end
Some code: #lit{foo} #lit{bar}.
#:end
#-section:
Some code: #lit{foo} #lit{bar}.
#:
#:endsubsection
#:endsection
Some code: #lit{foo} #lit{bar}.

2
src/prosidy/Prosidy.hs
View File

@ -2,5 +2,5 @@ module Prosidy ( module X)
where
import Prosidy.Source as X
import Prosidy.Types as X
import Prosidy.Types as X hiding (NonEmpty, nonEmpty)
import Prosidy.Parse as X

31
src/prosidy/Prosidy/Parse.hs
View File

@ -162,23 +162,26 @@ block = choice
blockTag :: P BlockTag
blockTag = do
t <- genericTag (void $ string "#-") $ option mempty blockTagContents
t <- genericTag (void $ string "#-") $ option (Spanned Nothing mempty) blockTagContents
emptyLines
pure t
blockTagContents :: P (Seq Block)
blockTagContents :: P (Spanned (Seq Block))
blockTagContents = choice
[ foldMap (Seq.singleton . BlockParagraph . fmap Paragraph) . sequenceA
<$> spanned (token tagParagraph)
, Seq.fromList <$> withBlockDelimiters (emptyLines *> many block)
[ spanned
$ foldMap (Seq.singleton . BlockParagraph . fmap Paragraph) . sequenceA
<$> token tagParagraph
, spanned
$ Seq.fromList
<$> withBlockDelimiters (emptyLines *> many block)
]
literalTag :: P LiteralTag
literalTag = genericTag (void $ string "#=") $ do
close <- blockTagDelim (void $ optional_ comment *> Megaparsec.newline)
litLines <- manyTill literalLine $ try (skipSpaces *> close)
litLines <- spanned . manyTill literalLine $ try (skipSpaces *> close)
emptyLines
pure . Literal . Text.Lazy.toStrict $ Text.Lazy.intercalate "\n" litLines
pure $ Literal . Text.Lazy.toStrict . Text.Lazy.intercalate "\n" <$> litLines
literalLine :: P Text.Lazy.Text
literalLine = do
@ -209,9 +212,10 @@ inline = choice
]
inlineTag :: P InlineTag
inlineTag = genericTag sigil . option mempty $ fmap orEmpty tagParagraph
inlineTag = genericTag sigil . option (Spanned Nothing mempty) $
fmap orEmpty tagParagraph
where
orEmpty = maybe Seq.empty getNonEmpty
orEmpty = fmap $ maybe Seq.empty getNonEmpty
sigil = try $ do
void $ char '#'
void . lookAhead $ satisfy isValidKeyHead
@ -242,19 +246,20 @@ paragraphSpacer = try $ do
skipSpaces1
notFollowedBy $ void (string "##") <|> void Megaparsec.newline
tagParagraph :: P (Maybe (NonEmpty Seq Inline))
tagParagraph = between start end $ option Nothing paragraphLike
tagParagraph :: P (Spanned (Maybe (NonEmpty Seq Inline)))
tagParagraph = between start end . spanned $
option Nothing paragraphLike
where
start = char '{' *> skipSpaces *> optional_ endOfLine
end = skipSpaces *> char '}'
-------------------------------------------------------------------------------
genericTag :: P () -> P a -> P (Tagged (Spanned a))
genericTag :: P () -> P (Spanned a) -> P (Tagged a)
genericTag sigilParser bodyParser = do
sigilParser
thisName <- toKeyUnchecked <$> keyLike
thisMetadata <- meta
thisContent <- spanned bodyParser
thisContent <- bodyParser
pure $ Tagged thisName thisMetadata thisContent
meta :: P Metadata

76
src/prosidy/Prosidy/Source.hs
View File

@ -1,5 +1,7 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTSyntax #-}
@ -16,11 +18,14 @@ import Data.Aeson (FromJSON(..), ToJSON(..))
import Data.Text (Text)
import Data.Word (Word)
import Data.Sequence (Seq)
import GHC.Generics (Generic)
import Data.Hashable (Hashable)
-------------------------------------------------------------------------------
data Source where
Source :: FilePath -> Text -> Source
deriving stock (Eq, Show)
deriving stock (Eq, Show, Generic)
deriving anyclass (Hashable)
sourcePath :: Lens' Source FilePath
sourcePath = lens get set
@ -39,7 +44,8 @@ sourceText = lens get set
-------------------------------------------------------------------------------
data Span where
Span :: Source -> Offset -> Offset -> Span
deriving stock (Eq, Show)
deriving stock (Eq, Show, Generic)
deriving anyclass (Hashable)
spanSource :: Lens' Span Source
spanSource = lens get set
@ -64,15 +70,37 @@ spanEnd = lens get set
-------------------------------------------------------------------------------
data SpanDetail where
SpanDetail :: Source -> Position -> Position -> Text -> SpanDetail
deriving (Show, Eq)
SpanDetail :: Position -> Position -> Text -> SpanDetail
deriving stock (Eq, Show, Generic)
deriving anyclass (Hashable)
spanDetailBegin :: Lens' SpanDetail Position
spanDetailBegin = lens get set
where
get (SpanDetail x _ _) = x
set (SpanDetail _ y z) x = SpanDetail x y z
{-# INLINE spanDetailBegin #-}
spanDetailEnd :: Lens' SpanDetail Position
spanDetailEnd = lens get set
where
get (SpanDetail _ y _) = y
set (SpanDetail x _ z) y = SpanDetail x y z
{-# INLINE spanDetailEnd #-}
spanDetailText :: Lens' SpanDetail Text
spanDetailText = lens get set
where
get (SpanDetail _ _ z) = z
set (SpanDetail x y _) = SpanDetail x y
{-# INLINE spanDetailText #-}
spanDetail :: Span -> SpanDetail
spanDetail (Span source@(Source _ srcText) (Offset from) (Offset to)) =
SpanDetail source startPosition endPosition spanned
spanDetail (Span (Source _ srcText) (Offset from) (Offset to)) =
SpanDetail startPosition endPosition spanned
where
(before, srcText') = Text.splitAt (fromIntegral from) srcText
(spanned, _) = Text.splitAt (fromIntegral to) srcText'
(spanned, _after) = Text.splitAt (fromIntegral to) srcText'
startPosition = advancePosition (Position (Line 0) (Column 0)) before
endPosition = advancePosition startPosition spanned
@ -87,7 +115,15 @@ advancePosition p = fst . foldl' (uncurry go) (p, '\0') . Text.unpack
-------------------------------------------------------------------------------
data Spanned a where
Spanned :: Maybe Span -> a -> Spanned a
deriving stock (Eq, Show, Functor, Foldable, Traversable)
deriving stock (Eq, Functor, Foldable, Traversable, Generic)
deriving anyclass (Hashable)
instance Show a => Show (Spanned a) where
show (Spanned Nothing x) = "Unspanned " <> show x
show (Spanned (Just s) x) =
"Spanned " <> (show from) <> (show to) <> (show txt) <> (show x)
where
SpanDetail from to txt = spanDetail s
instance FromJSON a => FromJSON (Spanned a) where
parseJSON = fmap (Spanned Nothing) . parseJSON
@ -122,27 +158,43 @@ type SpannedSeq a = Spanned (Seq (Spanned a))
-------------------------------------------------------------------------------
data Position where
Position :: Line -> Column -> Position
deriving (Show, Eq)
deriving stock (Eq, Show, Generic)
deriving anyclass (Hashable)
positionLine :: Lens' Position Line
positionLine = lens get set
where
get (Position l _) = l
set (Position _ c) = flip Position c
positionColumn :: Lens' Position Column
positionColumn = lens get set
where
get (Position _ c) = c
set (Position l _) = Position l
newtype Line = Line Word
deriving stock (Eq, Show)
deriving stock (Eq, Show, Generic)
deriving newtype (ToJSON, FromJSON)
deriving anyclass (Hashable)
_Line :: Iso' Line Word
_Line = iso (\(Line n) -> n) Line
{-# INLINE _Line #-}
newtype Column = Column Word
deriving stock (Eq, Show)
deriving stock (Eq, Show, Generic)
deriving newtype (ToJSON, FromJSON)
deriving anyclass (Hashable)
_Column :: Iso' Column Word
_Column = iso (\(Column n) -> n) Column
{-# INLINE _Column #-}
newtype Offset = Offset Word
deriving stock (Eq, Show)
deriving stock (Eq, Show, Generic)
deriving newtype (ToJSON, FromJSON)
deriving anyclass (Hashable)
_Offset :: Iso' Offset Word
_Offset = iso (\(Offset n) -> n) Offset

37
src/prosidy/Prosidy/Types.hs
View File

@ -97,9 +97,9 @@ instance Serde Block where
, noMatch "Expected a LiteralTag, BlockTag, or Paragraph"
]
type BlockTag = Tagged (Spanned (Seq Block))
type BlockTag = Tagged (Seq Block)
type LiteralTag = Tagged (Spanned Literal)
type LiteralTag = Tagged Literal
_BlockLiteral :: Prism' Block (Spanned LiteralTag)
_BlockLiteral = prism BlockLiteral $ \case
@ -128,15 +128,15 @@ data Document where
instance Serde Document where
serde = Document
<$> field "metadata" metadata
<*> field "content" content
<*> field "content" spannedContent
instance HasContent Document where
type Content Document = Spanned (Seq Block)
content = lens get set
type Content Document = Seq Block
spannedContent = lens get set
where
get (Document _ c) = c
set (Document m _) = Document m
{-# INLINE content #-}
{-# INLINE spannedContent #-}
instance HasMetadata Document where
metadata = lens get set
@ -145,7 +145,7 @@ instance HasMetadata Document where
set (Document _ c) m = Document m c
{-# INLINE metadata #-}
_Document :: Iso' Document (Region (Spanned (Seq Block)))
_Document :: Iso' Document (Region (Seq Block))
_Document = iso (\(Document m c) -> Region m c) (\(Region m c) -> Document m c)
-------------------------------------------------------------------------------
@ -164,7 +164,7 @@ instance Serde Inline where
, noMatch "Expected an Break, InlineTag, or Inline Text"
]
type InlineTag = Tagged (Spanned (Seq Inline))
type InlineTag = Tagged (Seq Inline)
_Break :: Prism' Inline ()
_Break = prism (const Break) $ \case
@ -289,17 +289,17 @@ _Paragraph = iso (\(Paragraph xs) -> xs) Paragraph
-------------------------------------------------------------------------------
data Tagged content where
Tagged :: Key -> Metadata -> content -> Tagged content
Tagged :: Key -> Metadata -> Spanned content -> Tagged content
deriving stock (Eq, Foldable, Functor, Show, Traversable)
deriving (FromJSON, ToJSON) via (JSON (Tagged content))
instance HasContent (Tagged content) where
type Content (Tagged content) = content
content = lens get set
spannedContent = lens get set
where
get (Tagged _ _ c) = c
set (Tagged k m _) = Tagged k m
{-# INLINE content #-}
{-# INLINE spannedContent #-}
instance HasMetadata (Tagged c) where
metadata = lens get set
@ -312,7 +312,7 @@ instance (Typeable c, ToJSON c, FromJSON c) => Serde (Tagged c) where
serde = Tagged
<$> field "name" tag
<*> field "metadata" metadata
<*> field "content" content
<*> field "content" spannedContent
tag :: Lens' (Tagged c) Key
tag = lens get set
@ -330,17 +330,17 @@ _Tagged key = prism (addTag key) $ \case
-------------------------------------------------------------------------------
data Region content where
Region :: Metadata -> content -> Region content
Region :: Metadata -> Spanned content -> Region content
deriving stock (Eq, Foldable, Functor, Show, Traversable)
deriving (FromJSON, ToJSON) via (JSON (Region content))
instance HasContent (Region content) where
type Content (Region content) = content
content = lens get set
spannedContent = lens get set
where
get (Region _ c) = c
set (Region m _) = Region m
{-# INLINE content #-}
{-# INLINE spannedContent #-}
instance HasMetadata (Region c) where
metadata = lens get set
@ -352,7 +352,7 @@ instance HasMetadata (Region c) where
instance (Typeable c, ToJSON c, FromJSON c) => Serde (Region c) where
serde = Region
<$> field "metadata" metadata
<*> field "content" content
<*> field "content" spannedContent
addTag :: Key -> Region c -> Tagged c
addTag key (Region m c) = Tagged key m c
@ -360,8 +360,13 @@ addTag key (Region m c) = Tagged key m c
-------------------------------------------------------------------------------
class HasContent node where
type family Content node
spannedContent :: Lens' node (Spanned (Content node))
content :: Lens' node (Content node)
content = spannedContent . spanning
{-# INLINE content #-}
{-# MINIMAL spannedContent #-}
-------------------------------------------------------------------------------
class HasMetadata node where
metadata :: Lens' node Metadata

267
src/prosidyc/Prosidy/Compile.hs
View File

@ -9,35 +9,44 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Prosidy.Compile
( Compile
, RuleT
, Rule
, ProductT
, SumT
, Desc
, Item
, Choice
, Error(..)
, tags
, tagRule
, blockRule
, inlineRule