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 Control.Exception (displayException)
import Data.Bifunctor (first)
import Data.Char (toLower, toUpper)
import Data.List qualified as List
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Maybe (mapMaybe)
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 (parseResource, parseResourceLenient, rejectJunk)
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
    , Loc (loc_start)
    , Quasi (qAddDependentFile)
    , lift
    , location
    , makeRelativeToProject
    , mkName
    , runIO
    )
import Prelude

-- | Parses a 'Resource'.
-- Strips the indentation shared by every line.
-- Syntax errors fail the compilation.
fluent :: QuasiQuoter
fluent =
    QuasiQuoter
        { quoteExp = \quoted -> do
            start <- loc_start <$> location
            either (fail . List.intercalate "\n" . fmap displayException . NonEmpty.toList) lift $
                parseQuoted start quoted
        , 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
    parseQuoted :: (Int, Int) -> String -> Either (NonEmpty ParseError) Resource
    parseQuoted (firstLine, firstColumn) quoted =
        first (fmap locate) . rejectJunk . parseResourceLenient $ text
      where
        (indent, text) = dedent $ Text.pack quoted
        locate error =
            error
                { line = firstLine + error.line - 1
                , column = indent + error.column + if error.line == 1 then firstColumn - 1 else 0
                }

    dedent :: Text -> (Int, Text)
    dedent (Text.lines -> lines) = (shared, Text.unlines $ Text.drop shared <$> lines)
      where
        shared = minimum . (maxBound :) $ mapMaybe (Text.findIndex (/= ' ')) lines

-- | 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 ParseError

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