TH.hs

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