{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ExistentialQuantification #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Shakespeare.I18N
-- Copyright   :  2012 Michael Snoyman <michael@snoyman.com>, Jeremy Shaw
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  Michael Snoyman <michael@snoyman.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- This module provides a type-based system for providing translations
-- for text strings.
--
-- It is similar in purpose to gettext or Java message bundles.
--
-- The core idea is to create simple data type where each constructor
-- represents a phrase, sentence, paragraph, etc. For example:
--
-- > data AppMessages = Hello | Goodbye
--
-- The 'RenderMessage' class is used to retrieve the appropriate
-- translation for a message value:
--
-- > class RenderMessage master message where
-- >   renderMessage :: master  -- ^ type that specifies which set of translations to use
-- >                 -> [Lang]  -- ^ acceptable languages in descending order of preference
-- >                 -> message -- ^ message to translate
-- >                 -> Text
--
-- Defining the translation type and providing the 'RenderMessage'
-- instance in Haskell is not very translator friendly. Instead,
-- translations are generally provided in external translations
-- files. Then the 'mkMessage' Template Haskell function is used to
-- read the external translation files and automatically create the
-- translation type and the @RenderMessage@ instance.
--
-- A full description of using this module to create translations for @Hamlet@ can be found here:
--
--  <http://www.yesodweb.com/book/internationalization>
--
-- A full description of using the module to create translations for @HSP@ can be found here:
--
--  <http://happstack.com/docs/crashcourse/Templates.html#hsp-i18n>
--
-- You can also adapt those instructions for use with other systems.
module Text.Shakespeare.I18N
    ( mkMessage
    , mkMessageFor
    , mkMessageVariant
    , RenderMessage (..)
    , ToMessage (..)
    , SomeMessage (..)
    , Lang
    ) where

import Language.Haskell.TH.Syntax
import Control.Applicative ((<$>))
import Control.Monad (filterM, forM)
import Data.Text (Text, pack, unpack)
import System.Directory
import Data.Maybe (catMaybes)
import Data.List (isSuffixOf, sortBy, foldl')
import qualified Data.Map as Map
import qualified Data.ByteString as S
import Data.Text.Encoding (decodeUtf8)
import Data.Char (isSpace, toLower, toUpper)
import Data.Ord (comparing)
import Text.Shakespeare.Base (Deref (..), Ident (..), parseHash, derefToExp)
import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>))
import Control.Arrow ((***))
import Data.Monoid (mempty, mappend)
import qualified Data.Text as T
import Data.String (IsString (fromString))

-- | 'ToMessage' is used to convert the value inside #{ } to 'Text'
--
-- The primary purpose of this class is to allow the value in #{ } to
-- be a 'String' or 'Text' rather than forcing it to always be 'Text'.
class ToMessage a where
    toMessage :: a -> Text
instance ToMessage Text where
    toMessage :: Text -> Text
toMessage = Text -> Text
forall a. a -> a
id
instance ToMessage String where
    toMessage :: String -> Text
toMessage = String -> Text
Data.Text.pack

-- | the 'RenderMessage' is used to provide translations for a message types
--
-- The 'master' argument exists so that it is possible to provide more
-- than one set of translations for a 'message' type. This is useful
-- if a library provides a default set of translations, but the user
-- of the library wants to provide a different set of translations.
class RenderMessage master message where
    renderMessage :: master  -- ^ type that specifies which set of translations to use
                  -> [Lang]  -- ^ acceptable languages in descending order of preference
                  -> message -- ^ message to translate
                  -> Text

instance RenderMessage master Text where
    renderMessage :: master -> [Text] -> Text -> Text
renderMessage master
_ [Text]
_ = Text -> Text
forall a. a -> a
id

-- | an RFC1766 / ISO 639-1 language code (eg, @fr@, @en-GB@, etc).
type Lang = Text

-- |generate translations from translation files
--
-- This function will:
--
--  1. look in the supplied subdirectory for files ending in @.msg@
--
--  2. generate a type based on the constructors found
--
--  3. create a 'RenderMessage' instance
--
mkMessage :: String   -- ^ base name to use for translation type
          -> FilePath -- ^ subdirectory which contains the translation files
          -> Lang     -- ^ default translation language
          -> Q [Dec]
mkMessage :: String -> String -> Text -> Q [Dec]
mkMessage String
dt String
folder Text
lang =
    Bool
-> String
-> String
-> String
-> String
-> String
-> Text
-> Q [Dec]
mkMessageCommon Bool
True String
"Msg" String
"Message" String
dt String
dt String
folder Text
lang


-- | create 'RenderMessage' instance for an existing data-type
mkMessageFor :: String     -- ^ master translation data type
             -> String     -- ^ existing type to add translations for
             -> FilePath   -- ^ path to translation folder
             -> Lang       -- ^ default language
             -> Q [Dec]
mkMessageFor :: String -> String -> String -> Text -> Q [Dec]
mkMessageFor String
master String
dt String
folder Text
lang = Bool
-> String
-> String
-> String
-> String
-> String
-> Text
-> Q [Dec]
mkMessageCommon Bool
False String
"" String
"" String
master String
dt String
folder Text
lang

-- | create an additional set of translations for a type created by `mkMessage`
mkMessageVariant :: String     -- ^ master translation data type
                 -> String     -- ^ existing type to add translations for
                 -> FilePath   -- ^ path to translation folder
                 -> Lang       -- ^ default language
                 -> Q [Dec]
mkMessageVariant :: String -> String -> String -> Text -> Q [Dec]
mkMessageVariant String
master String
dt String
folder Text
lang = Bool
-> String
-> String
-> String
-> String
-> String
-> Text
-> Q [Dec]
mkMessageCommon Bool
False String
"Msg" String
"Message" String
master String
dt String
folder Text
lang

-- |used by 'mkMessage' and 'mkMessageFor' to generate a 'RenderMessage' and possibly a message data type
mkMessageCommon :: Bool      -- ^ generate a new datatype from the constructors found in the .msg files
                -> String    -- ^ string to append to constructor names
                -> String    -- ^ string to append to datatype name
                -> String    -- ^ base name of master datatype
                -> String    -- ^ base name of translation datatype
                -> FilePath  -- ^ path to translation folder
                -> Lang      -- ^ default lang
                -> Q [Dec]
mkMessageCommon :: Bool
-> String
-> String
-> String
-> String
-> String
-> Text
-> Q [Dec]
mkMessageCommon Bool
genType String
prefix String
postfix String
master String
dt String
folder Text
lang = do
    [String]
files <- IO [String] -> Q [String]
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO [String] -> Q [String]) -> IO [String] -> Q [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
getDirectoryContents String
folder
    let files' :: [String]
files' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
".", String
".."]) [String]
files
    ([[String]]
filess, [(Text, [Def])]
contents) <- IO ([[String]], [(Text, [Def])]) -> Q ([[String]], [(Text, [Def])])
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO ([[String]], [(Text, [Def])])
 -> Q ([[String]], [(Text, [Def])]))
-> IO ([[String]], [(Text, [Def])])
-> Q ([[String]], [(Text, [Def])])
forall a b. (a -> b) -> a -> b
$ ([Maybe ([String], (Text, [Def]))]
 -> ([[String]], [(Text, [Def])]))
-> IO [Maybe ([String], (Text, [Def]))]
-> IO ([[String]], [(Text, [Def])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([([String], (Text, [Def]))] -> ([[String]], [(Text, [Def])])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([String], (Text, [Def]))] -> ([[String]], [(Text, [Def])]))
-> ([Maybe ([String], (Text, [Def]))]
    -> [([String], (Text, [Def]))])
-> [Maybe ([String], (Text, [Def]))]
-> ([[String]], [(Text, [Def])])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ([String], (Text, [Def]))] -> [([String], (Text, [Def]))]
forall a. [Maybe a] -> [a]
catMaybes) (IO [Maybe ([String], (Text, [Def]))]
 -> IO ([[String]], [(Text, [Def])]))
-> IO [Maybe ([String], (Text, [Def]))]
-> IO ([[String]], [(Text, [Def])])
forall a b. (a -> b) -> a -> b
$ (String -> IO (Maybe ([String], (Text, [Def]))))
-> [String] -> IO [Maybe ([String], (Text, [Def]))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> String -> IO (Maybe ([String], (Text, [Def])))
loadLang String
folder) [String]
files'
    (([String] -> Q ()) -> [[String]] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_(([String] -> Q ()) -> [[String]] -> Q ())
-> ((String -> Q ()) -> [String] -> Q ())
-> (String -> Q ())
-> [[String]]
-> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String -> Q ()) -> [String] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_) String -> Q ()
addDependentFile [[String]]
filess
    let contents' :: [(Text, [Def])]
contents' = Map Text [Def] -> [(Text, [Def])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text [Def] -> [(Text, [Def])])
-> Map Text [Def] -> [(Text, [Def])]
forall a b. (a -> b) -> a -> b
$ ([Def] -> [Def] -> [Def]) -> [(Text, [Def])] -> Map Text [Def]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Def] -> [Def] -> [Def]
forall a. [a] -> [a] -> [a]
(++) [(Text, [Def])]
contents
    [SDef]
sdef <-
        case Text -> [(Text, [Def])] -> Maybe [Def]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
lang [(Text, [Def])]
contents' of
            Maybe [Def]
Nothing -> String -> Q [SDef]
forall a. HasCallStack => String -> a
error (String -> Q [SDef]) -> String -> Q [SDef]
forall a b. (a -> b) -> a -> b
$ String
"Did not find main language file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
lang
            Just [Def]
def -> [Def] -> Q [SDef]
toSDefs [Def]
def
    ([Def] -> Q ()) -> [[Def]] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([SDef] -> [Def] -> Q ()
checkDef [SDef]
sdef) ([[Def]] -> Q ()) -> [[Def]] -> Q ()
forall a b. (a -> b) -> a -> b
$ ((Text, [Def]) -> [Def]) -> [(Text, [Def])] -> [[Def]]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [Def]) -> [Def]
forall a b. (a, b) -> b
snd [(Text, [Def])]
contents'
    let mname :: Name
mname = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
dt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
postfix
    [Clause]
c1 <- ([[Clause]] -> [Clause]) -> Q [[Clause]] -> Q [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Clause]] -> [Clause]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Clause]] -> Q [Clause]) -> Q [[Clause]] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ ((Text, [Def]) -> Q [Clause]) -> [(Text, [Def])] -> Q [[Clause]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> String -> (Text, [Def]) -> Q [Clause]
toClauses String
prefix String
dt) [(Text, [Def])]
contents'
    [Clause]
c2 <- (SDef -> Q Clause) -> [SDef] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> String -> SDef -> Q Clause
sToClause String
prefix String
dt) [SDef]
sdef
    Clause
c3 <- Q Clause
defClause
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
     ( if Bool
genType
       then ((Cxt
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
mname [] Maybe Kind
forall a. Maybe a
Nothing ((SDef -> Con) -> [SDef] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SDef -> Con
toCon String
dt) [SDef]
sdef) []) Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:)
       else [Dec] -> [Dec]
forall a. a -> a
id)
        [ Cxt -> Kind -> [Dec] -> Dec
instanceD
            []
            (Name -> Kind
ConT ''RenderMessage Kind -> Kind -> Kind
`AppT` (Name -> Kind
ConT (Name -> Kind) -> Name -> Kind
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
master) Kind -> Kind -> Kind
`AppT` Name -> Kind
ConT Name
mname)
            [ Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"renderMessage") ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ [Clause]
c1 [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [Clause]
c2 [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [Clause
c3]
            ]
        ]

toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause]
toClauses :: String -> String -> (Text, [Def]) -> Q [Clause]
toClauses String
prefix String
dt (Text
lang, [Def]
defs) =
    (Def -> Q Clause) -> [Def] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Def -> Q Clause
go [Def]
defs
  where
    go :: Def -> Q Clause
go Def
def = do
        Name
a <- String -> Q Name
newName String
"lang"
        (Pat
pat, Exp
bod) <- String -> String -> [String] -> [Content] -> Q (Pat, Exp)
mkBody String
dt (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ Def -> String
constr Def
def) (((String, Maybe String) -> String)
-> [(String, Maybe String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe String) -> String
forall a b. (a, b) -> a
fst ([(String, Maybe String)] -> [String])
-> [(String, Maybe String)] -> [String]
forall a b. (a -> b) -> a -> b
$ Def -> [(String, Maybe String)]
vars Def
def) (Def -> [Content]
content Def
def)
        Guard
guard <- (Exp -> Guard) -> Q Exp -> Q Guard
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Guard
NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]
        Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
            [Pat
WildP, Name -> [Pat] -> Pat
conP (String -> Name
mkName String
":") [Name -> Pat
VarP Name
a, Pat
WildP], Pat
pat]
            ([(Guard, Exp)] -> Body
GuardedB [(Guard
guard, Exp
bod)])
            []

mkBody :: String -- ^ datatype
       -> String -- ^ constructor
       -> [String] -- ^ variable names
       -> [Content]
       -> Q (Pat, Exp)
mkBody :: String -> String -> [String] -> [Content] -> Q (Pat, Exp)
mkBody String
dt String
cs [String]
vs [Content]
ct = do
    [(String, Name)]
vp <- (String -> Q (String, Name)) -> [String] -> Q [(String, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Q (String, Name)
forall (m :: * -> *). Monad m => String -> m (String, Name)
go [String]
vs
    let pat :: Pat
pat = Name -> [FieldPat] -> Pat
RecP (String -> Name
mkName String
cs) (((String, Name) -> FieldPat) -> [(String, Name)] -> [FieldPat]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Name
varName String
dt (String -> Name) -> (Name -> Pat) -> (String, Name) -> FieldPat
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Name -> Pat
VarP) [(String, Name)]
vp)
    let ct' :: [Content]
ct' = (Content -> Content) -> [Content] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map ([(String, Name)] -> Content -> Content
fixVars [(String, Name)]
vp) [Content]
ct
    Exp
pack' <- [|Data.Text.pack|]
    Exp
tomsg <- [|toMessage|]
    let ct'' :: [Exp]
ct'' = (Content -> Exp) -> [Content] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Exp -> Content -> Exp
toH Exp
pack' Exp
tomsg) [Content]
ct'
    Exp
mapp <- [|mappend|]
    let app :: Exp -> Exp -> Exp
app Exp
a Exp
b = Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
a) Exp
mapp (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
b)
    Exp
e <-
        case [Exp]
ct'' of
            [] -> [|mempty|]
            [Exp
x] -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
            (Exp
x:[Exp]
xs) -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
app Exp
x [Exp]
xs
    (Pat, Exp) -> Q (Pat, Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat
pat, Exp
e)
  where
    toH :: Exp -> Exp -> Content -> Exp
toH Exp
pack' Exp
_ (Raw String
s) = Exp
pack' Exp -> Exp -> Exp
`AppE` Exp -> Kind -> Exp
SigE (Lit -> Exp
LitE (String -> Lit
StringL String
s)) (Name -> Kind
ConT ''String)
    toH Exp
_ Exp
tomsg (Var Deref
d) = Exp
tomsg Exp -> Exp -> Exp
`AppE` Scope -> Deref -> Exp
derefToExp [] Deref
d
    go :: String -> m (String, Name)
go String
x = do
        let y :: Name
y = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: String
x
        (String, Name) -> m (String, Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
x, Name
y)
    fixVars :: [(String, Name)] -> Content -> Content
fixVars [(String, Name)]
vp (Var Deref
d) = Deref -> Content
Var (Deref -> Content) -> Deref -> Content
forall a b. (a -> b) -> a -> b
$ [(String, Name)] -> Deref -> Deref
fixDeref [(String, Name)]
vp Deref
d
    fixVars [(String, Name)]
_ (Raw String
s) = String -> Content
Raw String
s
    fixDeref :: [(String, Name)] -> Deref -> Deref
fixDeref [(String, Name)]
vp (DerefIdent (Ident String
i)) = Ident -> Deref
DerefIdent (Ident -> Deref) -> Ident -> Deref
forall a b. (a -> b) -> a -> b
$ String -> Ident
Ident (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$ [(String, Name)] -> String -> String
fixIdent [(String, Name)]
vp String
i
    fixDeref [(String, Name)]
vp (DerefBranch Deref
a Deref
b) = Deref -> Deref -> Deref
DerefBranch ([(String, Name)] -> Deref -> Deref
fixDeref [(String, Name)]
vp Deref
a) ([(String, Name)] -> Deref -> Deref
fixDeref [(String, Name)]
vp Deref
b)
    fixDeref [(String, Name)]
_ Deref
d = Deref
d
    fixIdent :: [(String, Name)] -> String -> String
fixIdent [(String, Name)]
vp String
i =
        case String -> [(String, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
i [(String, Name)]
vp of
            Maybe Name
Nothing -> String
i
            Just Name
y -> Name -> String
nameBase Name
y

sToClause :: String -> String -> SDef -> Q Clause
sToClause :: String -> String -> SDef -> Q Clause
sToClause String
prefix String
dt SDef
sdef = do
    (Pat
pat, Exp
bod) <- String -> String -> [String] -> [Content] -> Q (Pat, Exp)
mkBody String
dt (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ SDef -> String
sconstr SDef
sdef) (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ SDef -> [(String, String)]
svars SDef
sdef) (SDef -> [Content]
scontent SDef
sdef)
    Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
        [Pat
WildP, Name -> [Pat] -> Pat
conP (String -> Name
mkName String
"[]") [], Pat
pat]
        (Exp -> Body
NormalB Exp
bod)
        []

defClause :: Q Clause
defClause :: Q Clause
defClause = do
    Name
a <- String -> Q Name
newName String
"sub"
    Name
c <- String -> Q Name
newName String
"langs"
    Name
d <- String -> Q Name
newName String
"msg"
    Exp
rm <- [|renderMessage|]
    Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
        [Name -> Pat
VarP Name
a, Name -> [Pat] -> Pat
conP (String -> Name
mkName String
":") [Pat
WildP, Name -> Pat
VarP Name
c], Name -> Pat
VarP Name
d]
        (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp
rm Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
a Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
c Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
d)
        []

conP :: Name -> [Pat] -> Pat
#if MIN_VERSION_template_haskell(2,18,0)
conP name = ConP name []
#else
conP :: Name -> [Pat] -> Pat
conP = Name -> [Pat] -> Pat
ConP
#endif

toCon :: String -> SDef -> Con
toCon :: String -> SDef -> Con
toCon String
dt (SDef String
c [(String, String)]
vs [Content]
_) =
    Name -> [VarBangType] -> Con
RecC (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"Msg" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c) ([VarBangType] -> Con) -> [VarBangType] -> Con
forall a b. (a -> b) -> a -> b
$ ((String, String) -> VarBangType)
-> [(String, String)] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> VarBangType
go [(String, String)]
vs
  where
    go :: (String, String) -> VarBangType
go (String
n, String
t) = (String -> String -> Name
varName String
dt String
n, Bang
notStrict, Name -> Kind
ConT (Name -> Kind) -> Name -> Kind
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
t)

varName :: String -> String -> Name
varName :: String -> String -> Name
varName String
a String
y =
    String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String -> String
lower String
a, String
"Message", String -> String
upper String
y]
  where
    lower :: String -> String
lower (Char
x:String
xs) = Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
    lower [] = []
    upper :: String -> String
upper (Char
x:String
xs) = Char -> Char
toUpper Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
    upper [] = []

checkDef :: [SDef] -> [Def] -> Q ()
checkDef :: [SDef] -> [Def] -> Q ()
checkDef [SDef]
x [Def]
y =
    [SDef] -> [Def] -> Q ()
forall (m :: * -> *). Monad m => [SDef] -> [Def] -> m ()
go ((SDef -> SDef -> Ordering) -> [SDef] -> [SDef]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((SDef -> String) -> SDef -> SDef -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SDef -> String
sconstr) [SDef]
x) ((Def -> Def -> Ordering) -> [Def] -> [Def]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Def -> String) -> Def -> Def -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Def -> String
constr) [Def]
y)
  where
    go :: [SDef] -> [Def] -> m ()
go [SDef]
_ [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go [] (Def
b:[Def]
_) = String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Extra message constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Def -> String
constr Def
b
    go (SDef
a:[SDef]
as) (Def
b:[Def]
bs)
        | SDef -> String
sconstr SDef
a String -> String -> Bool
forall a. Ord a => a -> a -> Bool
< Def -> String
constr Def
b = [SDef] -> [Def] -> m ()
go [SDef]
as (Def
bDef -> [Def] -> [Def]
forall a. a -> [a] -> [a]
:[Def]
bs)
        | SDef -> String
sconstr SDef
a String -> String -> Bool
forall a. Ord a => a -> a -> Bool
> Def -> String
constr Def
b = String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Extra message constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Def -> String
constr Def
b
        | Bool
otherwise = do
            [(String, String)] -> [(String, Maybe String)] -> m ()
forall a a (m :: * -> *).
(Eq a, Eq a, Monad m) =>
[(a, a)] -> [(a, Maybe a)] -> m ()
go' (SDef -> [(String, String)]
svars SDef
a) (Def -> [(String, Maybe String)]
vars Def
b)
            [SDef] -> [Def] -> m ()
go [SDef]
as [Def]
bs
    go' :: [(a, a)] -> [(a, Maybe a)] -> m ()
go' ((a
an, a
at):[(a, a)]
as) ((a
bn, Maybe a
mbt):[(a, Maybe a)]
bs)
        | a
an a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
bn = String -> m ()
forall a. HasCallStack => String -> a
error String
"Mismatched variable names"
        | Bool
otherwise =
            case Maybe a
mbt of
                Maybe a
Nothing -> [(a, a)] -> [(a, Maybe a)] -> m ()
go' [(a, a)]
as [(a, Maybe a)]
bs
                Just a
bt
                    | a
at a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
bt -> [(a, a)] -> [(a, Maybe a)] -> m ()
go' [(a, a)]
as [(a, Maybe a)]
bs
                    | Bool
otherwise -> String -> m ()
forall a. HasCallStack => String -> a
error String
"Mismatched variable types"
    go' [] [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go' [(a, a)]
_ [(a, Maybe a)]
_ = String -> m ()
forall a. HasCallStack => String -> a
error String
"Mistmached variable count"

toSDefs :: [Def] -> Q [SDef]
toSDefs :: [Def] -> Q [SDef]
toSDefs = (Def -> Q SDef) -> [Def] -> Q [SDef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Def -> Q SDef
toSDef

toSDef :: Def -> Q SDef
toSDef :: Def -> Q SDef
toSDef Def
d = do
    [(String, String)]
vars' <- ((String, Maybe String) -> Q (String, String))
-> [(String, Maybe String)] -> Q [(String, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, Maybe String) -> Q (String, String)
go ([(String, Maybe String)] -> Q [(String, String)])
-> [(String, Maybe String)] -> Q [(String, String)]
forall a b. (a -> b) -> a -> b
$ Def -> [(String, Maybe String)]
vars Def
d
    SDef -> Q SDef
forall (m :: * -> *) a. Monad m => a -> m a
return (SDef -> Q SDef) -> SDef -> Q SDef
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> [Content] -> SDef
SDef (Def -> String
constr Def
d) [(String, String)]
vars' (Def -> [Content]
content Def
d)
  where
    go :: (String, Maybe String) -> Q (String, String)
go (String
a, Just String
b) = (String, String) -> Q (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
a, String
b)
    go (String
a, Maybe String
Nothing) = String -> Q (String, String)
forall a. HasCallStack => String -> a
error (String -> Q (String, String)) -> String -> Q (String, String)
forall a b. (a -> b) -> a -> b
$ String
"Main language missing type for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, String) -> String
forall a. Show a => a -> String
show (Def -> String
constr Def
d, String
a)

data SDef = SDef
    { SDef -> String
sconstr :: String
    , SDef -> [(String, String)]
svars :: [(String, String)]
    , SDef -> [Content]
scontent :: [Content]
    }

data Def = Def
    { Def -> String
constr :: String
    , Def -> [(String, Maybe String)]
vars :: [(String, Maybe String)]
    , Def -> [Content]
content :: [Content]
    }

(</>) :: FilePath -> FilePath -> FilePath
String
path </> :: String -> String -> String
</> String
file = String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> String -> String
forall a. a -> [a] -> [a]
: String
file

loadLang :: FilePath -> FilePath -> IO (Maybe ([FilePath], (Lang, [Def])))
loadLang :: String -> String -> IO (Maybe ([String], (Text, [Def])))
loadLang String
folder String
file = do
    let file' :: String
file' = String
folder String -> String -> String
</> String
file
    Bool
isFile <- String -> IO Bool
doesFileExist String
file'
    if Bool
isFile Bool -> Bool -> Bool
&& String
".msg" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
file
        then do
            let lang :: Text
lang = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
4 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
file
            [Def]
defs <- String -> IO [Def]
loadLangFile String
file'
            Maybe ([String], (Text, [Def]))
-> IO (Maybe ([String], (Text, [Def])))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([String], (Text, [Def]))
 -> IO (Maybe ([String], (Text, [Def]))))
-> Maybe ([String], (Text, [Def]))
-> IO (Maybe ([String], (Text, [Def])))
forall a b. (a -> b) -> a -> b
$ ([String], (Text, [Def])) -> Maybe ([String], (Text, [Def]))
forall a. a -> Maybe a
Just ([String
file'], (Text
lang, [Def]
defs))
        else do
            Bool
isDir <- String -> IO Bool
doesDirectoryExist String
file'
            if Bool
isDir
                then do
                    let lang :: Text
lang = String -> Text
pack String
file
                    ([String]
files, [[Def]]
defs) <- [(String, [Def])] -> ([String], [[Def]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(String, [Def])] -> ([String], [[Def]]))
-> IO [(String, [Def])] -> IO ([String], [[Def]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [(String, [Def])]
loadLangDir String
file'
                    Maybe ([String], (Text, [Def]))
-> IO (Maybe ([String], (Text, [Def])))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([String], (Text, [Def]))
 -> IO (Maybe ([String], (Text, [Def]))))
-> Maybe ([String], (Text, [Def]))
-> IO (Maybe ([String], (Text, [Def])))
forall a b. (a -> b) -> a -> b
$ ([String], (Text, [Def])) -> Maybe ([String], (Text, [Def]))
forall a. a -> Maybe a
Just ([String]
files, (Text
lang, [[Def]] -> [Def]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Def]]
defs))
                else
                    Maybe ([String], (Text, [Def]))
-> IO (Maybe ([String], (Text, [Def])))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([String], (Text, [Def]))
forall a. Maybe a
Nothing

loadLangDir :: FilePath -> IO [(FilePath, [Def])]
loadLangDir :: String -> IO [(String, [Def])]
loadLangDir String
folder = do
    [String]
paths <- (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
folder String -> String -> String
</>) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
".", String
".."]) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
folder
    [String]
files <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
paths
    [String]
dirs  <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist [String]
paths
    [Maybe (String, [Def])]
langFiles <-
        [String]
-> (String -> IO (Maybe (String, [Def])))
-> IO [Maybe (String, [Def])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
files ((String -> IO (Maybe (String, [Def])))
 -> IO [Maybe (String, [Def])])
-> (String -> IO (Maybe (String, [Def])))
-> IO [Maybe (String, [Def])]
forall a b. (a -> b) -> a -> b
$ \String
file -> do
            if String
".msg" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
file
                then do
                  [Def]
defs <- String -> IO [Def]
loadLangFile String
file
                  Maybe (String, [Def]) -> IO (Maybe (String, [Def]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (String, [Def]) -> IO (Maybe (String, [Def])))
-> Maybe (String, [Def]) -> IO (Maybe (String, [Def]))
forall a b. (a -> b) -> a -> b
$ (String, [Def]) -> Maybe (String, [Def])
forall a. a -> Maybe a
Just (String
file, [Def]
defs)
                else do
                  Maybe (String, [Def]) -> IO (Maybe (String, [Def]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (String, [Def])
forall a. Maybe a
Nothing
    [[(String, [Def])]]
langDirs <- (String -> IO [(String, [Def])])
-> [String] -> IO [[(String, [Def])]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [(String, [Def])]
loadLangDir [String]
dirs
    [(String, [Def])] -> IO [(String, [Def])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, [Def])] -> IO [(String, [Def])])
-> [(String, [Def])] -> IO [(String, [Def])]
forall a b. (a -> b) -> a -> b
$ [Maybe (String, [Def])] -> [(String, [Def])]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (String, [Def])]
langFiles [(String, [Def])] -> [(String, [Def])] -> [(String, [Def])]
forall a. [a] -> [a] -> [a]
++ [[(String, [Def])]] -> [(String, [Def])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(String, [Def])]]
langDirs

loadLangFile :: FilePath -> IO [Def]
loadLangFile :: String -> IO [Def]
loadLangFile String
file = do
    ByteString
bs <- String -> IO ByteString
S.readFile String
file
    let s :: String
s = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
bs
    [Def]
defs <- ([Maybe Def] -> [Def]) -> IO [Maybe Def] -> IO [Def]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Def] -> [Def]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe Def] -> IO [Def]) -> IO [Maybe Def] -> IO [Def]
forall a b. (a -> b) -> a -> b
$ (String -> IO (Maybe Def)) -> [String] -> IO [Maybe Def]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO (Maybe Def)
parseDef (String -> IO (Maybe Def))
-> (String -> String) -> String -> IO (Maybe Def)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) ([String] -> IO [Maybe Def]) -> [String] -> IO [Maybe Def]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s
    [Def] -> IO [Def]
forall (m :: * -> *) a. Monad m => a -> m a
return [Def]
defs

parseDef :: String -> IO (Maybe Def)
parseDef :: String -> IO (Maybe Def)
parseDef String
"" = Maybe Def -> IO (Maybe Def)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Def
forall a. Maybe a
Nothing
parseDef (Char
'#':String
_) = Maybe Def -> IO (Maybe Def)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Def
forall a. Maybe a
Nothing
parseDef String
s =
    case String
end of
        Char
':':String
end' -> do
            [Content]
content' <- ([Content] -> [Content]) -> IO [Content] -> IO [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Content] -> [Content]
compress (IO [Content] -> IO [Content]) -> IO [Content] -> IO [Content]
forall a b. (a -> b) -> a -> b
$ String -> IO [Content]
parseContent (String -> IO [Content]) -> String -> IO [Content]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
end'
            case String -> [String]
words String
begin of
                [] -> String -> IO (Maybe Def)
forall a. HasCallStack => String -> a
error (String -> IO (Maybe Def)) -> String -> IO (Maybe Def)
forall a b. (a -> b) -> a -> b
$ String
"Missing constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
                (String
w:[String]
ws) -> Maybe Def -> IO (Maybe Def)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Def -> IO (Maybe Def)) -> Maybe Def -> IO (Maybe Def)
forall a b. (a -> b) -> a -> b
$ Def -> Maybe Def
forall a. a -> Maybe a
Just Def :: String -> [(String, Maybe String)] -> [Content] -> Def
Def
                            { constr :: String
constr = String
w
                            , vars :: [(String, Maybe String)]
vars = (String -> (String, Maybe String))
-> [String] -> [(String, Maybe String)]
forall a b. (a -> b) -> [a] -> [b]
map String -> (String, Maybe String)
parseVar [String]
ws
                            , content :: [Content]
content = [Content]
content'
                            }
        String
_ -> String -> IO (Maybe Def)
forall a. HasCallStack => String -> a
error (String -> IO (Maybe Def)) -> String -> IO (Maybe Def)
forall a b. (a -> b) -> a -> b
$ String
"Missing colon: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
  where
    (String
begin, String
end) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') String
s

data Content = Var Deref | Raw String

compress :: [Content] -> [Content]
compress :: [Content] -> [Content]
compress [] = []
compress (Raw String
a:Raw String
b:[Content]
rest) = [Content] -> [Content]
compress ([Content] -> [Content]) -> [Content] -> [Content]
forall a b. (a -> b) -> a -> b
$ String -> Content
Raw (String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b) Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
rest
compress (Content
x:[Content]
y) = Content
x Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content] -> [Content]
compress [Content]
y

parseContent :: String -> IO [Content]
parseContent :: String -> IO [Content]
parseContent String
s =
    (ParseError -> IO [Content])
-> ([Content] -> IO [Content])
-> Either ParseError [Content]
-> IO [Content]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO [Content]
forall a. HasCallStack => String -> a
error (String -> IO [Content])
-> (ParseError -> String) -> ParseError -> IO [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show) [Content] -> IO [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError [Content] -> IO [Content])
-> Either ParseError [Content] -> IO [Content]
forall a b. (a -> b) -> a -> b
$ Parsec String () [Content]
-> String -> String -> Either ParseError [Content]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () [Content]
forall u. ParsecT String u Identity [Content]
go String
s String
s
  where
    go :: ParsecT String u Identity [Content]
go = do
        [Content]
x <- ParsecT String u Identity Content
-> ParsecT String u Identity [Content]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String u Identity Content
forall u. ParsecT String u Identity Content
go'
        ParsecT String u Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
        [Content] -> ParsecT String u Identity [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Content]
x
    go' :: ParsecT String u Identity Content
go' = (String -> Content
Raw (String -> Content)
-> ParsecT String u Identity String
-> ParsecT String u Identity Content
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecT String u Identity Char -> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"#")) ParsecT String u Identity Content
-> ParsecT String u Identity Content
-> ParsecT String u Identity Content
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ((Either String Deref -> Content)
-> ParsecT String u Identity (Either String Deref)
-> ParsecT String u Identity Content
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Content)
-> (Deref -> Content) -> Either String Deref -> Content
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Content
Raw Deref -> Content
Var) ParsecT String u Identity (Either String Deref)
forall a. UserParser a (Either String Deref)
parseHash)

parseVar :: String -> (String, Maybe String)
parseVar :: String -> (String, Maybe String)
parseVar String
s =
    case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@') String
s of
        (String
x, Char
'@':String
y) -> (String
x, String -> Maybe String
forall a. a -> Maybe a
Just String
y)
        (String, String)
_ -> (String
s, Maybe String
forall a. Maybe a
Nothing)

data SomeMessage master = forall msg. RenderMessage master msg => SomeMessage msg

instance IsString (SomeMessage master) where
    fromString :: String -> SomeMessage master
fromString = Text -> SomeMessage master
forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage (Text -> SomeMessage master)
-> (String -> Text) -> String -> SomeMessage master
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance master ~ master' => RenderMessage master (SomeMessage master') where
    renderMessage :: master -> [Text] -> SomeMessage master' -> Text
renderMessage master
a [Text]
b (SomeMessage msg
msg) = master -> [Text] -> msg -> Text
forall master message.
RenderMessage master message =>
master -> [Text] -> message -> Text
renderMessage master
a [Text]
b msg
msg

notStrict :: Bang
notStrict :: Bang
notStrict = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness

instanceD :: Cxt -> Type -> [Dec] -> Dec
instanceD :: Cxt -> Kind -> [Dec] -> Dec
instanceD = Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing