fluent-syntax (empty) → 1.0.0
raw patch · 8 files changed
+1340/−0 lines, 8 filesdep +aesondep +attoparsecdep +basesetup-changed
Dependencies added: aeson, attoparsec, base, directory, filepath, fluent-syntax, hashable, hspec, template-haskell, text
Files
- CHANGELOG.md +12/−0
- LICENCE +287/−0
- Setup.hs +2/−0
- fluent-syntax.cabal +82/−0
- src/Language/Fluent/AST.hs +200/−0
- src/Language/Fluent/Parser.hs +412/−0
- src/Language/Fluent/TH.hs +163/−0
- test/Main.hs +182/−0
+ CHANGELOG.md view
@@ -0,0 +1,12 @@+# Changelog++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/).++## [1.0.0] - 2026-10-01++### Added++- Initial release.
+ LICENCE view
@@ -0,0 +1,287 @@+ EUROPEAN UNION PUBLIC LICENCE v. 1.2+ EUPL © the European Union 2007, 2016++This European Union Public Licence (the ‘EUPL’) applies to the Work (as defined+below) which is provided under the terms of this Licence. Any use of the Work,+other than as authorised under this Licence is prohibited (to the extent such+use is covered by a right of the copyright holder of the Work).++The Work is provided under the terms of this Licence when the Licensor (as+defined below) has placed the following notice immediately following the+copyright notice for the Work:++ Licensed under the EUPL++or has expressed by any other means his willingness to license under the EUPL.++1. Definitions++In this Licence, the following terms have the following meaning:++- ‘The Licence’: this Licence.++- ‘The Original Work’: the work or software distributed or communicated by the+ Licensor under this Licence, available as Source Code and also as Executable+ Code as the case may be.++- ‘Derivative Works’: the works or software that could be created by the+ Licensee, based upon the Original Work or modifications thereof. This Licence+ does not define the extent of modification or dependence on the Original Work+ required in order to classify a work as a Derivative Work; this extent is+ determined by copyright law applicable in the country mentioned in Article 15.++- ‘The Work’: the Original Work or its Derivative Works.++- ‘The Source Code’: the human-readable form of the Work which is the most+ convenient for people to study and modify.++- ‘The Executable Code’: any code which has generally been compiled and which is+ meant to be interpreted by a computer as a program.++- ‘The Licensor’: the natural or legal person that distributes or communicates+ the Work under the Licence.++- ‘Contributor(s)’: any natural or legal person who modifies the Work under the+ Licence, or otherwise contributes to the creation of a Derivative Work.++- ‘The Licensee’ or ‘You’: any natural or legal person who makes any usage of+ the Work under the terms of the Licence.++- ‘Distribution’ or ‘Communication’: any act of selling, giving, lending,+ renting, distributing, communicating, transmitting, or otherwise making+ available, online or offline, copies of the Work or providing access to its+ essential functionalities at the disposal of any other natural or legal+ person.++2. Scope of the rights granted by the Licence++The Licensor hereby grants You a worldwide, royalty-free, non-exclusive,+sublicensable licence to do the following, for the duration of copyright vested+in the Original Work:++- use the Work in any circumstance and for all usage,+- reproduce the Work,+- modify the Work, and make Derivative Works based upon the Work,+- communicate to the public, including the right to make available or display+ the Work or copies thereof to the public and perform publicly, as the case may+ be, the Work,+- distribute the Work or copies thereof,+- lend and rent the Work or copies thereof,+- sublicense rights in the Work or copies thereof.++Those rights can be exercised on any media, supports and formats, whether now+known or later invented, as far as the applicable law permits so.++In the countries where moral rights apply, the Licensor waives his right to+exercise his moral right to the extent allowed by law in order to make effective+the licence of the economic rights here above listed.++The Licensor grants to the Licensee royalty-free, non-exclusive usage rights to+any patents held by the Licensor, to the extent necessary to make use of the+rights granted on the Work under this Licence.++3. Communication of the Source Code++The Licensor may provide the Work either in its Source Code form, or as+Executable Code. If the Work is provided as Executable Code, the Licensor+provides in addition a machine-readable copy of the Source Code of the Work+along with each copy of the Work that the Licensor distributes or indicates, in+a notice following the copyright notice attached to the Work, a repository where+the Source Code is easily and freely accessible for as long as the Licensor+continues to distribute or communicate the Work.++4. Limitations on copyright++Nothing in this Licence is intended to deprive the Licensee of the benefits from+any exception or limitation to the exclusive rights of the rights owners in the+Work, of the exhaustion of those rights or of other applicable limitations+thereto.++5. Obligations of the Licensee++The grant of the rights mentioned above is subject to some restrictions and+obligations imposed on the Licensee. Those obligations are the following:++Attribution right: The Licensee shall keep intact all copyright, patent or+trademarks notices and all notices that refer to the Licence and to the+disclaimer of warranties. The Licensee must include a copy of such notices and a+copy of the Licence with every copy of the Work he/she distributes or+communicates. The Licensee must cause any Derivative Work to carry prominent+notices stating that the Work has been modified and the date of modification.++Copyleft clause: If the Licensee distributes or communicates copies of the+Original Works or Derivative Works, this Distribution or Communication will be+done under the terms of this Licence or of a later version of this Licence+unless the Original Work is expressly distributed only under this version of the+Licence — for example by communicating ‘EUPL v. 1.2 only’. The Licensee+(becoming Licensor) cannot offer or impose any additional terms or conditions on+the Work or Derivative Work that alter or restrict the terms of the Licence.++Compatibility clause: If the Licensee Distributes or Communicates Derivative+Works or copies thereof based upon both the Work and another work licensed under+a Compatible Licence, this Distribution or Communication can be done under the+terms of this Compatible Licence. For the sake of this clause, ‘Compatible+Licence’ refers to the licences listed in the appendix attached to this Licence.+Should the Licensee's obligations under the Compatible Licence conflict with+his/her obligations under this Licence, the obligations of the Compatible+Licence shall prevail.++Provision of Source Code: When distributing or communicating copies of the Work,+the Licensee will provide a machine-readable copy of the Source Code or indicate+a repository where this Source will be easily and freely available for as long+as the Licensee continues to distribute or communicate the Work.++Legal Protection: This Licence does not grant permission to use the trade names,+trademarks, service marks, or names of the Licensor, except as required for+reasonable and customary use in describing the origin of the Work and+reproducing the content of the copyright notice.++6. Chain of Authorship++The original Licensor warrants that the copyright in the Original Work granted+hereunder is owned by him/her or licensed to him/her and that he/she has the+power and authority to grant the Licence.++Each Contributor warrants that the copyright in the modifications he/she brings+to the Work are owned by him/her or licensed to him/her and that he/she has the+power and authority to grant the Licence.++Each time You accept the Licence, the original Licensor and subsequent+Contributors grant You a licence to their contributions to the Work, under the+terms of this Licence.++7. Disclaimer of Warranty++The Work is a work in progress, which is continuously improved by numerous+Contributors. It is not a finished work and may therefore contain defects or+‘bugs’ inherent to this type of development.++For the above reason, the Work is provided under the Licence on an ‘as is’ basis+and without warranties of any kind concerning the Work, including without+limitation merchantability, fitness for a particular purpose, absence of defects+or errors, accuracy, non-infringement of intellectual property rights other than+copyright as stated in Article 6 of this Licence.++This disclaimer of warranty is an essential part of the Licence and a condition+for the grant of any rights to the Work.++8. Disclaimer of Liability++Except in the cases of wilful misconduct or damages directly caused to natural+persons, the Licensor will in no event be liable for any direct or indirect,+material or moral, damages of any kind, arising out of the Licence or of the use+of the Work, including without limitation, damages for loss of goodwill, work+stoppage, computer failure or malfunction, loss of data or any commercial+damage, even if the Licensor has been advised of the possibility of such damage.+However, the Licensor will be liable under statutory product liability laws as+far such laws apply to the Work.++9. Additional agreements++While distributing the Work, You may choose to conclude an additional agreement,+defining obligations or services consistent with this Licence. However, if+accepting obligations, You may act only on your own behalf and on your sole+responsibility, not on behalf of the original Licensor or any other Contributor,+and only if You agree to indemnify, defend, and hold each Contributor harmless+for any liability incurred by, or claims asserted against such Contributor by+the fact You have accepted any warranty or additional liability.++10. Acceptance of the Licence++The provisions of this Licence can be accepted by clicking on an icon ‘I agree’+placed under the bottom of a window displaying the text of this Licence or by+affirming consent in any other similar way, in accordance with the rules of+applicable law. Clicking on that icon indicates your clear and irrevocable+acceptance of this Licence and all of its terms and conditions.++Similarly, you irrevocably accept this Licence and all of its terms and+conditions by exercising any rights granted to You by Article 2 of this Licence,+such as the use of the Work, the creation by You of a Derivative Work or the+Distribution or Communication by You of the Work or copies thereof.++11. Information to the public++In case of any Distribution or Communication of the Work by means of electronic+communication by You (for example, by offering to download the Work from a+remote location) the distribution channel or media (for example, a website) must+at least provide to the public the information requested by the applicable law+regarding the Licensor, the Licence and the way it may be accessible, concluded,+stored and reproduced by the Licensee.++12. Termination of the Licence++The Licence and the rights granted hereunder will terminate automatically upon+any breach by the Licensee of the terms of the Licence.++Such a termination will not terminate the licences of any person who has+received the Work from the Licensee under the Licence, provided such persons+remain in full compliance with the Licence.++13. Miscellaneous++Without prejudice of Article 9 above, the Licence represents the complete+agreement between the Parties as to the Work.++If any provision of the Licence is invalid or unenforceable under applicable+law, this will not affect the validity or enforceability of the Licence as a+whole. Such provision will be construed or reformed so as necessary to make it+valid and enforceable.++The European Commission may publish other linguistic versions or new versions of+this Licence or updated versions of the Appendix, so far this is required and+reasonable, without reducing the scope of the rights granted by the Licence. New+versions of the Licence will be published with a unique version number.++All linguistic versions of this Licence, approved by the European Commission,+have identical value. Parties can take advantage of the linguistic version of+their choice.++14. Jurisdiction++Without prejudice to specific agreement between parties,++- any litigation resulting from the interpretation of this License, arising+ between the European Union institutions, bodies, offices or agencies, as a+ Licensor, and any Licensee, will be subject to the jurisdiction of the Court+ of Justice of the European Union, as laid down in article 272 of the Treaty on+ the Functioning of the European Union,++- any litigation arising between other parties and resulting from the+ interpretation of this License, will be subject to the exclusive jurisdiction+ of the competent court where the Licensor resides or conducts its primary+ business.++15. Applicable Law++Without prejudice to specific agreement between parties,++- this Licence shall be governed by the law of the European Union Member State+ where the Licensor has his seat, resides or has his registered office,++- this licence shall be governed by Belgian law if the Licensor has no seat,+ residence or registered office inside a European Union Member State.++Appendix++‘Compatible Licences’ according to Article 5 EUPL are:++- GNU General Public License (GPL) v. 2, v. 3+- GNU Affero General Public License (AGPL) v. 3+- Open Software License (OSL) v. 2.1, v. 3.0+- Eclipse Public License (EPL) v. 1.0+- CeCILL v. 2.0, v. 2.1+- Mozilla Public Licence (MPL) v. 2+- GNU Lesser General Public Licence (LGPL) v. 2.1, v. 3+- Creative Commons Attribution-ShareAlike v. 3.0 Unported (CC BY-SA 3.0) for+ works other than software+- European Union Public Licence (EUPL) v. 1.1, v. 1.2+- Québec Free and Open-Source Licence — Reciprocity (LiLiQ-R) or Strong+ Reciprocity (LiLiQ-R+).++The European Commission may update this Appendix to later versions of the above+licences without producing a new version of the EUPL, as long as they provide+the rights granted in Article 2 of this Licence and protect the covered Source+Code from exclusive appropriation.++All other changes or additions to this Appendix require the production of a new+EUPL version.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fluent-syntax.cabal view
@@ -0,0 +1,82 @@+cabal-version: 3.0+name: fluent-syntax+version: 1.0.0+synopsis: The syntax tree and parser for Project Fluent+description: The syntax tree and parser for <https://projectfluent.org Project Fluent>.+license: EUPL-1.2+license-file: LICENCE+author: IDA+maintainer: IDA+homepage: https://digital-autonomy.institute+bug-reports: https://issues.digital-autonomy.institute+category: Language+build-type: Simple+extra-doc-files:+ CHANGELOG.md++flag template-haskell+ description: Include the module Language.Fluent.TH, which uses Template Haskell+ default: True+ manual: True++common common+ default-language: Haskell2010+ ghc-options:+ -Weverything+ -Wno-all-missed-specialisations+ -Wno-missing-export-lists+ -Wno-missing-import-lists+ -Wno-missing-kind-signatures+ -Wno-missing-role-annotations+ -Wno-missing-safe-haskell-mode+ -Wno-unsafe+ -Wno-unused-do-bind++ default-extensions:+ BlockArguments+ DeriveGeneric+ DerivingStrategies+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ LambdaCase+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedRecordDot+ OverloadedStrings+ RecordWildCards+ Trustworthy+ ViewPatterns++library+ import: common+ hs-source-dirs: src+ build-depends:+ attoparsec >=0.14 && <0.15,+ base <5,+ hashable >=1.1 && <1.6,+ text <2.3,++ exposed-modules:+ Language.Fluent.AST+ Language.Fluent.Parser++ if flag(template-haskell)+ build-depends:+ template-haskell >=2.20 && <2.25++ exposed-modules:+ Language.Fluent.TH++test-suite test+ import: common+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends:+ aeson >=2.2 && <2.3,+ base <5,+ directory >=1.3 && <1.4,+ filepath >=1.4 && <1.6,+ fluent-syntax,+ hspec >=2.11 && <2.12,+ text <2.3,
+ src/Language/Fluent/AST.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE DuplicateRecordFields #-}++-- | The abstract syntax tree of FTL, the <https://projectfluent.org Project Fluent> file format.+--+-- The documentation of each type links to the relevant chapter of the+-- <https://projectfluent.org/fluent/guide/ Fluent Syntax Guide>.+--+-- The normative reference is the <https://github.com/projectfluent/fluent/blob/master/spec/fluent.ebnf grammar>.+module Language.Fluent.AST where++import Data.Hashable (Hashable)+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import GHC.Generics (Generic)+import Prelude++-- | An entire FTL file+newtype Resource = Resource {entries :: [Entry]}+ deriving stock (Generic, Eq, Show)++-- | A top-level element of a t'Resource'+data Entry+ = -- | A t'Message': @hello = Hello, world!@+ MessageEntry Message+ | -- | A t'Term': @-brand-name = Fluent@+ TermEntry Term+ | -- | A standalone @#@ comment, not attached to a t'Message' or t'Term'.+ CommentEntry Comment+ | -- | A @##@ comment, describing the group of entries that follows it.+ GroupCommentEntry Comment+ | -- | A @###@ comment, describing the whole t'Resource'.+ ResourceCommentEntry Comment+ | -- | Source text which could not be parsed, preserved verbatim.+ -- See <https://projectfluent.org/fluent/guide/ the guide> on error recovery.+ JunkEntry Text+ deriving stock (Generic, Eq, Show)++-- | A translation unit. Either the @value@ or the @attributes@ must be present.+data Message = Message+ { id :: Identifier+ -- ^ The name by which the message is referenced, e.g. @hello@.+ , value :: Maybe Pattern+ -- ^ The translation itself.+ , attributes :: [Attribute]+ -- ^ Additional translations belonging to this message.+ , comment :: Maybe Comment+ -- ^ The @#@ comment directly above the message, if any.+ }+ deriving stock (Generic, Eq, Show)++-- | A translation unit which is only ever referenced by other translations.+-- See <https://projectfluent.org/fluent/guide/terms.html Terms>.+data Term = Term+ { id :: Identifier+ -- ^ The name by which the term is referenced, without the leading @-@.+ -- e.g. @brand-name@ in @-brand-name@.+ , value :: Pattern+ -- ^ The translation itself; unlike a t'Message', a term always has one.+ , attributes :: [Attribute]+ -- ^ Additional translations belonging to this term, often grammatical+ -- properties such as gender or case.+ , comment :: Maybe Comment+ -- ^ The @#@ comment directly above the term, if any.+ }+ deriving stock (Generic, Eq, Show)++-- | The text of a comment, with the @#@ prefixes and the space following them removed.+-- See <https://projectfluent.org/fluent/guide/comments.html Comments>.+newtype Comment = Comment Text+ deriving stock (Generic, Eq, Show)++-- | A named t'Pattern' belonging to a t'Message' or a t'Term', written as+-- @.key = value@ on a line of its own.+-- See <https://projectfluent.org/fluent/guide/attributes.html Attributes>.+data Attribute = Attribute Identifier Pattern+ deriving stock (Generic, Eq, Show)++-- | The value of a t'Message', t'Term', t'Attribute' or t'Variant': text interspersed+-- with placeables.+-- See <https://projectfluent.org/fluent/guide/text.html Writing Text>.+newtype Pattern = Pattern (NonEmpty PatternElement)+ deriving stock (Generic, Eq, Show)++-- | A single piece of a t'Pattern'.+data PatternElement+ = -- | Text on the first line of the pattern, or following a t'Placeable'.+ InlineText Text+ | -- | Text on a continuation line, already dedented according to the+ -- <https://projectfluent.org/fluent/guide/multiline.html multiline> rules.+ BlockText Text+ | Placeable Placeable+ deriving stock (Generic, Eq, Show)++-- | An 'Expression' embedded in a t'Pattern' between braces, e.g. @{ $userName }@.+-- See <https://projectfluent.org/fluent/guide/placeables.html Placeables>.+data Placeable+ = -- | A placeable on the same line as the text preceding it.+ InlinePlaceable Expression+ | -- | A placeable on a continuation line, together with its indentation in+ -- columns, which takes part in computing the common indent of the t'Pattern'.+ BlockPlaceable Int Expression+ deriving stock (Generic, Eq, Show)++-- | The 'Expression' of a t'Placeable', whether inline or block.+placeableExpression :: Placeable -> Expression+placeableExpression (InlinePlaceable e) = e+placeableExpression (BlockPlaceable _ e) = e++-- | A choice between several t'Variant's, made by matching the selector, an+-- 'InlineExpression', against the t'VariantKey's: @{ $count -> ... }@.+-- See <https://projectfluent.org/fluent/guide/selectors.html Selectors>.+data SelectExpression = SelectExpression InlineExpression VariantList+ deriving stock (Generic, Eq, Show)++-- | An expression which yields a value.+data InlineExpression+ = StringLiteralExpression StringLiteral+ | NumberLiteralExpression NumberLiteral+ | -- | A call of a built-in or implementation-provided function, e.g.+ -- @NUMBER($ratio, minimumFractionDigits: 2)@.+ -- See <https://projectfluent.org/fluent/guide/builtins.html Built-in Functions>+ -- and <https://projectfluent.org/fluent/guide/functions.html Functions>.+ FunctionReference Identifier CallArguments+ | -- | A reference to another t'Message' or one of its attributes.+ -- See <https://projectfluent.org/fluent/guide/references.html Referencing Messages>.+ MessageReference Identifier (Maybe AttributeAccessor)+ | -- | A reference to a t'Term' or one of its attributes, with optional arguments to+ -- parameterise it.+ -- See <https://projectfluent.org/fluent/guide/terms.html Terms>.+ TermReference Identifier (Maybe AttributeAccessor) (Maybe CallArguments)+ | -- | A reference to an argument passed in by the application, e.g. @$userName@.+ -- See <https://projectfluent.org/fluent/guide/variables.html Variables>.+ VariableReference Identifier+ | -- | A placeable nested inside another placeable, used for grouping.+ PlaceableExpression Expression+ deriving stock (Generic, Eq, Show)++-- | The @.key@ suffix of a reference, selecting an t'Attribute' of the referent.+-- See <https://projectfluent.org/fluent/guide/attributes.html Attributes>.+newtype AttributeAccessor = AttributeAccessor Identifier+ deriving stock (Generic, Eq, Show)++-- | The contents of a t'Placeable'.+-- See <https://projectfluent.org/fluent/guide/placeables.html Placeables>.+data Expression+ = Select SelectExpression+ | Inline InlineExpression+ deriving stock (Generic, Eq, Show)++-- | One branch of a t'SelectExpression', written as @[key] value@ on a line of its own.+-- See <https://projectfluent.org/fluent/guide/selectors.html Selectors>.+data Variant = Variant+ { key :: VariantKey+ -- ^ The value or plural category.+ , value :: Pattern+ -- ^ The translation for this variant.+ , isDefault :: Bool+ -- ^ Whether the variant is marked as default with @*@.+ -- A default variant is used when no key matches.+ }+ deriving stock (Generic, Eq, Show)++-- | The key of a t'Variant': either a number, or a plural category such as @one@ or @other@.+-- See <https://projectfluent.org/fluent/guide/selectors.html Selectors>.+newtype VariantKey = VariantKey (Either NumberLiteral Identifier)+ deriving stock (Generic, Eq, Show)++-- | The t'Variant's of a t'SelectExpression'. Exactly one of them is the default.+-- See <https://projectfluent.org/fluent/guide/selectors.html Selectors>.+newtype VariantList = VariantList (NonEmpty Variant)+ deriving stock (Generic, Eq, Show)++-- | The parenthesised arguments of a 'FunctionReference' or 'TermReference'.+-- Positional arguments must precede named ones.+-- See <https://projectfluent.org/fluent/guide/functions.html Functions>.+newtype CallArguments = CallArguments [Either NamedArgument InlineExpression]+ deriving stock (Generic, Eq, Show)++-- | An argument passed by name, e.g. @minimumFractionDigits: 2@.+-- See <https://projectfluent.org/fluent/guide/functions.html Functions>.+data NamedArgument = NamedArgument Identifier (Either StringLiteral NumberLiteral)+ deriving stock (Generic, Eq, Show)++-- | The name of a t'Message', t'Term', t'Attribute', variable, function, or named argument.+newtype Identifier = Identifier Text+ deriving newtype (Show, Eq, Ord, Hashable)++-- | A decimal number with arbitrary precision.+newtype NumberLiteral = NumberLiteral Text+ deriving stock (Generic, Eq, Show)++-- | A quoted string, used to write characters which are otherwise+-- <https://projectfluent.org/fluent/guide/special.html special> in FTL.+data StringLiteral = StringLiteral+ { raw :: Text+ -- ^ The source text between the quotes, with escape sequences unresolved.+ , value :: Text+ -- ^ The text the literal denotes, with escape sequences resolved.+ }+ deriving stock (Generic, Eq, Show)
+ src/Language/Fluent/Parser.hs view
@@ -0,0 +1,412 @@+{- HLINT ignore "Use <$>" -}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Language.Fluent.Parser (module Language.Fluent.Parser, Parser) where++import Control.Applicative (Alternative (many, some), optional, (<|>))+import Control.Monad (replicateM, unless, when)+import Data.Attoparsec.Combinator (choice, eitherP, endOfInput, lookAhead, sepBy)+import Data.Attoparsec.Text+ ( Parser+ , char+ , endOfLine+ , match+ , parseOnly+ , peekChar+ , satisfy+ , string+ , takeWhile+ , takeWhile1+ )+import Data.Bifunctor (first)+import Data.Char (chr, isAsciiLower, isAsciiUpper, isDigit, isHexDigit, ord)+import Data.Either (isLeft, isRight, rights)+import Data.Functor (void, (<&>))+import Data.List qualified as List+import Data.List.NonEmpty (some1)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Ix (inRange)+import Language.Fluent.AST+import Numeric (readHex)+import Prelude hiding (take, takeWhile)++parse :: Parser a -> Text -> Either String a+parse p = parseOnly $ p <* endOfInput++parseNamed :: String -> Parser a -> Text -> Either String a+parseNamed name p t = first (const $ "Invalid " <> name <> ": " <> show t) $ parse p t++parseIdentifier :: Text -> Either String Identifier+parseIdentifier = parseNamed "identifier" identifier++parseResource :: Text -> Either String Resource+parseResource = parseNamed "resource" resource++resource :: Parser Resource+resource = Resource . rights <$> many (eitherP blankBlock entryOrJunk)++entryOrJunk :: Parser Entry+entryOrJunk = entry <* lookAhead entryEnd <|> JunkEntry <$> junk++entryEnd :: Parser ()+entryEnd = void endOfLine <|> endOfInput++junk :: Parser Text+junk = do+ first <- line+ when (Text.null first) $ fail "nothing left to skip"+ rest <- many $ beforeEntry *> line+ pure . mconcat $ first : rest+ where+ beforeEntry :: Parser ()+ beforeEntry = do+ next <- peekChar+ case next of+ Just c | beginsEntry c -> fail "the next entry begins here"+ Just _ -> pure ()+ Nothing -> fail "end of input"+ beginsEntry :: Char -> Bool+ beginsEntry c = isAsciiLower c || isAsciiUpper c || c == '-' || c == '#'++line :: Parser Text+line = do+ text <- takeWhile (/= '\n')+ ending <- Text.singleton <$> char '\n' <|> pure mempty+ pure $ text <> ending++entry :: Parser Entry+entry =+ choice+ [ commented+ , MessageEntry <$> message Nothing+ , TermEntry <$> term Nothing+ ]++commented :: Parser Entry+commented = do+ (hashes, Comment -> comment) <- commentBlock+ case hashes of+ 1 ->+ optional+ ( (endOfLine *>)+ . (<* lookAhead entryEnd)+ . eitherP (message $ Just comment)+ . term+ $ Just comment+ )+ <&> \case+ Nothing -> CommentEntry comment+ Just (Left message) -> MessageEntry message+ Just (Right term) -> TermEntry term+ 2 -> pure $ GroupCommentEntry comment+ _ -> pure $ ResourceCommentEntry comment++commentBlock :: Parser (Int, Text)+commentBlock = do+ (hashes, first) <- commentLine+ rest <- many $ endOfLine *> ofSameKind hashes+ pure (hashes, Text.intercalate "\n" (first : rest))+ where+ ofSameKind :: Int -> Parser Text+ ofSameKind hashes = do+ (found, content) <- commentLine+ unless (found == hashes) . fail $+ "expected a " <> replicate hashes '#' <> " comment, found a " <> replicate found '#' <> " one"+ pure content++commentLine :: Parser (Int, Text)+commentLine = do+ let hash = char '#'+ hashes <- length . catMaybes <$> sequence [Just <$> hash, optional hash, optional hash]+ content <-+ choice+ [ char ' ' *> lineText+ , mempty <$ lookAhead (void (string "\r\n") <|> void (char '\n') <|> endOfInput)+ ]+ pure (hashes, content)++lineText :: Parser Text+lineText = do+ text <- takeWhile (/= '\n')+ end <- peekChar+ pure if end == Just '\n' then fromMaybe text $ Text.stripSuffix "\r" text else text++message :: Maybe Comment -> Parser Message+message comment = do+ id <- identifier+ optional blankInline+ char '='+ optional blankInline+ value <- optional pattern+ attributes <- many attribute+ when (isNothing value && null attributes) $+ fail "Message must have either a pattern or attributes"+ pure Message{..}++term :: Maybe Comment -> Parser Term+term comment = do+ char '-'+ id <- identifier+ optional blankInline+ char '='+ optional blankInline+ value <- pattern+ attributes <- many attribute+ pure Term{..}++attribute :: Parser Attribute+attribute = do+ endOfLine+ optional blank+ char '.'+ i <- identifier+ optional blankInline+ char '='+ optional blankInline+ p <- pattern+ pure $ Attribute i p++pattern :: Parser Pattern+pattern = Pattern . NonEmpty.fromList . dedent . NonEmpty.toList <$> some1 patternElement++-- | Apply <https://projectfluent.org/fluent/guide/multiline multi-line rules>+-- to the raw pattern elements.+dedent :: [PatternElement] -> [PatternElement]+dedent elements =+ onLast (mapText $ Text.dropWhileEnd (`elem` blanks))+ . onFirst (mapText $ Text.dropWhile (`elem` newlines))+ $ strip <$> elements+ where+ newlines = "\r\n" :: String+ blanks = " \r\n" :: String+ commonIndent :: Int+ commonIndent =+ minimum $+ maxBound+ : [indentWidth t | BlockText t <- elements]+ <> [indent | Placeable (BlockPlaceable indent _) <- elements]+ indentWidth :: Text -> Int+ indentWidth = Text.length . Text.takeWhile (== ' ') . Text.dropWhile (`elem` newlines)+ strip :: PatternElement -> PatternElement+ strip (BlockText (Text.span (`elem` newlines) -> (ns, rest))) =+ BlockText (ns <> Text.drop commonIndent rest)+ strip e = e+ mapText :: (Text -> Text) -> PatternElement -> PatternElement+ mapText f (InlineText t) = InlineText (f t)+ mapText f (BlockText t) = BlockText (f t)+ mapText _ e = e+ onFirst, onLast :: (a -> a) -> [a] -> [a]+ onFirst f (x : xs) = f x : xs+ onFirst _ [] = []+ onLast f = reverse . onFirst f . reverse++patternElement :: Parser PatternElement+patternElement =+ choice+ [ InlineText <$> inlineText+ , BlockText <$> blockText+ , Placeable <$> placeable+ ]++placeable :: Parser Placeable+placeable =+ choice+ [ InlinePlaceable <$> inlinePlaceable+ , blockPlaceable+ ]++inlinePlaceable :: Parser Expression+inlinePlaceable = do+ char '{'+ optional blank+ e <- expression+ optional blank+ char '}'+ pure e++blockPlaceable :: Parser Placeable+blockPlaceable = do+ blankBlock+ indent <- maybe 0 Text.length <$> optional (takeWhile1 (== ' '))+ BlockPlaceable indent <$> inlinePlaceable++expression :: Parser Expression+expression = do+ i <- inlineExpression+ choice+ [ Select <$> do+ optional blank+ string "->"+ optional blankInline+ unless (choosesVariant i) $ fail "failed to choose a variant"+ vs <- variantList+ pure $ SelectExpression i vs+ , do+ unless (usableAsPlaceable i) $ fail "Attributes of terms cannot be used as placeables"+ pure $ Inline i+ ]+ where+ choosesVariant :: InlineExpression -> Bool+ choosesVariant (StringLiteralExpression _) = True+ choosesVariant (NumberLiteralExpression _) = True+ choosesVariant (VariableReference _) = True+ choosesVariant (FunctionReference _ _) = True+ choosesVariant (TermReference _ attribute _) = isJust attribute+ choosesVariant _ = False++ usableAsPlaceable :: InlineExpression -> Bool+ usableAsPlaceable (TermReference _ (Just _) _) = False+ usableAsPlaceable _ = True++inlineExpression :: Parser InlineExpression+inlineExpression =+ choice+ [ StringLiteralExpression <$> stringLiteral+ , NumberLiteralExpression <$> numberLiteral+ , FunctionReference <$> functionName <*> callArguments+ , MessageReference <$> identifier <*> optional attributeAccessor+ , TermReference+ <$> (char '-' *> identifier)+ <*> optional attributeAccessor+ <*> optional callArguments+ , VariableReference <$> (char '$' *> identifier)+ , PlaceableExpression <$> inlinePlaceable+ ]++attributeAccessor :: Parser AttributeAccessor+attributeAccessor = AttributeAccessor <$> (char '.' *> identifier)++variant :: Parser Variant+variant = do+ endOfLine+ optional blank+ isDefault <- isJust <$> optional (char '*')+ key <- variantKey+ optional blankInline+ value <- pattern+ pure Variant{..}++variantKey :: Parser VariantKey+variantKey = do+ char '['+ optional blank+ vk <- eitherP numberLiteral identifier+ optional blank+ char ']'+ pure $ VariantKey vk++variantList :: Parser VariantList+variantList = do+ variants <- some1 variant+ unless (any isDefault variants) $ fail "VariantList must have at least one default variant"+ endOfLine+ pure $ VariantList variants++callArguments :: Parser CallArguments+callArguments = do+ optional blank+ char '('+ optional blank+ args <- sepBy (eitherP namedArgument inlineExpression) comma+ unless (null args) . void $ optional comma+ optional blank+ char ')'+ unless (all isLeft $ dropWhile isRight args) $+ fail "an argument standing on its place follows one that is named"+ let names = [name | Left (NamedArgument name _) <- args]+ unless (length (List.nub names) == length names) $ fail "a name is given twice"+ pure $ CallArguments args+ where+ comma :: Parser ()+ comma = void $ optional blank >> char ',' >> optional blank++namedArgument :: Parser NamedArgument+namedArgument = do+ i <- identifier+ optional blank+ char ':'+ optional blank+ l <- eitherP stringLiteral numberLiteral+ pure $ NamedArgument i l++identifier :: Parser Identifier+identifier = Identifier <$> (Text.cons <$> satisfy isAsciiLetter <*> tailLetters)+ where+ isAsciiLetter c = isAsciiLower c || isAsciiUpper c+ tailLetters = takeWhile \c -> isAsciiLetter c || isDigit c || c == '_' || c == '-'++functionName :: Parser Identifier+functionName = do+ name@(Identifier text) <- identifier+ unless (Text.all capital text) $ fail "a function name should be written in all capitals"+ pure name+ where+ capital :: Char -> Bool+ capital c = isAsciiUpper c || isDigit c || c == '_' || c == '-'++numberLiteral :: Parser NumberLiteral+numberLiteral = do+ sign <- optional $ string "-"+ i <- digits+ f <- optional $ Text.cons <$> char '.' <*> digits+ pure . NumberLiteral . mconcat . catMaybes $ [sign, Just i, f]+ where+ digits = takeWhile1 (`elem` ['0' .. '9'])++stringLiteral :: Parser StringLiteral+stringLiteral = do+ char '"'+ (raw, value) <- match $ Text.pack <$> many quotedChar+ char '"'+ pure StringLiteral{..}++quotedChar :: Parser Char+quotedChar =+ choice+ [ satisfy \c -> isAnyChar c && notElem c ("\\\"\r\n" :: String)+ , char '\\'+ *> choice+ [ satisfy (`elem` ("\\\"" :: String))+ , char 'u' *> hexString 4+ , char 'U' *> hexString 6+ ]+ ]+ where+ hexDigit :: Parser Char+ hexDigit = satisfy isHexDigit+ hexString :: Int -> Parser Char+ hexString len = do+ [(num, "")] <- readHex <$> replicateM len hexDigit+ pure $ chr num++isAnyChar :: Char -> Bool+isAnyChar = inRange (0, 0x10FFFF) . ord++anyChar :: Parser Char+anyChar = satisfy isAnyChar++inlineText :: Parser Text+inlineText = takeWhile1 (`notElem` ("{}\r\n" :: String))++blockText :: Parser Text+blockText =+ fmap mconcat . sequence $+ [ Text.concat <$> some ("\n" <$ (optional blankInline *> endOfLine))+ , takeWhile1 (== ' ')+ , Text.cons <$> indentedChar <*> (inlineText <|> pure mempty)+ ]++indentedChar :: Parser Char+indentedChar = satisfy (`notElem` ("{}[*.\r\n" :: String))++blankInline :: Parser ()+blankInline = void . some . char $ ' '++blank :: Parser ()+blank = void . some $ blankInline <|> endOfLine++blankBlock :: Parser ()+blankBlock = void . some $ optional blankInline *> endOfLine
+ src/Language/Fluent/TH.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Language.Fluent.TH (fluent, messageIdentifiers) where++import Data.Char (toLower, toUpper)+import Data.String (IsString, fromString)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as Text+import Data.Traversable (for)+import Language.Fluent.AST+import Language.Fluent.Parser (parse, parseResource, resource)+import Language.Haskell.TH.Lib+ ( DecsQ+ , appE+ , litE+ , normalB+ , sigD+ , stringL+ , valD+ , varE+ , varP+ )+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+ ( Lift+ , Quasi (qAddDependentFile)+ , lift+ , makeRelativeToProject+ , mkName+ , runIO+ )+import Prelude++-- | Parses a 'Resource'.+-- Strips the indentation shared by every line.+fluent :: QuasiQuoter+fluent =+ QuasiQuoter+ { quoteExp = either fail lift . parse resource . dedent . Text.pack+ , quotePat = const $ fail "a Fluent Resource is not a pattern"+ , quoteType = const $ fail "a Fluent Resource is not a type"+ , quoteDec = const $ fail "a Fluent Resource is not a declaration"+ }+ where+ dedent :: Text -> Text+ dedent written = Text.unlines $ Text.drop shared <$> lines'+ where+ lines' = Text.lines written+ shared = minimum . (maxBound :) $ do+ line <- lines'+ let (indent, rest) = Text.span (== ' ') line+ [Text.length indent | not . Text.null $ rest]++-- | Declares a constant for every message identifier in the given Fluent file.+--+-- > messageIdentifiers "en.ftl"+--+-- declares, for the message @text-field-intro@,+--+-- > textFieldIntro :: (IsString s) => s+-- > textFieldIntro = "text-field-intro"+messageIdentifiers :: FilePath -> DecsQ+messageIdentifiers path = do+ path <- makeRelativeToProject path+ qAddDependentFile path+ contents <- runIO $ Text.readFile path+ Resource{entries} <- either fail pure $ parseResource contents+ mconcat <$> for entries \case+ (MessageEntry Message{..}) -> declare id+ _ -> pure []+ where+ declare :: Identifier -> DecsQ+ declare (Identifier identifier@(mkName . escape . camel -> name)) =+ sequence+ [ sigD name [t|forall s. (IsString s) => s|]+ , valD (varP name) (normalB $ varE 'fromString `appE` (litE . stringL . Text.unpack) identifier) []+ ]+ camel :: Text -> String+ camel =+ Text.unpack+ . mconcat+ . zipWith ($) (firstChar toLower : repeat (firstChar toUpper))+ . filter (not . Text.null)+ . Text.splitOn "-"+ firstChar :: (Char -> Char) -> Text -> Text+ firstChar f = maybe Text.empty (\(c, cs) -> Text.cons (f c) cs) . Text.uncons+ escape :: String -> String+ escape name+ | name `elem` keywords = name <> "'"+ | otherwise = name+ keywords :: [String]+ keywords =+ [ "case"+ , "class"+ , "data"+ , "default"+ , "deriving"+ , "do"+ , "else"+ , "foreign"+ , "if"+ , "import"+ , "in"+ , "infix"+ , "infixl"+ , "infixr"+ , "instance"+ , "let"+ , "module"+ , "newtype"+ , "of"+ , "then"+ , "type"+ , "where"+ ]++deriving stock instance Lift Resource++deriving stock instance Lift Entry++deriving stock instance Lift Message++deriving stock instance Lift Term++deriving stock instance Lift Comment++deriving stock instance Lift Attribute++deriving stock instance Lift Pattern++deriving stock instance Lift PatternElement++deriving stock instance Lift Placeable++deriving stock instance Lift Expression++deriving stock instance Lift SelectExpression++deriving stock instance Lift InlineExpression++deriving stock instance Lift AttributeAccessor++deriving stock instance Lift Variant++deriving stock instance Lift VariantKey++deriving stock instance Lift VariantList++deriving stock instance Lift CallArguments++deriving stock instance Lift NamedArgument++deriving stock instance Lift Identifier++deriving stock instance Lift NumberLiteral++deriving stock instance Lift StringLiteral
+ test/Main.hs view
@@ -0,0 +1,182 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Main where++import Data.Aeson (ToJSON (toJSON), Value (Null), eitherDecodeFileStrict, object, (.=))+import Data.List (isSuffixOf, sort)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as Text.IO+import Language.Fluent.AST+import Language.Fluent.Parser (parse, resource)+import System.Directory (listDirectory)+import System.Environment (lookupEnv)+import System.FilePath (replaceExtension, (</>))+import Test.Hspec+import Prelude++main :: IO ()+main = hspec . describe "reference fixtures" $ do+ runIO (lookupEnv "FLUENT_FIXTURES") >>= \case+ Nothing -> it "cannot be found" $ pendingWith "FLUENT_FIXTURES is unset"+ Just fixtures -> do+ runIO (sort . filter (".ftl" `isSuffixOf`) <$> listDirectory fixtures) >>= mapM_ \name -> it name do+ text <- Text.IO.readFile $ fixtures </> name+ expected <-+ either fail pure+ =<< eitherDecodeFileStrict (fixtures </> replaceExtension name "json")+ either expectationFailure ((`shouldBe` expected) . toJSON) $ parse resource text++instance ToJSON Resource where+ toJSON (Resource entries) =+ object ["type" .= ("Resource" :: Text), "body" .= (entry <$> entries)]+ where+ entry :: Entry -> Value+ entry (MessageEntry message) =+ object+ [ "type" .= ("Message" :: Text)+ , "id" .= identifier message.id+ , "value" .= maybe Null pattern message.value+ , "attributes" .= (attribute <$> message.attributes)+ , "comment" .= maybe Null (comment "Comment") message.comment+ ]+ entry (TermEntry term) =+ object+ [ "type" .= ("Term" :: Text)+ , "id" .= identifier term.id+ , "value" .= pattern term.value+ , "attributes" .= (attribute <$> term.attributes)+ , "comment" .= maybe Null (comment "Comment") term.comment+ ]+ entry (CommentEntry c) = comment "Comment" c+ entry (GroupCommentEntry c) = comment "GroupComment" c+ entry (ResourceCommentEntry c) = comment "ResourceComment" c+ entry (JunkEntry content) =+ object+ [ "type" .= ("Junk" :: Text)+ , "annotations" .= ([] :: [Value])+ , "content" .= content+ ]++ comment :: Text -> Comment -> Value+ comment kind (Comment content) =+ object ["type" .= kind, "content" .= content]++ identifier :: Identifier -> Value+ identifier (Identifier name) =+ object ["type" .= ("Identifier" :: Text), "name" .= name]++ attribute :: Attribute -> Value+ attribute (Attribute name value) =+ object+ [ "type" .= ("Attribute" :: Text)+ , "id" .= identifier name+ , "value" .= pattern value+ ]++ pattern :: Pattern -> Value+ pattern (Pattern elements) =+ object+ [ "type" .= ("Pattern" :: Text)+ , "elements" .= (either textElement placeable <$> runs (NonEmpty.toList elements))+ ]++ runs :: [PatternElement] -> [Either Text Placeable]+ runs = withoutLeadingBreak . filter (either (not . Text.null) (const True)) . foldr add []+ where+ withoutLeadingBreak :: [Either Text Placeable] -> [Either Text Placeable]+ withoutLeadingBreak (Left "\n" : rest) = rest+ withoutLeadingBreak elements = elements+ add :: PatternElement -> [Either Text Placeable] -> [Either Text Placeable]+ add (InlineText t) (Left u : rest) = Left (t <> u) : rest+ add (BlockText t) (Left u : rest) = Left (t <> u) : rest+ add (InlineText t) rest = Left t : rest+ add (BlockText t) rest = Left t : rest+ add (Placeable p@(BlockPlaceable _ _)) rest = Left "\n" : Right p : rest+ add (Placeable p) rest = Right p : rest++ textElement :: Text -> Value+ textElement value = object ["type" .= ("TextElement" :: Text), "value" .= value]++ placeable :: Placeable -> Value+ placeable p =+ object+ [ "type" .= ("Placeable" :: Text)+ , "expression" .= expression (placeableExpression p)+ ]++ expression :: Expression -> Value+ expression (Inline inline) = inlineExpression inline+ expression (Select (SelectExpression selector (VariantList variants))) =+ object+ [ "type" .= ("SelectExpression" :: Text)+ , "selector" .= inlineExpression selector+ , "variants" .= (variant <$> NonEmpty.toList variants)+ ]++ variant :: Variant -> Value+ variant v =+ object+ [ "type" .= ("Variant" :: Text)+ , "key" .= variantKey v.key+ , "value" .= pattern v.value+ , "default" .= v.isDefault+ ]++ variantKey :: VariantKey -> Value+ variantKey (VariantKey key) = either numberLiteral identifier key++ inlineExpression :: InlineExpression -> Value+ inlineExpression (StringLiteralExpression s) = stringLiteral s+ inlineExpression (NumberLiteralExpression n) = numberLiteral n+ inlineExpression (FunctionReference name called) =+ object+ [ "type" .= ("FunctionReference" :: Text)+ , "id" .= identifier name+ , "arguments" .= callArguments called+ ]+ inlineExpression (MessageReference name accessor) =+ object+ [ "type" .= ("MessageReference" :: Text)+ , "id" .= identifier name+ , "attribute" .= maybe Null accessor' accessor+ ]+ inlineExpression (TermReference name accessor called) =+ object+ [ "type" .= ("TermReference" :: Text)+ , "id" .= identifier name+ , "attribute" .= maybe Null accessor' accessor+ , "arguments" .= maybe Null callArguments called+ ]+ inlineExpression (VariableReference name) =+ object ["type" .= ("VariableReference" :: Text), "id" .= identifier name]+ inlineExpression (PlaceableExpression e) =+ object ["type" .= ("Placeable" :: Text), "expression" .= expression e]++ accessor' :: AttributeAccessor -> Value+ accessor' (AttributeAccessor name) = identifier name++ callArguments :: CallArguments -> Value+ callArguments (CallArguments called) =+ object+ [ "type" .= ("CallArguments" :: Text)+ , "positional" .= [inlineExpression e | Right e <- called]+ , "named" .= [namedArgument a | Left a <- called]+ ]++ namedArgument :: NamedArgument -> Value+ namedArgument (NamedArgument name literal) =+ object+ [ "type" .= ("NamedArgument" :: Text)+ , "name" .= identifier name+ , "value" .= either stringLiteral numberLiteral literal+ ]++ stringLiteral :: StringLiteral -> Value+ stringLiteral StringLiteral{raw} =+ object ["type" .= ("StringLiteral" :: Text), "value" .= raw]++ numberLiteral :: NumberLiteral -> Value+ numberLiteral (NumberLiteral value) =+ object ["type" .= ("NumberLiteral" :: Text), "value" .= value]