diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fluent-syntax.cabal b/fluent-syntax.cabal new file mode 100644 --- /dev/null +++ b/fluent-syntax.cabal @@ -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 . +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, diff --git a/src/Language/Fluent/AST.hs b/src/Language/Fluent/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fluent/AST.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +-- | The abstract syntax tree of FTL, the file format. +-- +-- The documentation of each type links to the relevant chapter of the +-- . +-- +-- The normative reference is the . +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 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 . +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 . +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 . +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 . +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 + -- rules. + BlockText Text + | Placeable Placeable + deriving stock (Generic, Eq, Show) + +-- | An 'Expression' embedded in a t'Pattern' between braces, e.g. @{ $userName }@. +-- See . +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 . +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 + -- and . + FunctionReference Identifier CallArguments + | -- | A reference to another t'Message' or one of its attributes. + -- See . + MessageReference Identifier (Maybe AttributeAccessor) + | -- | A reference to a t'Term' or one of its attributes, with optional arguments to + -- parameterise it. + -- See . + TermReference Identifier (Maybe AttributeAccessor) (Maybe CallArguments) + | -- | A reference to an argument passed in by the application, e.g. @$userName@. + -- See . + 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 . +newtype AttributeAccessor = AttributeAccessor Identifier + deriving stock (Generic, Eq, Show) + +-- | The contents of a t'Placeable'. +-- See . +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 . +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 . +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 . +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 . +newtype CallArguments = CallArguments [Either NamedArgument InlineExpression] + deriving stock (Generic, Eq, Show) + +-- | An argument passed by name, e.g. @minimumFractionDigits: 2@. +-- See . +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 +-- 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) diff --git a/src/Language/Fluent/Parser.hs b/src/Language/Fluent/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fluent/Parser.hs @@ -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 +-- 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 diff --git a/src/Language/Fluent/TH.hs b/src/Language/Fluent/TH.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fluent/TH.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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]