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

Initial commit

master
Alex Feldman-Crough 10 months ago
commit
7c95f4152a
18 changed files with 1415 additions and 0 deletions
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. +74
    -0
      .drone.yml
  2. +5
    -0
      .gitignore
  3. +19
    -0
      .hlint.yaml
  4. +17
    -0
      .vscode/settings.json
  5. +2
    -0
      CHANGELOG
  6. +373
    -0
      LICENSE
  7. +9
    -0
      README.pro
  8. +46
    -0
      brittany.yaml
  9. +4
    -0
      cabal.project
  10. +4
    -0
      hie.yaml
  11. +120
    -0
      prosidyc.cabal
  12. +12
    -0
      scripts/documentation-coverage
  13. +15
    -0
      scripts/release
  14. +85
    -0
      src/Prosidy/Compile.hs
  15. +291
    -0
      src/Prosidy/Compile/Core.hs
  16. +175
    -0
      src/Prosidy/Compile/Error.hs
  17. +91
    -0
      src/Prosidy/Compile/Match.hs
  18. +73
    -0
      src/Prosidy/Compile/Run.hs

+ 74
- 0
.drone.yml View File

@ -0,0 +1,74 @@
---
kind: pipeline
type: docker
name: default
steps:
- name: configure
image: utdemir/ghc-musl:v4-integer-simple-ghc881
environment:
CABAL_DIR: /cabal
volumes:
- name: cabal-cache
path: /cabal
commands:
- cabal v2-update
- cabal v2-configure --jobs \$ncpus --enable-tests --flags +fatal-warnings
- &default-steps
name: ghc 8.8.1
image: utdemir/ghc-musl:v4-integer-simple-ghc881
depends_on: [configure]
environment:
CABAL_DIR: /cabal
volumes:
- name: cabal-cache
path: /cabal
commands:
- cabal v2-build
- cabal v2-test
- <<: *default-steps
name: ghc 8.6.5
image: utdemir/ghc-musl:v4-integer-simple-ghc865
- name: docs
image: utdemir/ghc-musl:v4-integer-simple-ghc881
depends_on:
- ghc 8.8.1
environment:
CABAL_DIR: /cabal
volumes:
- name: cabal-cache
path: /cabal
commands:
- ./scripts/documentation-coverage
- name: release
image: registry.in.fldcr.com/cabal-publish:latest
depends_on:
- ghc 8.8.1
- ghc 8.6.5
- docs
environment:
CABAL_DIR: /cabal
HACKAGE_USER: {"from_secret": "hackage-user"}
HACKAGE_PASSWORD: {"from_secret": "hackage-password"}
volumes:
- name: cabal-cache
path: /cabal
commands:
- ./scripts/release
when:
event:
- tag
volumes:
- name: cabal-cache
host:
path: /var/cache/cabal
---
kind: signature
hmac: 4182c9a06e0671846733a1cd1617ad52119e1a96be312770004503c6be80b553
...

+ 5
- 0
.gitignore View File

@ -0,0 +1,5 @@
.stack-work/
dist/
dist-newstyle/
/cabal.project.local
*~

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

+ 17
- 0
.vscode/settings.json View File

@ -0,0 +1,17 @@
{
"files.exclude": {
"dist/**": true,
"dist-newstyle/**": true,
".ghc.environment.*": true,
".gitattributes": true,
".env/**": true
},
"files.watcherExclude": {
"**/.out/**": true,
"**/.git/objects/**": true,
"**/.git/subtree-cache/**": true,
"**/.env/**": true,
"**/dist/**": true,
"**/dist-newstyle/**": true
}
}

+ 2
- 0
CHANGELOG View File

@ -0,0 +1,2 @@
# v0.1.0.0 _(2020-03-03)_
- Initial version

+ 373
- 0
LICENSE View File

@ -0,0 +1,373 @@
Mozilla Public License Version 2.0
==================================
1. Definitions
--------------
1.1. "Contributor"
means each individual or legal entity that creates, contributes to
the creation of, or owns Covered Software.
1.2. "Contributor Version"
means the combination of the Contributions of others (if any) used
by a Contributor and that particular Contributor's Contribution.
1.3. "Contribution"
means Covered Software of a particular Contributor.
1.4. "Covered Software"
means Source Code Form to which the initial Contributor has attached
the notice in Exhibit A, the Executable Form of such Source Code
Form, and Modifications of such Source Code Form, in each case
including portions thereof.
1.5. "Incompatible With Secondary Licenses"
means
(a) that the initial Contributor has attached the notice described
in Exhibit B to the Covered Software; or
(b) that the Covered Software was made available under the terms of
version 1.1 or earlier of the License, but not also under the
terms of a Secondary License.
1.6. "Executable Form"
means any form of the work other than Source Code Form.
1.7. "Larger Work"
means a work that combines Covered Software with other material, in
a separate file or files, that is not Covered Software.
1.8. "License"
means this document.
1.9. "Licensable"
means having the right to grant, to the maximum extent possible,
whether at the time of the initial grant or subsequently, any and
all of the rights conveyed by this License.
1.10. "Modifications"
means any of the following:
(a) any file in Source Code Form that results from an addition to,
deletion from, or modification of the contents of Covered
Software; or
(b) any new file in Source Code Form that contains any Covered
Software.
1.11. "Patent Claims" of a Contributor
means any patent claim(s), including without limitation, method,
process, and apparatus claims, in any patent Licensable by such
Contributor that would be infringed, but for the grant of the
License, by the making, using, selling, offering for sale, having
made, import, or transfer of either its Contributions or its
Contributor Version.
1.12. "Secondary License"
means either the GNU General Public License, Version 2.0, the GNU
Lesser General Public License, Version 2.1, the GNU Affero General
Public License, Version 3.0, or any later versions of those
licenses.
1.13. "Source Code Form"
means the form of the work preferred for making modifications.
1.14. "You" (or "Your")
means an individual or a legal entity exercising rights under this
License. For legal entities, "You" includes any entity that
controls, is controlled by, or is under common control with You. For
purposes of this definition, "control" means (a) the power, direct
or indirect, to cause the direction or management of such entity,
whether by contract or otherwise, or (b) ownership of more than
fifty percent (50%) of the outstanding shares or beneficial
ownership of such entity.
2. License Grants and Conditions
--------------------------------
2.1. Grants
Each Contributor hereby grants You a world-wide, royalty-free,
non-exclusive license:
(a) under intellectual property rights (other than patent or trademark)
Licensable by such Contributor to use, reproduce, make available,
modify, display, perform, distribute, and otherwise exploit its
Contributions, either on an unmodified basis, with Modifications, or
as part of a Larger Work; and
(b) under Patent Claims of such Contributor to make, use, sell, offer
for sale, have made, import, and otherwise transfer either its
Contributions or its Contributor Version.
2.2. Effective Date
The licenses granted in Section 2.1 with respect to any Contribution
become effective for each Contribution on the date the Contributor first
distributes such Contribution.
2.3. Limitations on Grant Scope
The licenses granted in this Section 2 are the only rights granted under
this License. No additional rights or licenses will be implied from the
distribution or licensing of Covered Software under this License.
Notwithstanding Section 2.1(b) above, no patent license is granted by a
Contributor:
(a) for any code that a Contributor has removed from Covered Software;
or
(b) for infringements caused by: (i) Your and any other third party's
modifications of Covered Software, or (ii) the combination of its
Contributions with other software (except as part of its Contributor
Version); or
(c) under Patent Claims infringed by Covered Software in the absence of
its Contributions.
This License does not grant any rights in the trademarks, service marks,
or logos of any Contributor (except as may be necessary to comply with
the notice requirements in Section 3.4).
2.4. Subsequent Licenses
No Contributor makes additional grants as a result of Your choice to
distribute the Covered Software under a subsequent version of this
License (see Section 10.2) or under the terms of a Secondary License (if
permitted under the terms of Section 3.3).
2.5. Representation
Each Contributor represents that the Contributor believes its
Contributions are its original creation(s) or it has sufficient rights
to grant the rights to its Contributions conveyed by this License.
2.6. Fair Use
This License is not intended to limit any rights You have under
applicable copyright doctrines of fair use, fair dealing, or other
equivalents.
2.7. Conditions
Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted
in Section 2.1.
3. Responsibilities
-------------------
3.1. Distribution of Source Form
All distribution of Covered Software in Source Code Form, including any
Modifications that You create or to which You contribute, must be under
the terms of this License. You must inform recipients that the Source
Code Form of the Covered Software is governed by the terms of this
License, and how they can obtain a copy of this License. You may not
attempt to alter or restrict the recipients' rights in the Source Code
Form.
3.2. Distribution of Executable Form
If You distribute Covered Software in Executable Form then:
(a) such Covered Software must also be made available in Source Code
Form, as described in Section 3.1, and You must inform recipients of
the Executable Form how they can obtain a copy of such Source Code
Form by reasonable means in a timely manner, at a charge no more
than the cost of distribution to the recipient; and
(b) You may distribute such Executable Form under the terms of this
License, or sublicense it under different terms, provided that the
license for the Executable Form does not attempt to limit or alter
the recipients' rights in the Source Code Form under this License.
3.3. Distribution of a Larger Work
You may create and distribute a Larger Work under terms of Your choice,
provided that You also comply with the requirements of this License for
the Covered Software. If the Larger Work is a combination of Covered
Software with a work governed by one or more Secondary Licenses, and the
Covered Software is not Incompatible With Secondary Licenses, this
License permits You to additionally distribute such Covered Software
under the terms of such Secondary License(s), so that the recipient of
the Larger Work may, at their option, further distribute the Covered
Software under the terms of either this License or such Secondary
License(s).
3.4. Notices
You may not remove or alter the substance of any license notices
(including copyright notices, patent notices, disclaimers of warranty,
or limitations of liability) contained within the Source Code Form of
the Covered Software, except that You may alter any license notices to
the extent required to remedy known factual inaccuracies.
3.5. Application of Additional Terms
You may choose to offer, and to charge a fee for, warranty, support,
indemnity or liability obligations to one or more recipients of Covered
Software. However, You may do so only on Your own behalf, and not on
behalf of any Contributor. You must make it absolutely clear that any
such warranty, support, indemnity, or liability obligation is offered by
You alone, and You hereby agree to indemnify every Contributor for any
liability incurred by such Contributor as a result of warranty, support,
indemnity or liability terms You offer. You may include additional
disclaimers of warranty and limitations of liability specific to any
jurisdiction.
4. Inability to Comply Due to Statute or Regulation
---------------------------------------------------
If it is impossible for You to comply with any of the terms of this
License with respect to some or all of the Covered Software due to
statute, judicial order, or regulation then You must: (a) comply with
the terms of this License to the maximum extent possible; and (b)
describe the limitations and the code they affect. Such description must
be placed in a text file included with all distributions of the Covered
Software under this License. Except to the extent prohibited by statute
or regulation, such description must be sufficiently detailed for a
recipient of ordinary skill to be able to understand it.
5. Termination
--------------
5.1. The rights granted under this License will terminate automatically
if You fail to comply with any of its terms. However, if You become
compliant, then the rights granted under this License from a particular
Contributor are reinstated (a) provisionally, unless and until such
Contributor explicitly and finally terminates Your grants, and (b) on an
ongoing basis, if such Contributor fails to notify You of the
non-compliance by some reasonable means prior to 60 days after You have
come back into compliance. Moreover, Your grants from a particular
Contributor are reinstated on an ongoing basis if such Contributor
notifies You of the non-compliance by some reasonable means, this is the
first time You have received notice of non-compliance with this License
from such Contributor, and You become compliant prior to 30 days after
Your receipt of the notice.
5.2. If You initiate litigation against any entity by asserting a patent
infringement claim (excluding declaratory judgment actions,
counter-claims, and cross-claims) alleging that a Contributor Version
directly or indirectly infringes any patent, then the rights granted to
You by any and all Contributors for the Covered Software under Section
2.1 of this License shall terminate.
5.3. In the event of termination under Sections 5.1 or 5.2 above, all
end user license agreements (excluding distributors and resellers) which
have been validly granted by You or Your distributors under this License
prior to termination shall survive termination.
************************************************************************
* *
* 6. Disclaimer of Warranty *
* ------------------------- *
* *
* Covered Software is provided under this License on an "as is" *
* basis, without warranty of any kind, either expressed, implied, or *
* statutory, including, without limitation, warranties that the *
* Covered Software is free of defects, merchantable, fit for a *
* particular purpose or non-infringing. The entire risk as to the *
* quality and performance of the Covered Software is with You. *
* Should any Covered Software prove defective in any respect, You *
* (not any Contributor) assume the cost of any necessary servicing, *
* repair, or correction. This disclaimer of warranty constitutes an *
* essential part of this License. No use of any Covered Software is *
* authorized under this License except under this disclaimer. *
* *
************************************************************************
************************************************************************
* *
* 7. Limitation of Liability *
* -------------------------- *
* *
* Under no circumstances and under no legal theory, whether tort *
* (including negligence), contract, or otherwise, shall any *
* Contributor, or anyone who distributes Covered Software as *
* permitted above, be liable to You for any direct, indirect, *
* special, incidental, or consequential damages of any character *
* including, without limitation, damages for lost profits, loss of *
* goodwill, work stoppage, computer failure or malfunction, or any *
* and all other commercial damages or losses, even if such party *
* shall have been informed of the possibility of such damages. This *
* limitation of liability shall not apply to liability for death or *
* personal injury resulting from such party's negligence to the *
* extent applicable law prohibits such limitation. Some *
* jurisdictions do not allow the exclusion or limitation of *
* incidental or consequential damages, so this exclusion and *
* limitation may not apply to You. *
* *
************************************************************************
8. Litigation
-------------
Any litigation relating to this License may be brought only in the
courts of a jurisdiction where the defendant maintains its principal
place of business and such litigation shall be governed by laws of that
jurisdiction, without reference to its conflict-of-law provisions.
Nothing in this Section shall prevent a party's ability to bring
cross-claims or counter-claims.
9. Miscellaneous
----------------
This License represents the complete agreement concerning the subject
matter hereof. If any provision of this License is held to be
unenforceable, such provision shall be reformed only to the extent
necessary to make it enforceable. Any law or regulation which provides
that the language of a contract shall be construed against the drafter
shall not be used to construe this License against a Contributor.
10. Versions of the License
---------------------------
10.1. New Versions
Mozilla Foundation is the license steward. Except as provided in Section
10.3, no one other than the license steward has the right to modify or
publish new versions of this License. Each version will be given a
distinguishing version number.
10.2. Effect of New Versions
You may distribute the Covered Software under the terms of the version
of the License under which You originally received the Covered Software,
or under the terms of any subsequent version published by the license
steward.
10.3. Modified Versions
If you create software not governed by this License, and you want to
create a new license for such software, you may create and use a
modified version of this License if you rename the license and remove
any references to the name of the license steward (except to note that
such modified license differs from this License).
10.4. Distributing Source Code Form that is Incompatible With Secondary
Licenses
If You choose to distribute Source Code Form that is Incompatible With
Secondary Licenses under the terms of this version of the License, the
notice described in Exhibit B of this License must be attached.
Exhibit A - Source Code Form License Notice
-------------------------------------------
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at http://mozilla.org/MPL/2.0/.
If it is not possible or desirable to put the notice in a particular
file, then You may include the notice in a location (such as a LICENSE
file in a relevant directory) where a recipient would be likely to look
for such a notice.
You may add additional accurate notices of copyright ownership.
Exhibit B - "Incompatible With Secondary Licenses" Notice
---------------------------------------------------------
This Source Code Form is "Incompatible With Secondary Licenses", as
defined by the Mozilla Public License, v. 2.0.

+ 9
- 0
README.pro View File

@ -0,0 +1,9 @@
title: prosidyc
---
#lit{prosidyc} is a Haskell library for compiling
#link[uri='https://prosidy.org']{Prosidy} documents into other formats
with less of the ceremony of explicit #lit{case ... of} clauses.
This library is in a #i{very early} state. Don't use it unless you enjoy
everything breaking.

+ 46
- 0
brittany.yaml View File

@ -0,0 +1,46 @@
conf_debug:
dconf_roundtrip_exactprint_only: false
dconf_dump_bridoc_simpl_par: false
dconf_dump_ast_unknown: false
dconf_dump_bridoc_simpl_floating: false
dconf_dump_config: false
dconf_dump_bridoc_raw: false
dconf_dump_bridoc_final: false
dconf_dump_bridoc_simpl_alt: false
dconf_dump_bridoc_simpl_indent: false
dconf_dump_annotations: false
dconf_dump_bridoc_simpl_columns: false
dconf_dump_ast_full: false
conf_forward:
options_ghc: []
conf_errorHandling:
econf_ExactPrintFallback: ExactPrintFallbackModeInline
econf_Werror: true
econf_omit_output_valid_check: false
econf_produceOutputOnErrors: false
conf_preprocessor:
ppconf_CPPMode: CPPModeAbort
ppconf_hackAroundIncludes: false
conf_obfuscate: false
conf_roundtrip_exactprint_only: false
conf_version: 1
conf_layout:
lconfig_reformatModulePreamble: true
lconfig_altChooser:
tag: AltChooserBoundedSearch
contents: 3
lconfig_allowSingleLineExportList: true
lconfig_importColumn: 50
lconfig_hangingTypeSignature: false
lconfig_importAsColumn: 50
lconfig_alignmentLimit: 30
lconfig_allowHangingQuasiQuotes: true
lconfig_indentListSpecial: true
lconfig_indentAmount: 4
lconfig_alignmentBreakOnMultiline: true
lconfig_cols: 80
lconfig_indentPolicy: IndentPolicyFree
lconfig_indentWhereSpecial: true
lconfig_columnAlignMode:
tag: ColumnAlignModeMajority
contents: 0.7

+ 4
- 0
cabal.project View File

@ -0,0 +1,4 @@
packages: prosidyc.cabal
optimization: True
split-sections: True
test-show-details: direct

+ 4
- 0
hie.yaml View File

@ -0,0 +1,4 @@
cradle:
cabal:
- path: '.'
component: 'lib:prosidyc'

+ 120
- 0
prosidyc.cabal View File

@ -0,0 +1,120 @@
cabal-version: 2.4
name: prosidyc
version: 0.1.0.0
synopsis: A DSL for processing Prosidy documents.
license: MPL-2.0
license-file: LICENSE
author: James Alexander Feldman-Crough
maintainer: alex@fldcr.com
copyright: ©2020 to James Alexander Feldman-Crough
category: Language
extra-source-files: CHANGELOG, README.pro
tested-with:
GHC == 8.6.5
, GHC == 8.8.1
description:
A small, Haskell EDSL which builds a specification and compiler for
Prosidy dialects.
source-repository head
type: git
location: https://git.fldcr.com/prosidy/prosidyc
flag fatal-warnings
description: Turns all warnings into errors. Used in CI.
default: False
manual: True
-------------------------------------------------------------------------------
library
default-language: Haskell2010
hs-source-dirs: src
ghc-options:
-Wall
-Wno-name-shadowing
if flag(fatal-warnings)
ghc-options:
-Werror
exposed-modules:
Prosidy.Compile
, Prosidy.Compile.Core
, Prosidy.Compile.Error
, Prosidy.Compile.Match
other-modules:
Prosidy.Compile.Run
build-depends:
base >= 4.11 && < 5
, prosidy >= 1.6 && < 1.7
, mtl
, microlens
, microlens-mtl
, text
, bytestring
, containers
, unordered-containers
, free
, hashable
, profunctors
, transformers
-- , aeson >= 1.4 && < 1.5
-- , bytestring >= 0.10 && < 0.11
-- , binary >= 0.8 && < 0.9
-- , containers >= 0.6 && < 0.7
-- , contravariant >= 1.5 && < 1.6
-- , deepseq >= 1.4 && < 1.5
-- , hashable >= 1.2 && < 1.4
-- , megaparsec >= 7.0 && < 8.1
-- , profunctors >= 5.3 && < 5.6
-- , tagged >= 0.8 && < 0.9
-- , text >= 1.2 && < 1.3
-- , transformers >= 0.5 && < 0.6
-- , vector >= 0.12 && < 0.13
-- , unordered-containers >= 0.2 && < 0.3
-------------------------------------------------------------------------------
-- test-suite prosidy-test
-- default-language: Haskell2010
-- type: exitcode-stdio-1.0
-- hs-source-dirs: test
--
-- ghc-options:
-- -Wall
-- -Wno-name-shadowing
--
-- main-is:
-- Prosidy/Test.hs
--
-- other-modules:
-- Prosidy.Test.Source
-- , Prosidy.Test.Types
-- , Prosidy.Test.Parse
-- , Paths_prosidy
--
-- autogen-modules:
-- Paths_prosidy
--
-- build-depends:
-- base
-- , prosidy
-- , aeson >= 1.4 && < 1.5
-- , aeson-pretty >= 0.8 && < 0.9
-- , aeson-diff >= 1.1 && < 1.2
-- , bytestring >= 0.10 && < 0.11
-- , containers >= 0.6 && < 0.7
-- , directory >= 1.3 && < 1.4
-- , filepath >= 1.4 && < 1.5
-- , tasty >= 1.2 && < 1.3
-- , tasty-ant-xml >= 1.1 && < 1.2
-- , tasty-golden >= 2.3 && < 2.4
-- , tasty-hunit >= 0.10 && < 1.11
-- , tasty-quickcheck >= 0.10 && < 0.11
-- , text >= 1.2 && < 1.3

+ 12
- 0
scripts/documentation-coverage View File

@ -0,0 +1,12 @@
#!/bin/bash
# code: language=sh
set -e
tmpfile="$(mktemp)"
trap "rm -f $tmpfile" EXIT
cabal v2-haddock --haddock-for-hackage --enable-documentation 2>&1 | tee "$tmpfile"
if grep --quiet --fixed-strings 'Missing documentation for:' "$tmpfile"
then
printf -- '-----\nERROR: Not all public exports have documentation.' >&2
exit 1
fi

+ 15
- 0
scripts/release View File

@ -0,0 +1,15 @@
#!/bin/bash
set -euo pipefail
cd "$(git rev-parse --show-toplevel)"
version="$(grep '^version:' prosidyc.cabal | sed 's|^version: *||')"
echo "Publishing v${version}" >&2
do-upload ()
{
cabal upload --username="${HACKAGE_USER}" --password="${HACKAGE_PASSWORD}" "$@"
}
cabal sdist
do-upload "dist-newstyle/sdist/prosidyc-${version}.tar.gz"
do-upload --documentation "dist-newstyle/prosidyc-${version}-docs.tar.gz"

+ 85
- 0
src/Prosidy/Compile.hs View File

@ -0,0 +1,85 @@
{-|
Module : Prosidy.Compile
Description : Compile Prosidy documents into other shapes
Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Prosidy.Compile
( -- * Accessors
escapeHatch
, getContent
, matchContent
, optParse
, prop
, reqParse
, traversing
, self
-- * Reëxports
, RuleT
, Rule
, CanMatch
, Error(..)
, ErrorSet
, module Prosidy.Compile.Match
, module Prosidy.Compile.Run
)
where
import Prelude hiding ( break )
import Prosidy.Compile.Core
import Prosidy.Compile.Error
import Prosidy.Compile.Match
import Prosidy.Compile.Run
import Data.Text ( Text )
import qualified Prosidy as P
-------------------------------------------------------------------------------
-- | Access the inner 'Prosidy.Types.Content' of a node.
getContent :: P.HasContent i => RuleT (P.Content i) e f a -> RuleT i e f a
getContent = rule . GetContent
-- | Traverse over each item in a node's 'P.Content' via fallible matches.
matchContent
:: (Traversable t, P.HasContent i, t x ~ P.Content i, CanMatch x)
=> Match x e f a
-> RuleT i e f (t a)
matchContent = getContent . traversing . match
-- | Parse an optional setting from a node with attached 'P.Metadata'.
optParse
:: P.HasMetadata i
=> P.Key
-> (Text -> Either String a)
-> RuleT i e f (Maybe a)
optParse key = rule . GetSetting id key
-- | Check if a property is set on a node with attached 'P.Metadata'.
prop :: P.HasMetadata i => P.Key -> RuleT i e f Bool
prop = rule . GetProperty id
-- | Parse an required setting from a node with attached 'P.Metadata'.
reqParse
:: P.HasMetadata i => P.Key -> (Text -> Either String a) -> RuleT i e f a
reqParse key = rule . GetRequiredSetting key
-- | Lift a 'RuleT' so that it operates on a traversable structure.
traversing :: Traversable t => RuleT i e f a -> RuleT (t i) e f (t a)
traversing = rule . Traverse id id
-- | Access the contents of a node.
self :: RuleT i e f i
self = rule $ GetSelf id
-- | Do anything you want with a node. This should be used sparingly! The
-- actions you perform inside of this function are invisible to inspection.
escapeHatch :: (i -> f (Either (Error e) a)) -> RuleT i e f a
escapeHatch = rule . Lift

+ 291
- 0
src/Prosidy/Compile/Core.hs View File

@ -0,0 +1,291 @@
{-|
Module : Prosidy.Compile.Core
Description : Primitive type definitions and functions.
Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
module Prosidy.Compile.Core
( RuleF(..)
, RuleT
, Rule
, CanMatch(evalPattern, noMatchError)
, Pattern(..)
, Interpret
, BlockRegion
, InlineRegion
, LiteralRegion
, interpretWith
, evalPatterns
, rule
)
where
import Lens.Micro
import Prosidy.Compile.Error
import Prosidy ( Key
, HasLocation
, HasMetadata
, HasContent(Content)
)
import Data.Text ( Text )
import Data.Bifunctor ( Bifunctor(..) )
import Data.List.NonEmpty ( NonEmpty(..) )
import Control.Monad.Except ( runExceptT )
import Control.Monad.Trans.Class ( MonadTrans(..) )
import Data.Functor.Identity ( Identity )
import qualified Prosidy
import qualified Control.Applicative.Free.Final
as Ap
-- | A single compilation rule. Parameterized by the following types:
--
-- * @input@: The type of the Prosidy node that is currently accessible.
--
-- * @error@: Allows users to specify a custom error type to be used for
-- throwing errors. 'Data.Void.Void' can be used to rely solely on
-- the errors built into this library.
--
-- * @context@: A 'Monad' for performing contextual computation beyond what
-- is provided by this library. If additional contextual computation is not
-- desired, use 'Data.Functor.Identity.Identity' as the type.
--
-- * @output@: The resulting output type.
newtype RuleT input error context output = RuleT
(Ap.Ap (RuleF input error context) output)
deriving (Functor, Applicative)
instance MonadTrans (RuleT input error) where
lift = rule . Lift . const . fmap Right
-- | 'RuleT' without a contextual environment.
type Rule input error = RuleT input error Identity
-- | Lifts a 'RuleF' into a 'RuleT'.
rule :: RuleF i e f o -> RuleT i e f o
rule = RuleT . Ap.liftAp
-- | The control functor for compiling Prosidy elements. Each action
-- corresponds to an action to perform on the @input@ variable.
--
-- See 'RuleT' and 'Rule' for use of this type.
data RuleF input error context output where
-- | Throw an error.
Fail
::Error error
-> RuleF input error context output
-- | Embed a raw action as a rule. Note: Please avoid using this if
-- possible: it breaks static introspection!
Lift
::(input -> context (Either (Error error) output))
-> RuleF input error context output
-- | Given a non-empty list of potential cases, construct a Rule that
-- processes any items matching at least one of those cases.
TestMatch
::(CanMatch input)
=> NonEmpty (Pattern input error context output)
-> RuleF input error context output
Traverse
::Traversable t
=> (input -> t i)
-> (t o -> output)
-> RuleT i error context o
-> RuleF input error context output
-- | When @input@ is a value wrapping some 'Content', enable access to that
-- 'Content' by wrapping a 'RuleT'.
GetContent
::HasContent input
=> RuleT (Content input) error context output
-> RuleF input error context output
-- | Fetch a property from items with metadata.
GetProperty
::HasMetadata input
=> (Bool -> a)
-> Key
-> RuleF input error context a
-- | Fetch an /optional/ setting from items with metadata.
GetSetting
::HasMetadata input
=> (Maybe x -> output)
-> Key
-> (Text -> Either String x)
-> RuleF input error context output
-- | Fetch a /required/ setting from items with metadata.
GetRequiredSetting
::HasMetadata input
=> Key
-> (Text -> Either String output)
-> RuleF input error context output
-- | Get the raw text from a 'Text' node.
GetSelf
::(input -> output)
-> RuleF input error context output
instance Functor context => Functor (RuleF input error context) where
fmap fn = \case
Fail error -> Fail error
Lift lift -> Lift $ fmap (fmap fn) . lift
TestMatch matches -> TestMatch $ fmap (fmap fn) matches
Traverse f g rule -> Traverse f (fn . g) rule
GetContent rule -> GetContent $ fmap fn rule
GetProperty k key -> GetProperty (fn . k) key
GetSetting k key parse -> GetSetting (fn . k) key parse
GetRequiredSetting key parse ->
GetRequiredSetting key (fmap fn . parse)
GetSelf k -> GetSelf (fn . k)
-------------------------------------------------------------------------------
-- | A (lawless) typeclass for enabling fallible matching on nodes.
--
-- Implementing new instances of this class in library code is *unneccessary*
-- and *unsupported*.
class (forall i e. Functor (Pattern t i e), HasLocation t) => CanMatch t where
-- | A data type representing allowable fallible patterns for @t@.
data family Pattern t :: * -> (* -> *) -> * -> *
-- | Information about why a @Pattern@ failed to match.
data family NoMatch t :: *
-- | Attempt to match a pattern against a value.
evalPattern ::
Applicative g
=> Pattern t error context output
-- ^ The @Pattern@ to match against
-> Interpret error context g
-- ^ An interpreter for evaluating the match.
-> t
-- ^ The value to attempt to match against
-> Either (NoMatch t) (g output)
-- | Lift a @NoMatch@ error into the 'Error' type.
noMatchError :: NoMatch t -> Error e
instance CanMatch Prosidy.Block where
data Pattern Prosidy.Block error context output =
BlockTagP Key (RuleT BlockRegion error context output)
| LitTagP Key (RuleT LiteralRegion error context output)
| ParagraphP (RuleT (Prosidy.SeriesNE Prosidy.Inline) error context output)
deriving Functor
data NoMatch Prosidy.Block =
NoMatchBlockTag Key
| NoMatchLitTag Key
| NoMatchParagraph
evalPattern (BlockTagP key rule) = evalPatternWith
(Prosidy._BlockTag . Prosidy.tagged key)
(NoMatchBlockTag key)
rule
evalPattern (LitTagP key rule) = evalPatternWith
(Prosidy._BlockLiteral . Prosidy.tagged key)
(NoMatchLitTag key)
rule
evalPattern (ParagraphP rule) = evalPatternWith
(Prosidy._BlockParagraph . Prosidy.content)
NoMatchParagraph
rule
noMatchError (NoMatchBlockTag key) = ExpectedTag BlockKind key
noMatchError (NoMatchLitTag key) = ExpectedTag LiteralKind key
noMatchError NoMatchParagraph = ExpectedParagraph
instance CanMatch Prosidy.Inline where
data Pattern Prosidy.Inline error context output =
InlineTagP Key (RuleT InlineRegion error context output)
| BreakP (RuleT () error context output)
| TextP (RuleT Text error context output)
deriving Functor
data NoMatch Prosidy.Inline =
NoMatchInlineTag Key
| NoMatchBreak
| NoMatchText
evalPattern (InlineTagP key rule) = evalPatternWith
(Prosidy._InlineTag . Prosidy.tagged key)
(NoMatchInlineTag key)
rule
evalPattern (TextP rule) =
evalPatternWith (Prosidy._Text . Prosidy.fragment) NoMatchText rule
evalPattern (BreakP rule) =
evalPatternWith Prosidy._Break NoMatchBreak rule
noMatchError (NoMatchInlineTag key) = ExpectedTag InlineKind key
noMatchError NoMatchText = ExpectedText
noMatchError NoMatchBreak = ExpectedBreak
-- | Match one or more patterns, in sequence, against a value. The result from
-- the first successful pattern will be returned. Subsequent matches will not
-- be tried.
evalPatterns
:: (CanMatch i, IsError e, MonadErrors e g)
=> NonEmpty (Pattern i e f o)
-> Interpret e f g
-> i
-> g o
evalPatterns (x :| xs) interpret input =
runExceptT folded >>= either throwError pure
where
folded = foldr (\pat acc -> doEval pat `orElse` acc) (doEval x) xs
doEval pat = either (throwError1 . noMatchError) lift
$ evalPattern pat interpret input
orElse lhsM rhsM = do
lhs <- lift $ runExceptT lhsM
case lhs of
Right ok -> pure ok
Left err -> rhsM `catchError` \err' -> throwError $ err <> err'
evalPatternWith
:: Applicative g
=> Traversal' i j
-> e
-> RuleT j e' f o
-> Interpret e' f g
-> i
-> Either e (g o)
evalPatternWith sel error rule interpret input =
second (interpretWith rule interpret)
. maybe (Left error) Right
$ input
^? sel
-------------------------------------------------------------------------------
-- | Build an interpreter into a functor @g@.
interpretWith :: Applicative g => RuleT i e f a -> Interpret e f g -> i -> g a
interpretWith (RuleT ap) int i = Ap.runAp (int i) ap
-------------------------------------------------------------------------------
-- | Runs a single 'RuleF' into an applicative @g@. Passing this value to
-- 'interpretWith' will fully evaluate a 'RuleT' into the same functor.
type Interpret e f g = forall i a . i -> RuleF i e f a -> g a
-------------------------------------------------------------------------------
-- | A 'Prosidy.Types.BlockTag' with the tag name removed.
type BlockRegion = Prosidy.Region (Prosidy.Series Prosidy.Block)
-- | An 'Prosidy.Types.InlineTag' with the tag name removed.
type InlineRegion = Prosidy.Region (Prosidy.Series Prosidy.Inline)
-- | A 'Prosidy.Types.LiteralTag' with the tag name removed.
type LiteralRegion = Prosidy.Region Text

+ 175
- 0
src/Prosidy/Compile/Error.hs View File

@ -0,0 +1,175 @@
{-|
Module : Prosidy.Compile.Error
Description : Error definitions and utility functions.
Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
module Prosidy.Compile.Error
( Error(..)
, TagKind(..)
, ErrorSet
, Error'
, ErrorSet'
, IsError
, MonadErrors
, singleError
, customError
, throwError1
, allErrors
, attachLocation
, MonadError(..)
)
where
import Lens.Micro
import Control.Exception ( Exception(..) )
import Prosidy.Types.Key ( Key )
import Prosidy.Source ( Line(..)
, Column(..)
, Location
)
import Prosidy.Optics.Source ( HasLocation(..)
, line
, column
)
import Data.HashSet ( HashSet
, singleton
)
import Control.Monad.Except ( MonadError(..)
, throwError
)
import GHC.Generics ( Generic )
import Data.Hashable ( Hashable )
import Data.Typeable ( Typeable )
import Data.Void ( Void )
import Data.Foldable ( toList )
import Data.List.NonEmpty ( NonEmpty(..)
, nonEmpty
)
-- | A contraint alias for types returning at least one error.
type MonadErrors e = MonadError (ErrorSet e)
-- | A constraint alias for errors throwable in a context admitting a
-- 'MonadErrors' instance.
type IsError e = (Exception e, Hashable e, Eq e)
-- | A non-empty set of errors.
newtype ErrorSet e =
ErrorSet (HashSet (Error e))
deriving stock (Show, Generic, Eq)
deriving anyclass (Hashable)
instance IsError e => Semigroup (ErrorSet e) where
ErrorSet lhs <> ErrorSet rhs = ErrorSet $! lhs <> rhs
-- | A type alias for 'ErrorSet's which never contain empty errors.
type ErrorSet' = ErrorSet Void
-- | Enumerates the errors thrown when
data Error a =
Custom a
-- ^ A custom error, allowing extensibility.
| ParseError Key String
-- ^ Thrown when parsing a setting fails.
| Required Key
-- ^ Thrown when a setting was required to be set, but wasn't provided.
| ExpectedTag TagKind Key
-- ^ Thrown when matching against a 'Prosidy.Tag', and another node was
-- found, or the input tag's 'Key' didn't match the specified key.
| ExpectedParagraph
-- ^ Thrown when matching against paragraph and an unexpected node was
-- encountered.
| ExpectedText
-- ^ Thrown when matching against text and an unexpected node was
-- encountered.
| ExpectedBreak
-- ^ Thrown when matching against an explicit break and an unexpected node
-- was encountered.
| EmptyMatch
-- ^ Thrown when a match has no cases to check against.
| Group (Maybe Location) (ErrorSet a)
-- ^ Used to group a set of errors thrown at the same point in a tree.
-- If a location is available, we attach it for debugging.
deriving (Eq, Show, Generic, Hashable)
instance (Typeable a, Exception a) => Exception (Error a) where
displayException (Custom a ) = displayException a
displayException (ParseError k msg) = mconcat
[ showString "failed to parse the setting "
, shows k
, showString ": "
, showString msg
]
""
displayException EmptyMatch = "Match provided with no possible cases."
displayException (Required k) = "missing required setting " <> show k
displayException (ExpectedTag kind k) =
"expected a " <> show kind <> " tag with key " <> show k
displayException ExpectedParagraph = "expected a paragrapgh"
displayException ExpectedText = "expected plain text"
displayException ExpectedBreak = "expected a break"
displayException (Group (Just loc) x) = mconcat
[ showString "error(s) encountered at line "
, shows (loc ^?! line . to (\(Line n) -> succ n))
, showString " column "
, shows (loc ^?! column . to (\(Column n) -> succ n))
, showString ":\n"
, foldMap
(\exn -> showString (displayException exn) <> showChar '\n')
(allErrors x)
]
""
displayException (Group Nothing x) = foldMap
(\exn -> showString (displayException exn) <> showChar '\n')
(allErrors x)
""
-- | A type alias for 'Error's that never throw a custom error.
type Error' = Error Void
-- | A marker class for marking which type of tag 'ExpectedTag' was expecting.
data TagKind = BlockKind | InlineKind | LiteralKind
deriving (Show, Eq, Generic, Hashable)
-- | Group errors together, attaching a location if one is available.
attachLocation :: (IsError e, MonadErrors e m, HasLocation l) => l -> m a -> m a
attachLocation item = flip catchError $ throwError1 . Group (item ^? location)
-- | Lift a single 'Error' into an 'ErrorSet'.
singleError :: Hashable e => Error e -> ErrorSet e
singleError = ErrorSet . singleton
{-# INLINE singleError #-}
-- | Lift a custom error into an 'ErrorSet'.
customError :: Hashable e => e -> ErrorSet e
customError = singleError . Custom
{-# INLINE customError #-}
-- | Throw a single error.
throwError1 :: Hashable e => MonadErrors e m => Error e -> m a
throwError1 = throwError . singleError
{-# INLINE throwError1 #-}
-- | Return the set of errors in an 'ErrorSet' as a non-empty list.
allErrors :: ErrorSet e -> NonEmpty (Error e)
allErrors (ErrorSet hs) =
maybe (error "unexpected empty ErrorSet") id . nonEmpty $ toList hs

+ 91
- 0
src/Prosidy/Compile/Match.hs View File

@ -0,0 +1,91 @@
{-|
Module : Prosidy.Compile.Match
Description : Fallible pattern rules.
Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE DerivingVia #-}
module Prosidy.Compile.Match
( -- * DSL for matching cases
Match
, MatchM
, match
-- ** Specific matchers
, break
, breakWith
, blocktag
, inlinetag
, literaltag
, paragraph
, text
)
where
import Prelude hiding ( break )
import Prosidy.Compile.Core
import Prosidy.Compile.Error
import Control.Monad.State ( StateT(..)
, State
, modify'
, execState
)
import Data.Monoid ( Endo(..) )
import Data.Text ( Text )
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Prosidy as P
-- | The type of fallible pattern specifications.
type Match i e f a = MatchM i e a f ()
-- | A monadic interface for defining fallible patterns. In practice, @r@ will
-- always be instantiated to @()@— 'Match' can be more clear.
newtype MatchM i e a f r = MatchM (State (Endo [Pattern i e f a]) r)
deriving (Functor, Applicative, Monad)
via State (Endo [Pattern i e f a])
-- | Finalize a 'Match' into a rule. This is often used to offset a match
-- block:
--
-- @
-- blocktags :: Match Block Void Identity String
-- blocktags = match $ do
-- ...
-- @
match :: CanMatch i => Match i e f a -> RuleT i e f a
match (MatchM s) = case appEndo (execState s mempty) [] of
x : xs -> rule . TestMatch $ x :| xs
[] -> rule $ Fail EmptyMatch
-- | Match against a 'Prosidy.Typs.Break'.
break :: RuleT () e f a -> Match P.Inline e f a
break = put . BreakP
-- | Replace all 'Prosidy.Types.Break's with the provided value.
breakWith :: a -> Match P.Inline e f a
breakWith = put . BreakP . pure
-- | Match a 'Prosidy.Types.BlockTag' with the given 'P.Key'.
blocktag :: P.Key -> RuleT BlockRegion e f a -> Match P.Block e f a
blocktag key = put . BlockTagP key
-- | Match an 'Prosidy.Types.InlineTag' with the given 'P.Key'.
inlinetag :: P.Key -> RuleT InlineRegion e f a -> Match P.Inline e f a
inlinetag key = put . InlineTagP key
-- | Match an 'Prosidy.Types.LiteralTag' with the given 'P.Key'.
literaltag :: P.Key -> RuleT LiteralRegion e f a -> Match P.Block e f a
literaltag key = put . LitTagP key
-- | Match 'Prosidy.Types.Paragraph's in a block context.
paragraph :: RuleT (P.SeriesNE P.Inline) e f a -> Match P.Block e f a
paragraph = put . ParagraphP
-- | Match plain 'Text' in an inline context.
text :: RuleT Text e f a -> Match P.Inline e f a
text = put . TextP
put :: Pattern i e f a -> Match i e f a
put x = MatchM $ modify' (<> Endo (x :))

+ 73
- 0
src/Prosidy/Compile/Run.hs View File

@ -0,0 +1,73 @@
{-|
Module : Prosidy.Compile.Run
Description : Interpretation of compilation rules.
Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
module Prosidy.Compile.Run (run, runM) where
import Lens.Micro
import Prosidy.Compile.Core
import Prosidy.Compile.Error
import Control.Monad.Trans ( MonadIO(..)
, MonadTrans(..)
)
import Control.Monad.Except ( ExceptT(..) )
import Data.Functor.Identity ( Identity(..) )
import qualified Prosidy as P
-------------------------------------------------------------------------------
-- | Run a 'Rule' against an input, returning a parse result.
run :: IsError e => RuleT i e Identity a -> i -> Either (ErrorSet e) a
run rule = runIdentity . runM rule
-- | Run a 'RuleT' against an input, returning a contextual parse result.
runM
:: (Monad context, IsError e)
=> RuleT i e context a
-> i
-> context (Either (ErrorSet e) a)
runM rule = (\(Run x) -> x) . runRun rule
-------------------------------------------------------------------------------
newtype Run error context output = Run
(context (Either (ErrorSet error) output))
deriving (Functor, Applicative, Monad, MonadError (ErrorSet error))
via (ExceptT (ErrorSet error) context)
instance MonadIO context => MonadIO (Run error context) where
liftIO = lift . liftIO
instance MonadTrans (Run error) where
lift = Run . fmap Right
runRun
:: (Monad context, IsError e) => RuleT i e context a -> i -> Run e context a
runRun rule = interpretWith rule interpret
interpret
:: (Monad context, IsError error)
=> Interpret error context (Run error context)
interpret input = \case
Fail e -> throwError1 e
Lift lifted -> lift (lifted input) >>= either throwError1 pure
TestMatch matches ->
attachLocation input $ evalPatterns matches interpret input
Traverse f g rule -> do
fmap g . traverse (runRun rule) $ f input
GetContent rule -> runRun rule $ input ^. P.content
GetProperty k key -> input ^. P.hasProperty key & pure . k
GetSetting k key parse ->
input ^. P.atSetting key & traverse parse & either
(throwError1 . ParseError key)
(pure . k)
GetRequiredSetting key parse -> do
raw <-
input ^. P.atSetting key & maybe (throwError1 $ Required key) pure
either (throwError1 . ParseError key) pure $ parse raw
GetSelf k -> pure $ k input

Write Preview
Loading…
Cancel
Save