Browse Source

Start cleaning up prosidyc a touch

master
Alex Feldman-Crough 1 year ago
parent
commit
a2441464aa
16 changed files with 590 additions and 573 deletions
  1. +0
    -169
      .ghc.environment.x86_64-linux-8.6.5
  2. +19
    -0
      .hlint.yaml
  3. +24
    -14
      src/poetic/Main.hs
  4. +70
    -89
      src/prosidy-manual/Prosidy/Manual.hs
  5. +4
    -2
      src/prosidy-manual/Prosidy/Manual/TableOfContents.hs
  6. +1
    -0
      src/prosidy-manual/prosidy-manual.cabal
  7. +131
    -132
      src/prosidy-markup/Main.hs
  8. +14
    -54
      src/prosidy-markup/syntax-guide.pro
  9. +1
    -1
      src/prosidy/Prosidy.hs
  10. +18
    -13
      src/prosidy/Prosidy/Parse.hs
  11. +64
    -12
      src/prosidy/Prosidy/Source.hs
  12. +21
    -16
      src/prosidy/Prosidy/Types.hs
  13. +210
    -57
      src/prosidyc/Prosidy/Compile.hs
  14. +3
    -10
      src/prosidyc/Prosidy/Compile/Internal/Eval.hs
  15. +9
    -4
      src/prosidyc/Prosidy/Compile/Internal/Spec.hs
  16. +1
    -0
      src/prosidyc/prosidyc.cabal

+ 0
- 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
- 0
.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 <$>'}

+ 24
- 14
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} =


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
#:

+ 4
- 2
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
- 0
src/prosidy-manual/prosidy-manual.cabal View File

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

+ 131
- 132
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


+ 14
- 54
src/prosidy-markup/syntax-guide.pro View File

@ -2,43 +2,33 @@ title: Syntax Guide
style: style.css
---
#-section:endsection
#-h{Headers}
#=prosidy:
#=code>n class="p">[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>n class="p">[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>n class="p">[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>n class="p">[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>n class="p">[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>n class="p">[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>n class="p">[lang='prosidy']:end
#=code>n class="p">[>lang='haskell']:
fibonacci :: [Integer]
fibonacci = 0 : 1 : zipWith (+) fib (tail fib)
#:
#=python:
#=code>n class="p">[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>n class="p">[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>n class="p">[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}.

+ 1
- 1
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

+ 18
- 13
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


+ 64
- 12
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

+ 21
- 16
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


+ 210
- 57
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
, documentRule
, paragraphRule
, rule
, access
, staticOnly
, compileM
, compile
, rule
, choose
, self
, prop
, req
, opt
, descend
, child
, children
, embed
, (@?)
)
where
, disallow
) where
import qualified Prosidy.Compile.Internal.Eval as Eval
import qualified Prosidy.Compile.Internal.Spec as Spec
import qualified Prosidy.Compile.Internal.Util as Util
import qualified Control.Lens as L
import Control.Lens.Operators
import Data.Sequence (Seq)
import Prosidy.Compile.Internal.Spec ( ItemKey(..) )
import Prosidy.Compile.Internal.Error ( Errors
, Result(..)
@ -45,12 +54,33 @@ import Prosidy.Compile.Internal.Error ( Errors
, resultError
, liftResult
, eachError
, mapErrors
, raiseError
)
import Prosidy.Types ( Key
, HasMetadata
)
, Tagged
, Region
, Paragraph
, Literal
, LiteralTag
, BlockTag
, InlineTag
, Block
, Inline
, _BlockTag
, _BlockLiteral
, _InlineTag
, _BlockParagraph
, _InlineText
, _Literal
, _Break