{-# 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 hiding (makeRelativeToProject)
import Control.Applicative ((<$>))
import Control.Monad (filterM, forM)
import Data.Text (Text, pack, unpack)
import System.Directory
import Data.FileEmbed (makeRelativeToProject)
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 :: Lang -> Lang
toMessage = Lang -> Lang
forall a. a -> a
id
instance ToMessage String where
    toMessage :: String -> Lang
toMessage = String -> Lang
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 -> [Lang] -> Lang -> Lang
renderMessage master
_ [Lang]
_ = Lang -> Lang
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 -> Lang -> Q [Dec]
mkMessage String
dt String
folder Lang
lang =
    Bool
-> String
-> String
-> String
-> String
-> String
-> Lang
-> Q [Dec]
mkMessageCommon Bool
True String
"Msg" String
"Message" String
dt String
dt String
folder Lang
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 -> Lang -> Q [Dec]
mkMessageFor String
master String
dt String
folder Lang
lang = Bool
-> String
-> String
-> String
-> String
-> String
-> Lang
-> Q [Dec]
mkMessageCommon Bool
False String
"" String
"" String
master String
dt String
folder Lang
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 -> Lang -> Q [Dec]
mkMessageVariant String
master String
dt String
folder Lang
lang = Bool
-> String
-> String
-> String
-> String
-> String
-> Lang
-> Q [Dec]
mkMessageCommon Bool
False String
"Msg" String
"Message" String
master String
dt String
folder Lang
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
-> Lang
-> Q [Dec]
mkMessageCommon Bool
genType String
prefix String
postfix String
master String
dt String
rawFolder Lang
lang = do
    String
folder <- String -> Q String
makeRelativeToProject String
rawFolder
    [String]
files <- IO [String] -> Q [String]
forall a. IO a -> Q a
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, [(Lang, [Def])]
contents) <- IO ([[String]], [(Lang, [Def])]) -> Q ([[String]], [(Lang, [Def])])
forall a. IO a -> Q a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO ([[String]], [(Lang, [Def])])
 -> Q ([[String]], [(Lang, [Def])]))
-> IO ([[String]], [(Lang, [Def])])
-> Q ([[String]], [(Lang, [Def])])
forall a b. (a -> b) -> a -> b
$ ([Maybe ([String], (Lang, [Def]))]
 -> ([[String]], [(Lang, [Def])]))
-> IO [Maybe ([String], (Lang, [Def]))]
-> IO ([[String]], [(Lang, [Def])])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([([String], (Lang, [Def]))] -> ([[String]], [(Lang, [Def])])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([String], (Lang, [Def]))] -> ([[String]], [(Lang, [Def])]))
-> ([Maybe ([String], (Lang, [Def]))]
    -> [([String], (Lang, [Def]))])
-> [Maybe ([String], (Lang, [Def]))]
-> ([[String]], [(Lang, [Def])])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ([String], (Lang, [Def]))] -> [([String], (Lang, [Def]))]
forall a. [Maybe a] -> [a]
catMaybes) (IO [Maybe ([String], (Lang, [Def]))]
 -> IO ([[String]], [(Lang, [Def])]))
-> IO [Maybe ([String], (Lang, [Def]))]
-> IO ([[String]], [(Lang, [Def])])
forall a b. (a -> b) -> a -> b
$ (String -> IO (Maybe ([String], (Lang, [Def]))))
-> [String] -> IO [Maybe ([String], (Lang, [Def]))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> String -> IO (Maybe ([String], (Lang, [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' :: [(Lang, [Def])]
contents' = Map Lang [Def] -> [(Lang, [Def])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Lang [Def] -> [(Lang, [Def])])
-> Map Lang [Def] -> [(Lang, [Def])]
forall a b. (a -> b) -> a -> b
$ ([Def] -> [Def] -> [Def]) -> [(Lang, [Def])] -> Map Lang [Def]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Def] -> [Def] -> [Def]
forall a. [a] -> [a] -> [a]
(++) [(Lang, [Def])]
contents
    [SDef]
sdef <-
        case Lang -> [(Lang, [Def])] -> Maybe [Def]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Lang
lang [(Lang, [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]
++ Lang -> String
unpack Lang
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
$ ((Lang, [Def]) -> [Def]) -> [(Lang, [Def])] -> [[Def]]
forall a b. (a -> b) -> [a] -> [b]
map (Lang, [Def]) -> [Def]
forall a b. (a, b) -> b
snd [(Lang, [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 a b. (a -> b) -> Q a -> Q b
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
$ ((Lang, [Def]) -> Q [Clause]) -> [(Lang, [Def])] -> Q [[Clause]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> String -> (Lang, [Def]) -> Q [Clause]
toClauses String
prefix String
dt) [(Lang, [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> String -> SDef -> Q Clause
sToClause String
prefix String
dt) [SDef]
sdef
    Clause
c3 <- Q Clause
defClause
    [Dec] -> Q [Dec]
forall a. a -> Q a
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 -> (Lang, [Def]) -> Q [Clause]
toClauses String
prefix String
dt (Lang
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Def -> Q Clause
go [Def]
defs
  where
    go :: Def -> Q Clause
go Def
def = do
        Name
a <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m 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 a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Guard
NormalG [|$(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
a) == pack $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Lang -> String
unpack Lang
lang)|]
        Clause -> Q Clause
forall a. a -> Q a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
            (Exp
x:[Exp]
xs) -> Exp -> Q Exp
forall a. a -> Q a
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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. a -> Q a
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 a. a -> m a
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 a. a -> Q a
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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"sub"
    Name
c <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"langs"
    Name
d <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"msg"
    Exp
rm <- [|renderMessage|]
    Clause -> Q Clause
forall a. a -> Q a
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 -> [Pat] -> Pat
conP Name
name = Name -> Cxt -> [Pat] -> Pat
ConP Name
name []
#else
conP = 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 a. a -> m a
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 a. a -> m a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> Q a
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 a. a -> Q a
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], (Lang, [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 :: Lang
lang = String -> Lang
pack (String -> Lang) -> String -> Lang
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], (Lang, [Def]))
-> IO (Maybe ([String], (Lang, [Def])))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([String], (Lang, [Def]))
 -> IO (Maybe ([String], (Lang, [Def]))))
-> Maybe ([String], (Lang, [Def]))
-> IO (Maybe ([String], (Lang, [Def])))
forall a b. (a -> b) -> a -> b
$ ([String], (Lang, [Def])) -> Maybe ([String], (Lang, [Def]))
forall a. a -> Maybe a
Just ([String
file'], (Lang
lang, [Def]
defs))
        else do
            Bool
isDir <- String -> IO Bool
doesDirectoryExist String
file'
            if Bool
isDir
                then do
                    let lang :: Lang
lang = String -> Lang
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], (Lang, [Def]))
-> IO (Maybe ([String], (Lang, [Def])))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([String], (Lang, [Def]))
 -> IO (Maybe ([String], (Lang, [Def]))))
-> Maybe ([String], (Lang, [Def]))
-> IO (Maybe ([String], (Lang, [Def])))
forall a b. (a -> b) -> a -> b
$ ([String], (Lang, [Def])) -> Maybe ([String], (Lang, [Def]))
forall a. a -> Maybe a
Just ([String]
files, (Lang
lang, [[Def]] -> [Def]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Def]]
defs))
                else
                    Maybe ([String], (Lang, [Def]))
-> IO (Maybe ([String], (Lang, [Def])))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([String], (Lang, [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 a. a -> IO a
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 a. a -> IO a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO [(String, [Def])]
loadLangDir [String]
dirs
    [(String, [Def])] -> IO [(String, [Def])]
forall a. a -> IO a
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 = Lang -> String
unpack (Lang -> String) -> Lang -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Lang
decodeUtf8 ByteString
bs
    [Def]
defs <- ([Maybe Def] -> [Def]) -> IO [Maybe Def] -> IO [Def]
forall a b. (a -> b) -> IO a -> IO b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
. Lang -> String
T.unpack (Lang -> String) -> (String -> Lang) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lang -> Lang
T.strip (Lang -> Lang) -> (String -> Lang) -> String -> Lang
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lang
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a b. (a -> b) -> IO a -> IO b
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 a. a -> IO a
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
                            { 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 a. a -> IO a
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 a. a -> ParsecT String u Identity a
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 a b.
(a -> b)
-> ParsecT String u Identity a -> ParsecT String u Identity b
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 a b.
(a -> b)
-> ParsecT String u Identity a -> ParsecT String u Identity b
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 = Lang -> SomeMessage master
forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage (Lang -> SomeMessage master)
-> (String -> Lang) -> String -> SomeMessage master
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lang
T.pack

instance master ~ master' => RenderMessage master (SomeMessage master') where
    renderMessage :: master -> [Lang] -> SomeMessage master' -> Lang
renderMessage master
a [Lang]
b (SomeMessage msg
msg) = master -> [Lang] -> msg -> Lang
forall master message.
RenderMessage master message =>
master -> [Lang] -> message -> Lang
renderMessage master
a [Lang]
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