{-# 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
fluent =
    QuasiQuoter
        { quoteExp :: String -> Q Exp
quoteExp = (String -> Q Exp)
-> (Resource -> Q Exp) -> Either String Resource -> Q Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Resource -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Resource -> m Exp
lift (Either String Resource -> Q Exp)
-> (String -> Either String Resource) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Resource -> Text -> Either String Resource
forall a. Parser a -> Text -> Either String a
parse Parser Resource
resource (Text -> Either String Resource)
-> (String -> Text) -> String -> Either String Resource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
dedent (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
        , quotePat :: String -> Q Pat
quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"a Fluent Resource is not a pattern"
        , quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"a Fluent Resource is not a type"
        , quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"a Fluent Resource is not a declaration"
        }
  where
    dedent :: Text -> Text
    dedent :: Text -> Text
dedent Text
written = [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.drop Int
shared (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
lines'
      where
        lines' :: [Text]
lines' = Text -> [Text]
Text.lines Text
written
        shared :: Int
shared = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> ([Int] -> [Int]) -> [Int] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
forall a. Bounded a => a
maxBound Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ do
            line <- [Text]
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 :: String -> Q [Dec]
messageIdentifiers String
path = do
    path <- String -> Q String
makeRelativeToProject String
path
    qAddDependentFile path
    contents <- runIO $ Text.readFile path
    Resource{entries} <- either fail pure $ parseResource contents
    mconcat <$> for entries \case
        (MessageEntry Message{[Attribute]
Maybe Pattern
Maybe Comment
Identifier
id :: Identifier
value :: Maybe Pattern
attributes :: [Attribute]
comment :: Maybe Comment
comment :: Message -> Maybe Comment
attributes :: Message -> [Attribute]
value :: Message -> Maybe Pattern
id :: Message -> Identifier
..}) -> Identifier -> Q [Dec]
declare Identifier
id
        Entry
_ -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    declare :: Identifier -> DecsQ
    declare :: Identifier -> Q [Dec]
declare (Identifier identifier :: Text
identifier@(String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
escape (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
camel -> Name
name)) =
        [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
            [ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
name [t|forall s. (IsString s) => s|]
            , Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
name) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'fromString Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (Text -> Lit) -> Text -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL (String -> Lit) -> (Text -> String) -> Text -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack) Text
identifier) []
            ]
    camel :: Text -> String
    camel :: Text -> String
camel =
        Text -> String
Text.unpack
            (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text -> Text) -> Text -> Text)
-> [Text -> Text] -> [Text] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
($) ((Char -> Char) -> Text -> Text
firstChar Char -> Char
toLower (Text -> Text) -> [Text -> Text] -> [Text -> Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text -> Text]
forall a. a -> [a]
repeat ((Char -> Char) -> Text -> Text
firstChar Char -> Char
toUpper))
            ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)
            ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"-"
    firstChar :: (Char -> Char) -> Text -> Text
    firstChar :: (Char -> Char) -> Text -> Text
firstChar Char -> Char
f = Text -> ((Char, Text) -> Text) -> Maybe (Char, Text) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
Text.empty (\(Char
c, Text
cs) -> Char -> Text -> Text
Text.cons (Char -> Char
f Char
c) Text
cs) (Maybe (Char, Text) -> Text)
-> (Text -> Maybe (Char, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (Char, Text)
Text.uncons
    escape :: String -> String
    escape :: String -> String
escape String
name
        | String
name String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
keywords = String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'"
        | Bool
otherwise = String
name
    keywords :: [String]
    keywords :: [String]
keywords =
        [ String
"case"
        , String
"class"
        , String
"data"
        , String
"default"
        , String
"deriving"
        , String
"do"
        , String
"else"
        , String
"foreign"
        , String
"if"
        , String
"import"
        , String
"in"
        , String
"infix"
        , String
"infixl"
        , String
"infixr"
        , String
"instance"
        , String
"let"
        , String
"module"
        , String
"newtype"
        , String
"of"
        , String
"then"
        , String
"type"
        , String
"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