    {-# 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
        folder <- String -> Q String
    makeRelativeToProject String
    rawFolder
        files <- qRunIO $ getDirectoryContents folder
        let 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
        (filess, contents) <- qRunIO $ fmap (unzip . catMaybes) $ mapM (loadLang folder) files'
        (mapM_.mapM_) addDependentFile filess
        let 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 <-
            case lookup lang 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
        mapM_ (checkDef sdef) $ map snd contents'
        let 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
        c1 <- fmap concat $ mapM (toClauses prefix dt) contents'
        c2 <- mapM (sToClause prefix dt) sdef
        c3 <- defClause
        return $
         ( if genType
           then ((DataD [] mname [] Nothing (map (toCon dt) sdef) []) :)
           else id)
            [ instanceD
                []
                (ConT ''RenderMessage `AppT` (ConT $ mkName master) `AppT` ConT mname)
                [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [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
            a <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "lang"
            (pat, bod) <- mkBody dt (prefix ++ constr def) (map fst $ vars def) (content def)
            guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]
            return $ Clause
                [WildP, conP (mkName ":") [VarP a, WildP], pat]
                (GuardedB [(guard, 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
        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 = 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 -> Content) -> [Content] -> [Content]
    forall a b. (a -> b) -> [a] -> [b]
    map ([(String, Name)] -> Content -> Content
    fixVars [(String, Name)]
    vp) [Content]
    ct
        pack' <- [|Data.Text.pack|]
        tomsg <- [|toMessage|]
        let ct'' = (Content -> Exp) -> [Content] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (Exp -> Exp -> Content -> Exp
    toH Exp
    pack' Exp
    tomsg) [Content]
    ct'
        mapp <- [|mappend|]
        let 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)
        e <-
            case 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
        return (pat, 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, 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)
        return $ Clause
            [WildP, conP (mkName "[]") [], pat]
            (NormalB bod)
            []

    defClause :: Q Clause
    defClause :: Q Clause
    defClause = do
        a <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "sub"
        c <- newName "langs"
        d <- newName "msg"
        rm <- [|renderMessage|]
        return $ Clause
            [VarP a, conP (mkName ":") [WildP, VarP c], VarP d]
            (NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE 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
        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
        return $ SDef (constr d) vars' (content 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
        isFile <- String -> IO Bool
    doesFileExist String
    file'
        if isFile && ".msg" `isSuffixOf` file
            then do
                let 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
                defs <- loadLangFile file'
                return $ Just ([file'], (lang, defs))
            else do
                isDir <- doesDirectoryExist file'
                if isDir
                    then do
                        let lang = String -> Lang
    pack String
    file
                        (files, defs) <- unzip <$> loadLangDir file'
                        return $ Just (files, (lang, concat defs))
                    else
                        return Nothing

    loadLangDir :: FilePath -> IO [(FilePath, [Def])]
    loadLangDir :: String -> IO [(String, [Def])]
    loadLangDir String
    folder = do
        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
        files <- filterM doesFileExist paths
        dirs  <- filterM doesDirectoryExist paths
        langFiles <-
            forM files $ \String
    file -> do
                if String
    ".msg" String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isSuffixOf` String
    file
                    then do
                      defs <- String -> IO [Def]
    loadLangFile String
    file
                      return $ Just (file, 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
        langDirs <- mapM loadLangDir dirs
        return $ catMaybes langFiles ++ concat langDirs

    loadLangFile :: FilePath -> IO [Def]
    loadLangFile :: String -> IO [Def]
    loadLangFile String
    file = do
        bs <- String -> IO ByteString
    S.readFile String
    file
        let s = Lang -> String
    unpack (Lang -> String) -> Lang -> String
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Lang
    decodeUtf8 ByteString
    bs
        defs <- fmap catMaybes $ mapM (parseDef . T.unpack . T.strip . T.pack) $ lines s
        return 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]) -> 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 words 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
            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'
            eof
            return 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 u (m :: * -> *) a. 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