{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
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))
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
class RenderMessage master message where
renderMessage :: master
-> [Lang]
-> message
-> Text
instance RenderMessage master Text where
renderMessage :: master -> [Lang] -> Lang -> Lang
renderMessage master
_ [Lang]
_ = Lang -> Lang
forall a. a -> a
id
type Lang = Text
mkMessage :: String
-> FilePath
-> Lang
-> 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
mkMessageFor :: String
-> String
-> FilePath
-> Lang
-> 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
mkMessageVariant :: String
-> String
-> FilePath
-> Lang
-> 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
mkMessageCommon :: Bool
-> String
-> String
-> String
-> String
-> FilePath
-> 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
-> String
-> [String]
-> [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