{-# 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 = 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]
_ = 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 <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ String -> IO [String]
getDirectoryContents String
folder
    let files' :: [String]
files' = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
".", String
".."]) [String]
files
    ([[String]]
filess, [(Lang, [Def])]
contents) <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> String -> IO (Maybe ([String], (Lang, [Def])))
loadLang String
folder) [String]
files'
    (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_forall b c a. (b -> c) -> (a -> b) -> a -> c
.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' = forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) [(Lang, [Def])]
contents
    [SDef]
sdef <-
        case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Lang
lang [(Lang, [Def])]
contents' of
            Maybe [Def]
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Did not find main language file: " forall a. [a] -> [a] -> [a]
++ Lang -> String
unpack Lang
lang
            Just [Def]
def -> [Def] -> Q [SDef]
toSDefs [Def]
def
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([SDef] -> [Def] -> Q ()
checkDef [SDef]
sdef) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Lang, [Def])]
contents'
    let mname :: Name
mname = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
dt forall a. [a] -> [a] -> [a]
++ String
postfix
    [Clause]
c1 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> String -> (Lang, [Def]) -> Q [Clause]
toClauses String
prefix String
dt) [(Lang, [Def])]
contents'
    [Clause]
c2 <- 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
     ( if Bool
genType
       then ((Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
mname [] forall a. Maybe a
Nothing (forall a b. (a -> b) -> [a] -> [b]
map (String -> SDef -> Con
toCon String
dt) [SDef]
sdef) []) forall a. a -> [a] -> [a]
:)
       else forall a. a -> a
id)
        [ Cxt -> Kind -> [Dec] -> Dec
instanceD
            []
            (Name -> Kind
ConT ''RenderMessage Kind -> Kind -> Kind
`AppT` (Name -> Kind
ConT 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") forall a b. (a -> b) -> a -> b
$ [Clause]
c1 forall a. [a] -> [a] -> [a]
++ [Clause]
c2 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) =
    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 <- 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 forall a. [a] -> [a] -> [a]
++ Def -> String
constr Def
def) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Def -> [(String, Maybe String)]
vars Def
def) (Def -> [Content]
content Def
def)
        Guard
guard <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Guard
NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. Monad m => String -> m (String, Name)
go [String]
vs
    let pat :: Pat
pat = Name -> [FieldPat] -> Pat
RecP (String -> Name
mkName String
cs) (forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Name
varName String
dt 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' = 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'' = 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 (forall a. a -> Maybe a
Just Exp
a) Exp
mapp (forall a. a -> Maybe a
Just Exp
b)
    Exp
e <-
        case [Exp]
ct'' of
            [] -> [|mempty|]
            [Exp
x] -> forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
            (Exp
x:[Exp]
xs) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> 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
    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 forall a b. (a -> b) -> a -> b
$ Char
'_' forall a. a -> [a] -> [a]
: String
x
        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 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 forall a b. (a -> b) -> a -> b
$ String -> Ident
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 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 forall a. [a] -> [a] -> [a]
++ SDef -> String
sconstr SDef
sdef) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ SDef -> [(String, String)]
svars SDef
sdef) (SDef -> [Content]
scontent SDef
sdef)
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"sub"
    Name
c <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"langs"
    Name
d <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"msg"
    Exp
rm <- [|renderMessage|]
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 forall a b. (a -> b) -> a -> b
$ String
"Msg" forall a. [a] -> [a] -> [a]
++ String
c) forall a b. (a -> b) -> a -> b
$ 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 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 forall a b. (a -> b) -> a -> b
$ 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 forall a. a -> [a] -> [a]
: String
xs
    lower [] = []
    upper :: String -> String
upper (Char
x:String
xs) = Char -> Char
toUpper Char
x forall a. a -> [a] -> [a]
: String
xs
    upper [] = []

checkDef :: [SDef] -> [Def] -> Q ()
checkDef :: [SDef] -> [Def] -> Q ()
checkDef [SDef]
x [Def]
y =
    forall {m :: * -> *}. Monad m => [SDef] -> [Def] -> m ()
go (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing SDef -> String
sconstr) [SDef]
x) (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Def -> String
constr) [Def]
y)
  where
    go :: [SDef] -> [Def] -> m ()
go [SDef]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go [] (Def
b:[Def]
_) = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Extra message constructor: " forall a. [a] -> [a] -> [a]
++ Def -> String
constr Def
b
    go (SDef
a:[SDef]
as) (Def
b:[Def]
bs)
        | SDef -> String
sconstr SDef
a forall a. Ord a => a -> a -> Bool
< Def -> String
constr Def
b = [SDef] -> [Def] -> m ()
go [SDef]
as (Def
bforall a. a -> [a] -> [a]
:[Def]
bs)
        | SDef -> String
sconstr SDef
a forall a. Ord a => a -> a -> Bool
> Def -> String
constr Def
b = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Extra message constructor: " forall a. [a] -> [a] -> [a]
++ Def -> String
constr Def
b
        | Bool
otherwise = do
            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 forall a. Eq a => a -> a -> Bool
/= a
bn = 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 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 -> forall a. HasCallStack => String -> a
error String
"Mismatched variable types"
    go' [] [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go' [(a, a)]
_ [(a, Maybe a)]
_ = forall a. HasCallStack => String -> a
error String
"Mistmached variable count"

toSDefs :: [Def] -> Q [SDef]
toSDefs :: [Def] -> Q [SDef]
toSDefs = 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' <- 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 forall a b. (a -> b) -> a -> b
$ Def -> [(String, Maybe String)]
vars Def
d
    forall (m :: * -> *) a. Monad m => a -> m a
return 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) = forall (m :: * -> *) a. Monad m => a -> m a
return (String
a, String
b)
    go (String
a, Maybe String
Nothing) = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Main language missing type for " forall a. [a] -> [a] -> [a]
++ 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 forall a. [a] -> [a] -> [a]
++ Char
'/' 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" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
file
        then do
            let lang :: Lang
lang = String -> Lang
pack forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
4 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse String
file
            [Def]
defs <- String -> IO [Def]
loadLangFile String
file'
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [(String, [Def])]
loadLangDir String
file'
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([String]
files, (Lang
lang, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Def]]
defs))
                else
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

loadLangDir :: FilePath -> IO [(FilePath, [Def])]
loadLangDir :: String -> IO [(String, [Def])]
loadLangDir String
folder = do
    [String]
paths <- forall a b. (a -> b) -> [a] -> [b]
map (String
folder String -> String -> String
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
".", String
".."]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
folder
    [String]
files <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
paths
    [String]
dirs  <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist [String]
paths
    [Maybe (String, [Def])]
langFiles <-
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
files forall a b. (a -> b) -> a -> b
$ \String
file -> do
            if String
".msg" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
file
                then do
                  [Def]
defs <- String -> IO [Def]
loadLangFile String
file
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (String
file, [Def]
defs)
                else do
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    [[(String, [Def])]]
langDirs <- 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe (String, [Def])]
langFiles forall a. [a] -> [a] -> [a]
++ 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 forall a b. (a -> b) -> a -> b
$ ByteString -> Lang
decodeUtf8 ByteString
bs
    [Def]
defs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO (Maybe Def)
parseDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lang -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lang -> Lang
T.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lang
T.pack) forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s
    forall (m :: * -> *) a. Monad m => a -> m a
return [Def]
defs

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

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

parseVar :: String -> (String, Maybe String)
parseVar :: String -> (String, Maybe String)
parseVar String
s =
    case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'@') String
s of
        (String
x, Char
'@':String
y) -> (String
x, forall a. a -> Maybe a
Just String
y)
        (String, String)
_ -> (String
s, 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 = forall master msg.
RenderMessage master msg =>
msg -> SomeMessage master
SomeMessage 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) = 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 forall a. Maybe a
Nothing