{-# LANGUAGE TemplateHaskell #-}{-# LANGUAGE MultiParamTypeClasses #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE TypeSynonymInstances #-}{-# LANGUAGE ExistentialQuantification #-}{-# LANGUAGE CPP #-}------------------------------------------------------------------------------- |-- 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.moduleText.Shakespeare.I18N(mkMessage,mkMessageFor,mkMessageVariant,RenderMessage(..),ToMessage(..),SomeMessage(..),Lang)whereimportLanguage.Haskell.TH.SyntaximportData.Text(Text,pack,unpack)importSystem.DirectoryimportData.Maybe(catMaybes)importData.List(isSuffixOf,sortBy,foldl')importqualifiedData.ByteStringasSimportData.Text.Encoding(decodeUtf8)importData.Char(isSpace,toLower,toUpper)importData.Ord(comparing)importText.Shakespeare.Base(Deref(..),Ident(..),parseHash,derefToExp)importText.ParserCombinators.Parsec(parse,many,eof,many1,noneOf,(<|>))importControl.Arrow((***))importData.Monoid(mempty,mappend)importqualifiedData.TextasTimportData.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'.classToMessageawheretoMessage::a->TextinstanceToMessageTextwheretoMessage=idinstanceToMessageStringwheretoMessage=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.classRenderMessagemastermessagewhererenderMessage::master-- ^ type that specifies which set of translations to use->[Lang]-- ^ acceptable languages in descending order of preference->message-- ^ message to translate->TextinstanceRenderMessagemasterTextwhererenderMessage__=id-- | an RFC1766 / ISO 639-1 language code (eg, @fr@, @en-GB@, etc).typeLang=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]mkMessagedtfolderlang=mkMessageCommonTrue"Msg""Message"dtdtfolderlang-- | create 'RenderMessage' instance for an existing data-typemkMessageFor::String-- ^ master translation data type->String-- ^ existing type to add translations for->FilePath-- ^ path to translation folder->Lang-- ^ default language->Q[Dec]mkMessageFormasterdtfolderlang=mkMessageCommonFalse""""masterdtfolderlang-- | 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]mkMessageVariantmasterdtfolderlang=mkMessageCommonFalse"Msg""Message"masterdtfolderlang-- |used by 'mkMessage' and 'mkMessageFor' to generate a 'RenderMessage' and possibly a message data typemkMessageCommon::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]mkMessageCommongenTypeprefixpostfixmasterdtfolderlang=dofiles<-qRunIO$getDirectoryContentsfolder(_files',contents)<-qRunIO$fmap(unzip.catMaybes)$mapM(loadLangfolder)files#ifdef GHC_7_4mapM_qAddDependentFile_files'#endifsdef<-caselookuplangcontentsofNothing->error$"Did not find main language file: "++unpacklangJustdef->toSDefsdefmapM_(checkDefsdef)$mapsndcontentsletmname=mkName$dt++postfixc1<-fmapconcat$mapM(toClausesprefixdt)contentsc2<-mapM(sToClauseprefixdt)sdefc3<-defClausereturn$(ifgenTypethen((DataD[]mname[](map(toCondt)sdef)[]):)elseid)[InstanceD[](ConT''RenderMessage`AppT`(ConT$mkNamemaster)`AppT`ConTmname)[FunD(mkName"renderMessage")$c1++c2++[c3]]]toClauses::String->String->(Lang,[Def])->Q[Clause]toClausesprefixdt(lang,defs)=mapMgodefswheregodef=doa<-newName"lang"(pat,bod)<-mkBodydt(prefix++constrdef)(mapfst$varsdef)(contentdef)guard<-fmapNormalG[|$(return$VarEa)==pack$(lift$unpacklang)|]return$Clause[WildP,ConP(mkName":")[VarPa,WildP],pat](GuardedB[(guard,bod)])[]mkBody::String-- ^ datatype->String-- ^ constructor->[String]-- ^ variable names->[Content]->Q(Pat,Exp)mkBodydtcsvsct=dovp<-mapMgovsletpat=RecP(mkNamecs)(map(varNamedt***VarP)vp)letct'=map(fixVarsvp)ctpack'<-[|Data.Text.pack|]tomsg<-[|toMessage|]letct''=map(toHpack'tomsg)ct'mapp<-[|mappend|]letappab=InfixE(Justa)mapp(Justb)e<-casect''of[]->[|mempty|][x]->returnx(x:xs)->return$foldl'appxxsreturn(pat,e)wheretoHpack'_(Raws)=pack'`AppE`SigE(LitE(StringLs))(ConT''String)toH_tomsg(Vard)=tomsg`AppE`derefToExp[]dgox=dolety=mkName$'_':xreturn(x,y)fixVarsvp(Vard)=Var$fixDerefvpdfixVars_(Raws)=RawsfixDerefvp(DerefIdent(Identi))=DerefIdent$Ident$fixIdentvpifixDerefvp(DerefBranchab)=DerefBranch(fixDerefvpa)(fixDerefvpb)fixDeref_d=dfixIdentvpi=caselookupivpofNothing->iJusty->nameBaseysToClause::String->String->SDef->QClausesToClauseprefixdtsdef=do(pat,bod)<-mkBodydt(prefix++sconstrsdef)(mapfst$svarssdef)(scontentsdef)return$Clause[WildP,ConP(mkName"[]")[],pat](NormalBbod)[]defClause::QClausedefClause=doa<-newName"sub"c<-newName"langs"d<-newName"msg"rm<-[|renderMessage|]return$Clause[VarPa,ConP(mkName":")[WildP,VarPc],VarPd](NormalB$rm`AppE`VarEa`AppE`VarEc`AppE`VarEd)[]toCon::String->SDef->ContoCondt(SDefcvs_)=RecC(mkName$"Msg"++c)$mapgovswherego(n,t)=(varNamedtn,NotStrict,ConT$mkNamet)varName::String->String->NamevarNameay=mkName$concat[lowera,"Message",uppery]wherelower(x:xs)=toLowerx:xslower[]=[]upper(x:xs)=toUpperx:xsupper[]=[]checkDef::[SDef]->[Def]->Q()checkDefxy=go(sortBy(comparingsconstr)x)(sortBy(comparingconstr)y)wherego_[]=return()go[](b:_)=error$"Extra message constructor: "++constrbgo(a:as)(b:bs)|sconstra<constrb=goas(b:bs)|sconstra>constrb=error$"Extra message constructor: "++constrb|otherwise=dogo'(svarsa)(varsb)goasbsgo'((an,at):as)((bn,mbt):bs)|an/=bn=error"Mismatched variable names"|otherwise=casembtofNothing->go'asbsJustbt|at==bt->go'asbs|otherwise->error"Mismatched variable types"go'[][]=return()go'__=error"Mistmached variable count"toSDefs::[Def]->Q[SDef]toSDefs=mapMtoSDeftoSDef::Def->QSDeftoSDefd=dovars'<-mapMgo$varsdreturn$SDef(constrd)vars'(contentd)wherego(a,Justb)=return(a,b)go(a,Nothing)=error$"Main language missing type for "++show(constrd,a)dataSDef=SDef{sconstr::String,svars::[(String,String)],scontent::[Content]}dataDef=Def{constr::String,vars::[(String,MaybeString)],content::[Content]}loadLang::FilePath->FilePath->IO(Maybe(FilePath,(Lang,[Def])))loadLangfolderfile=doletfile'=folder++'/':filee<-doesFileExistfile'ife&&".msg"`isSuffixOf`filethendoletlang=pack$reverse$drop4$reversefilebs<-S.readFilefile'lets=unpack$decodeUtf8bsdefs<-fmapcatMaybes$mapMparseDef$linessreturn$Just(file',(lang,defs))elsereturnNothingparseDef::String->IO(MaybeDef)parseDef""=returnNothingparseDef('#':_)=returnNothingparseDefs=caseendof':':end'->docontent'<-fmapcompress$parseContent$dropWhileisSpaceend'casewordsbeginof[]->error$"Missing constructor: "++s(w:ws)->return$JustDef{constr=w,vars=mapparseVarws,content=content'}_->error$"Missing colon: "++swhere(begin,end)=break(==':')sdataContent=VarDeref|RawStringcompress::[Content]->[Content]compress[]=[]compress(Rawa:Rawb:rest)=compress$Raw(a++b):restcompress(x:y)=x:compressyparseContent::String->IO[Content]parseContents=either(error.show)return$parsegosswherego=dox<-manygo'eofreturnxgo'=(Raw`fmap`many1(noneOf"#"))<|>(fmap(eitherRawVar)parseHash)parseVar::String->(String,MaybeString)parseVars=casebreak(=='@')sof(x,'@':y)->(x,Justy)_->(s,Nothing)dataSomeMessagemaster=forallmsg.RenderMessagemastermsg=>SomeMessagemsginstanceIsString(SomeMessagemaster)wherefromString=SomeMessage.T.packinstanceRenderMessagemaster(SomeMessagemaster)whererenderMessageab(SomeMessagemsg)=renderMessageabmsg