lojban 0.0.0 → 0.1
raw patch · 12 files changed
+647/−233 lines, 12 filesdep +HTTPdep +containersdep +curlsetup-changednew-component:exe:jbovlastegendb
Dependencies added: HTTP, containers, curl, haskell98, process, regex-compat, tagsoup
Files
- GenDB.hs +12/−0
- Language/Lojban/CLL.hs +39/−0
- Language/Lojban/Jbovlaste.hs +282/−0
- Language/Lojban/Lujvo.hs +88/−0
- Language/Lojban/Util.hs +121/−0
- Lojban/Jbovlaste.hs +0/−151
- Lojban/Lujvo.hs +0/−76
- Setup.hs +2/−0
- Setup.lhs +0/−3
- Utils.hs +28/−0
- WildCard.hs +66/−0
- lojban.cabal +9/−3
+ GenDB.hs view
@@ -0,0 +1,12 @@+import Language.Lojban.Jbovlaste+import System+import qualified System.IO.Strict as StrictIO++main :: IO ()+main = do+ args <- getArgs+ case args of+ [from,to] -> do db <- genDB from+ writeFile to (show db)+ [] -> StrictIO.interact (show . genDBString)+ _ -> error "expecting <from .xml file> <to filename>"
+ Language/Lojban/CLL.hs view
@@ -0,0 +1,39 @@+module Language.Lojban.CLL+ (cll)+ where++import Control.Arrow+import Data.Char+import Data.List+import Data.Maybe+import Data.Ord+import Network.Curl+import Network.HTTP+import Text.HTML.TagSoup++cll query = do+ (code,body) <- curlGetString url [CurlUserAgent "Mozilla"]+ if code == CurlOK+ then return $ Just $ parse query $ body+ else return $ Nothing+ where url = "http://www.google.com/search?q="+ ++ (urlEncode $ "site:jbotcan.org/cllc " ++ query)++parse t = sortBy (flip $ comparing $ contains t . snd) . catMaybes . map extract . split (==sepTag) . dropWhile (/= sepTag) . parseTags++contains a b = lower a `isInfixOf` lower b++extract (TagOpen "h3" _:TagOpen "a" (("href",url):_):rest) = Just (url,desc) where+ desc = innerText $ takeWhile (/=TagOpen "br" []) rest+extract _ = Nothing++sepTag = TagOpen "li" [("class","g")]++split :: (a -> Bool) -> [a] -> [[a]]+split p xs = reverse $ go p xs [] where+ go p xs acc = case break p xs of+ ([],_:xs) -> go p xs acc+ (x ,_:xs) -> go p xs (x:acc)+ (x,[]) -> x:acc++lower = map toLower
+ Language/Lojban/Jbovlaste.hs view
@@ -0,0 +1,282 @@+module Language.Lojban.Jbovlaste+ (-- * Types+ JboDB+ ,JboValsi+ ,JboValsiType(..)+ -- * Generation of the database+ ,genDB+ ,genDBString+ ,readDB+ -- * Querying the database+ ,findValsi+ ,filterValsi+ ,valsi+ ,defSub+ ,defWildCard+ -- * Accessing parts of valsis+ ,valsiWord+ ,valsiGloss+ ,valsiDef+ ,valsiRafsis+ ,valsiNotes+ ,valsiSelma'o+ ,valsiSelrafsis+ ,valsiType+ -- * Showing valsi+ ,showValsi+ )+ where++import qualified System.IO.Strict as StrictIO+import Text.XML.Light.Input+import Text.XML.Light.Types+import Text.XML.Light.Proc+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Text.Regex+import Data.List+import Data.Ord+import Language.Lojban.Lujvo+import Data.Map (Map)+import Control.Monad+import Data.Function+import WildCard+import Data.Char++-- | Find valsi(s) by word or gloss or rafsi.+valsi :: JboDB -> String -> [JboValsi]+valsi db s = sortBy (comparing valsiType) $ filterValsi db match where+ match e = valsiWord e == s || any (==s) (valsiGloss e)+ || (valsiType e == GismuType && any (==s) (valsiRafsis e))++-- | Find valsi(s) by definition substring.+defSub :: JboDB -> String -> [JboValsi]+defSub db s = filterValsi db match where+ match e = isInfixOf s (valsiDef e) ++-- | Find valsi(s) by definition wild card string.+defWildCard :: JboDB -> String -> [JboValsi]+defWildCard db s = filterValsi db match where+ match e = isNothing $ wildcard s (valsiDef e) ++-- | Filter valsi(s) by a predicate.+filterValsi :: JboDB -> (JboValsi -> Bool) -> [JboValsi]+filterValsi db f = map snd $ filter (f . snd) $ M.assocs $ valsis $ db++-- | Find valsi(s) by a predicate.+findValsi :: JboDB -> (JboValsi -> Bool) -> Maybe JboValsi+findValsi db f = (fmap snd) $ find (f . snd) $ M.assocs $ valsis $ db++-- | Read in a database from file.+readDB :: FilePath -> IO JboDB+readDB f = (JboDB . genMapLujvo . valsis . read) `fmap` readFile f++-- | Generate a database from the Jbovlaste XML export file.+genDB :: FilePath -> IO JboDB+genDB f = genDBString `fmap` StrictIO.readFile f++-- | Generate a database from the Jbovlaste XML export.+genDBString :: String -> JboDB+genDBString = JboDB . genMap' . fromJust . parseXMLDoc++genMap' :: Element -> Map String JboValsi+genMap' xml = foldr update M.empty es where+ es = entries xml+ update e m | qname == name "valsi"+ && any (==type') ["gismu","fu'ivla","cmavo","lujvo","cmavo cluster"]+ = M.insert w (elemToValsi e es m) m+ | otherwise = m+ where qname = elName e+ w = fromJust $ attr "word" e+ type' = fromMaybe "" $ attr "type" e++genMapLujvo :: Map String JboValsi -> Map String JboValsi+genMapLujvo m = foldr resolve m $ M.toList m where+ resolve (w,v) = case valsiType v of+ LujvoType -> let (JboLujvo rs _ e) = v+ ss = catMaybes $ map (flip selrafsi m) rs+ in M.insert w (JboLujvo rs ss e)+ _ -> id++entries :: Element -> [Element]+entries = filterElements correct where+ correct e = qname == name "valsi" || qname == name "nlword"+ where qname = elName e++elemToValsi :: Element -> [Element] -> Map String JboValsi -> JboValsi+elemToValsi e es m | type' == "gismu" = makeGismu e es+ | type' == "fu'ivla" = makeGismu e es+ | type' == "cmavo cluster" = makeCmavo True e es+ | type' == "cmavo" = makeCmavo False e es+ | type' == "lujvo" = makeLujvo e es m+ where type' = fromJust $ attr "type" e+ word = fromJust $ attr "word" e++makeGismu :: Element -> [Element] -> JboValsi+makeGismu e es = JboGismu rafsis (JboEntry word gloss def notes) where+ (rafsis,word,gloss,def,notes) = entryGet e es++makeFu'ivla :: Element -> [Element] -> JboValsi+makeFu'ivla e es = JboFu'ivla (JboEntry word gloss def notes) where+ (_,word,gloss,def,notes) = entryGet e es++makeCmavo :: Bool -> Element -> [Element] -> JboValsi+makeCmavo c e es = JboCmavo c rafsis selma'o (JboEntry word gloss def notes) where+ (rafsis,word,gloss,def,notes) = entryGet e es+ selma'o = subStr e "selmaho"++makeLujvo :: Element -> [Element] -> Map String JboValsi -> JboValsi+makeLujvo e es m = JboLujvo rafsis' [] (JboEntry word gloss def notes) where+ (_,word,gloss,def,notes) = entryGet e es+ rafsis' = rafsis word++selrafsi :: String -> Map String JboValsi -> Maybe JboValsi+selrafsi s = fmap snd . find sel . M.assocs where+ sel (w,v) = case valsiType v of+ GismuType -> isPrefixOf s w || any (==s) rafsis+ CmavoType -> any (==s) rafsis+ _ -> False+ where rafsis = valsiRafsis v++entryGet :: Element -> [Element] -> ([String],String,[String],String,String)+entryGet e es = (rafsis,word,gloss,def,notes) where+ word = fromJust $ attr "word" e+ rafsis = map strContent $ filterElements ((==name "rafsi") . elName) e+ gloss = glosses word es+ def = subStr e "definition"+ notes = subStr e "notes"++subStr e n = format $ fromMaybe "" $ strContent `fmap` findElement (name n) e++glosses w es = map (fromMaybe "" . attr "word") $ sortBy (comparing $ attr "place") $ filter glossForThis es where+ glossForThis e = elName e == name "nlword"+ && attr "valsi" e == Just w++-- Format descriptions, strip whitespace, change LateX parts to+-- simple text, e.g. $x_1$ to x1.+format :: String -> String+format = trim . third . second . first where+ first = flip (subRegex (mkRegex "\\$([a-z]+)_([0-9]+)\\$")) "\\1\\2"+ second = flip (subRegex (mkRegex "\\$([a-z]+)_\\{([0-9]+)\\}\\$")) "\\1\\2"+ third = flip (subRegex (mkRegex "\\$([a-z]+)_([0-9]+)=([a-z]+)_([0-9]+)\\$")) "\\1\\2=\\3\\4"++-- | Get the word of a valsi.+valsiWord :: JboValsi -> String+valsiWord = entry _entryWord++-- | Get the gloss(es) of a valsi.+valsiGloss :: JboValsi -> [String]+valsiGloss = entry _entryGloss++-- | Get the definition of a valsi.+valsiDef :: JboValsi -> String+valsiDef = entry _entryDef++-- | Get the notes of a valsi.+valsiNotes :: JboValsi -> String+valsiNotes = entry _entryNotes++-- | Get the selma'o of a cmavo (Nothing for non-cmavo).+valsiSelma'o :: JboValsi -> Maybe String+valsiSelma'o w = case valsiType w of+ CmavoType -> Just (_cmavoSelma'o w)+ _ -> Nothing++-- | Get the selrafsis of a lujvo (empty list for non-lujvo).+valsiSelrafsis :: JboValsi -> [JboValsi]+valsiSelrafsis w = case valsiType w of+ LujvoType -> _lujvoSelrafsis w+ _ -> []++entry = (. join valsiEntry)++valsiEntry w =+ case valsiType w of+ GismuType -> _gismuEntry+ CmavoType -> _cmavoEntry+ LujvoType -> _lujvoEntry+ Fu'ivlaType -> _fu'ivlaEntry++-- | Get the type of a valsi.+valsiType :: JboValsi -> JboValsiType+valsiType (JboGismu _ _) = GismuType+valsiType (JboCmavo _ _ _ _) = CmavoType+valsiType (JboLujvo _ _ _) = LujvoType+valsiType (JboFu'ivla _ ) = Fu'ivlaType++showType w = case valsiType w of+ CmavoType | _cmavoCluster w -> "cmavo cluster"+ _ -> map toLower . takeWhile (/='T') . show $ valsiType w++data JboDB = JboDB { valsis :: Map String JboValsi } + deriving (Read,Show)++data JboEntry = + JboEntry {+ _entryWord :: String+ , _entryGloss :: [String]+ , _entryDef :: String+ , _entryNotes :: String+ }+ deriving (Read,Show)++data JboValsiType = CmavoType | GismuType | LujvoType | Fu'ivlaType + deriving (Eq,Show,Read,Ord)++-- | An opaque data type on which accessors can be used.+data JboValsi =+ JboGismu { _gismuRafsis :: [String]+ , _gismuEntry :: JboEntry }+ | JboCmavo { _cmavoCluster :: Bool+ , _cmavoRafsis :: [String]+ , _cmavoSelma'o :: String+ , _cmavoEntry :: JboEntry }+ | JboLujvo { _lujvoRafsis :: [String]+ , _lujvoSelrafsis :: [JboValsi]+ , _lujvoEntry :: JboEntry }+ | JboFu'ivla { _fu'ivlaEntry :: JboEntry }+ deriving (Show,Read)++showValsi :: JboValsi -> String+showValsi w = showType w ++ " " ++ braces (valsiWord w)+ ++ selma'o (valsiSelma'o w)+ ++ rafsis (valsiRafsis w) + ++ selrafs (lujvoSelrafsis w) ++ selgloss (lujvoSelrafsis w)+ ++ glosses (valsiGloss w)+ ++ ": " ++ valsiDef w ++ notes (valsiNotes w)+ where rafsis = list "" ((", with rafsi "++) . braces . commas)+ selrafs = list "" ((", selrafsi "++) . braces . commas . map valsiWord)+ selgloss = list "" ((' ':) . parens . commas . map (slashes . valsiGloss))+ selma'o = maybe "" (", of selma'o "++)+ glosses = list "" ((", glossing to "++) . commas . map speech)+ notes = list "" (" Notes: "++)++instance Eq JboValsi where (==) = (==) `on` valsiWord++-- | Get the selrafsis of a lujvo.+lujvoSelrafsis :: JboValsi -> [JboValsi]+lujvoSelrafsis w = case valsiType w of+ LujvoType -> _lujvoSelrafsis w+ _ -> []++-- | Get any rafsis of a valsi.+valsiRafsis :: JboValsi -> [String]+valsiRafsis w = + case valsiType w of+ GismuType -> _gismuRafsis w+ CmavoType -> _cmavoRafsis w+ LujvoType -> _lujvoRafsis w+ _ -> []++-- Utilities++braces s = "{" ++ s ++ "}"+parens s = "(" ++ s ++ ")"+speech s = "\"" ++ s ++ "\""+commas = intercalate ", " . filter (not . null)+slashes = intercalate "/" . filter (not . null)+list nil cons v = if v == [] then nil else cons v+name n = QName n Nothing Nothing+attr = findAttr . name+trim = unwords . words
+ Language/Lojban/Lujvo.hs view
@@ -0,0 +1,88 @@+module Language.Lojban.Lujvo (rafsis,fixClusters) where++import Prelude hiding ((^),(*),(/),(+))+import Text.ParserCombinators.Parsec hiding (notFollowedBy)+import Control.Monad+import Control.Applicative ((<$>))++data Rafsi = ShortRafsi [Char] | Rafsi4Let [Char] | Rafsi5Let [Char]+instance Show Rafsi where+ show (ShortRafsi e) = e+ show (Rafsi4Let e) = e+ show (Rafsi5Let e) = e++fixClusters :: String -> String+fixClusters xs = go xs [] where+ go (x:y:xs) acc | validCluster (x:y:[]) = go (y:xs) (acc++[x])+ | otherwise = go (y:xs) (acc++[x]++"y")+ go [x] acc = go [] (acc++[x])+ go [] acc = acc++validCluster :: [Char] -> Bool+validCluster = either (const False) (const True) . parse cluster ""++cluster = do diphthong / (do consonant / vowel; consonant / vowel)++rafsis :: String -> [String]+rafsis s = + case parse lujvo "" s of+ Right rs -> map show rs+ Left _ -> []++lujvo = ((rafsi5 <!anyChar / rafsi3 / rafsi4)+) <!anyChar+rafsi3 = ShortRafsi <$> ((cvc / ccv / cvv) <!y <!(anyChar >> y))+rafsi4 = Rafsi4Let <$> (ct & (vt & ct / ct & vt) & ct <&anyChar <&!(y?))+rafsi5 = do (Rafsi4Let ls) <- rafsi4; v <- vowel; return $ Rafsi5Let (ls++v)+cvc = ct & vt & ct <&anyChar <&!(y?)+ccv = ct & ct & vt <&!(((r / n) <& consonant)?)+cvv = ct & (diphthong / vt & h & vt) <&!(((r / n) <& consonant)?)+ct = consonant+vt = vowel+syllabic = l / m / n / r+consonant = voiced / unvoiced / syllabic+diphthong = (a & i / a & u / e & i / o & i) <!nucleus <!glide+vowel = (a / e / i / o / u) <!nucleus+a = oneOf' "aA"+e = oneOf' "eE"+i = oneOf' "iI"+o = oneOf' "oO"+u = oneOf' "uU"+y = oneOf' "yY"+affricate = t & c / t & s / d & j / d & z+glide = (i / u) <&nucleus <!glide+nucleus = vowel / diphthong / y <!nucleus+voiced = b / d / g / j / v / z+unvoiced = c / f / k / p / s / t / x+l = oneOf' "lL" <!l+m = oneOf' "mM" <!m <!z+n = oneOf' "nN" <!n <!affricate+r = oneOf' "rR" <!r+b = oneOf' "bB" <!b <!unvoiced+d = oneOf' "dD" <!d <!unvoiced+g = oneOf' "gG" <!g <!unvoiced+v = oneOf' "vV" <!v <!unvoiced+j = oneOf' "jJ" <!j <!z <!unvoiced+z = oneOf' "zZ" <!z <!j <!unvoiced+s = oneOf' "sS" <!s <!c <!voiced+c = oneOf' "cC" <!c <!s <!x <!voiced+x = oneOf' "xX" <!x <!c <!k <!voiced+k = oneOf' "kK" <!k <!x <!voiced+f = oneOf' "fF" <!f <!voiced+p = oneOf' "pP" <!p <!voiced+t = oneOf' "tT" <!t <!voiced+h = oneOf' "'h" <!h <&nucleus++p <&! p1 = do r <- p; p1; return r+infixl 2 <&!+oneOf' p = oneOf p >>= return . (:[])+(+) p = many1 (try p)+(*) p = many (try p)+(<!) a a1 = do r <- a; ((try a1 >>= unexpected . show) <|> return r)+infixl 2 <!+(/) a a1 = (try a <|> a1)+infixl 1 /+(&) a a1 = (do r <- a; r1 <- a1; return $ mplus r r1)+infixl 4 &+(<&) a a1 = do r <- a; lookAhead a1; return r+infixl 2 <&+(?) p = (try p <|> return mzero)
+ Language/Lojban/Util.hs view
@@ -0,0 +1,121 @@+module Language.Lojban.Util + (-- * Query a Jbovlaste database+ lujvoSelrafsis+ ,lujvosSelrafsi+ ,lujvosSelrafsis+ ,lujvosSelrafsis'+ ,findGismu+ ,findCmavo+ ,findSelrafsi+ ,filterSelma'o+ -- * External programs+ ,grammar+ ,translate+ ,wordType+ ,lujvoAndRate+ ,selma'oInfo)+ where++import Utils+import Language.Lojban.Jbovlaste+import Control.Arrow+import Data.Char+import Data.List+import Text.Regex++-- | Return the selrafsis of a lujvo (string).+lujvoSelrafsis :: JboDB -> String -> Maybe [JboValsi]+lujvoSelrafsis db = list Nothing (Just . valsiSelrafsis . head) . valsi db++-- | Returns all lujvos which contain the given selrafsi.+lujvosSelrafsi :: JboDB+ -> String -- ^ selrafsi (either a cmavo or gismu)+ -> [JboValsi] -- ^ lujvos containing said selrafsi+lujvosSelrafsi db w = filterValsi db (any ((==w) . valsiWord) . valsiSelrafsis)++-- | Returns all lujvos which contain any of the given selrafsis.+lujvosSelrafsis :: JboDB+ -> [String] -- ^ selrafsis+ -> [JboValsi] -- ^ lujvos containing any of the selrafsis+lujvosSelrafsis db ws = filterValsi db (any (flip elem ws . valsiWord) . valsiSelrafsis)++-- | Returns all lujvos which contain all of the given selrafsis (in order).+lujvosSelrafsis' :: JboDB+ -> [String] -- ^ selrafsis+ -> [JboValsi] -- ^ lujvos containing all of the selrafsis (in order)+lujvosSelrafsis' db ws = filterValsi db ((==ws) . map valsiWord . valsiSelrafsis)++-- | Find a gismu valsi matching the given word.+findGismu :: JboDB -> String -> Maybe JboValsi+findGismu db w = findValsi db gismu where+ gismu v = valsiType v == GismuType && valsiWord v == w++-- | Find a cmavo valsi matching the given word.+findCmavo :: JboDB -> String -> Maybe JboValsi+findCmavo db w = findValsi db cmavo where+ cmavo v = valsiType v == CmavoType && valsiWord v == w++-- | Find a selrafsi matching the given rafsi.+findSelrafsi :: JboDB -> String -> Maybe JboValsi+findSelrafsi db w = findValsi db selrafsi where+ selrafsi v = (valsiType v == CmavoType || valsiType v == GismuType)+ && (any (==w) (valsiRafsis v)+ ||+ (length w >= 4 &&+ valsiType v == GismuType && w `isPrefixOf` valsiWord v))++-- | Returns all cmavo which belong to the given selma'o.+filterSelma'o :: JboDB -> String -> [JboValsi]+filterSelma'o db s = filterValsi db selma'o where+ selma'o v = valsiType v == CmavoType && fmap format (valsiSelma'o v) == Just (format s)+ where format = filter isLetter . lower++-- | Shows the grammar of a lojban utterance using jbofihe.+grammar :: String -- ^ The lojban utterance+ -> IO (Either String (String,String)) -- ^ A pair of error and success strings.+grammar = run "jbofihe -ie"++-- | Translates a lojban utterance to English using jbofihe.+translate :: String -- ^ The lojban utterance+ -> IO (Either String (String,String)) -- ^ English output+translate = run "jbofihe -x"++-- | Shows the type of a word using vlatai.+wordType :: String -- ^ The lojban word+ -> IO (Either String String) -- ^ Word type+wordType w = do+ r <- run ("vlatai \"" ++ (lojbanic w) ++ "\"") "" + case r of+ Right ("",v) -> return . Right . unwords . words $ v+ Right (e,_) -> return $ Left e+ Left e -> return $ Left e++-- | Tries to construct and rate lujvo from selfrasis, using jvocuhadju.+lujvoAndRate :: [String] -- ^ selrafsis+ -> IO (Either String [(Int,String)]) -- ^ Word type+lujvoAndRate ws = do+ let selrafsis = unwords $ map (("\""++) . (++"\"") . lojbanic) ws+ r <- run ("jvocuhadju " ++ selrafsis ++ "") ""+ case r of+ Right ("",g) -> return $ Right $ map (rating . trim) $ dropWhile (not . any isDigit) $ lines $ g+ Right (e,_) -> return $ Left e+ Left e -> return $ Left e+ where rating = (read *** tail) . break isSpace++-- | Returns information about a selma'o, using mahotic.+selma'oInfo :: String -> IO (Either String String)+selma'oInfo s = do+ r <- run ("mahotci -i \"" ++ upper (lojbanic s) ++ "\"") ""+ case r of+ Right ("",good) -> return $ Right (format good)+ Right (bad,_) -> return $ Left $ "no entry for \"" ++ s ++ "\""+ Left _ -> return $ Left "mahotci pipe error"+ where format = flip (subRegex r1) "\n" . flip (subRegex r) "\\1 \\2"+ r = mkRegex "([^\n])\n([^\n])"+ r1 = mkRegex "\n\n"++lojbanic = filter good where+ good c = isLetter c || c == '\'' || c == ' '++lower = map toLower+upper = map toUpper
− Lojban/Jbovlaste.hs
@@ -1,151 +0,0 @@--- | A module which provides an way to query XML exports of Jbovlaste.--{-# LANGUAGE PatternGuards #-}--module Lojban.Jbovlaste - (-- * Types- JbovlasteDB- ,JbovlasteEntry- ,JbovlasteEntryType(..)- -- * Opening- ,openJbovlaste- -- * Querying- ,valsi- ,selma'o- ,selrafsi- ,selrafsis- ,findByDef- ,filterEntries- -- * Inspection- ,entryWord- ,entryType- ,entryGloss)- where--import Prelude hiding (readFile,elem)-import System.IO.Strict (readFile)-import Text.XML.Light.Input-import Text.XML.Light.Types-import Text.XML.Light.Proc-import Control.Applicative-import Data.Maybe-import Data.List hiding (elem)-import Data.Char-import Data.Function-import Lojban.Lujvo---- | Open an XML export of Jbovlaste for querying (strictly).-openJbovlaste :: FilePath -> IO (Maybe JbovlasteDB)-openJbovlaste path = (JDB path <$>) <$> parseXMLDoc <$> readFile path---- | Find the selrafsis of a lujvo.-selrafsis :: JbovlasteDB -> String -> [String]-selrafsis db = map fromJust . catMaybes . map ((entryWord <$>) . selrafsi db . show) . rafsis---- | Filter entries according to a predicate.-filterEntries :: JbovlasteDB -> (JbovlasteEntry -> Bool) -> [JbovlasteEntry]-filterEntries db f = (entry db <$>) . filterElements (f . entry db) $ elem db---- | Find (maybe) a valsi by rafsi.-selrafsi :: JbovlasteDB -> String -> Maybe JbovlasteEntry-selrafsi db t = entry db <$> filterElement match (elem db) where- match e | any ((==t) . strContent) $ findChildren (name "rafsi") e = True- | length t' >= 4 && isPrefixOf t (fromMaybe "" $ attr "word" e) - && (attr "type" e == Just "gismu" || attr "type" e == Just "cmavo") = True- | otherwise = False- t' = filter (/='\'') t---- | Find valsi(s) by selma'o.-selma'o :: JbovlasteDB -> String -> [JbovlasteEntry]-selma'o db t = entry db <$> filterElements match (elem db) where- match = any ((==lower t) . lower . strContent) . findChildren (name "selmaho")---- | Find a valsi by searching for word or gloss, and--- resolving gloss entries to valsi entries.-valsi :: JbovlasteDB -> String -> [JbovlasteEntry]-valsi db t = entry db <$> (resolve db $ filterElements match (elem db)) where- match e | Just w <- attr "word" e = w == t- | otherwise = False---- | Find valsis according to a predicate applied to the definition.-findByDef :: JbovlasteDB -> (String -> Bool) -> [JbovlasteEntry]-findByDef db t = entry db <$> filterElements match (elem db) where- match = any (t . strContent) . findChildren (name "definition")---- | Inspect an entry for the word.-entryWord :: JbovlasteEntry -> Maybe String-entryWord = attr "word" . entryElem---- | Inspect an entry for the gloss.-entryGloss :: JbovlasteEntry -> Maybe String-entryGloss = _entryGloss---- | What type of word is the entry?-entryType :: JbovlasteEntry -> JbovlasteEntryType-entryType e = case attr "type" $ entryElem e of- Just "cmavo" -> Cmavo- Just "lujvo" -> Lujvo- Just "gismu" -> Gismu- _ -> Other---- Construct an entry.-entry db e = Entry e (gloss db e)---- Find the gloss for a valsi.-gloss :: JbovlasteDB -> Element -> Maybe String-gloss db e = attr "word" =<< filterElement filter (elem db) where- filter e' | elName e' == name "nlword"- , attr "place" e' == Just "1" || attr "place" e' == Nothing- , attr "valsi" e' == attr "word" e = True- | otherwise = False---- Resolve gloss words to their lojban valsi entries.-resolve :: JbovlasteDB -> [Element] -> [Element]-resolve db = map resolve where- resolve e | elName e == name "nlword"- , Just v <- attr "valsi" e = fromMaybe e $ findValsi db v- | otherwise = e---- Find a valsi.-findValsi :: JbovlasteDB -> String -> Maybe Element-findValsi db w = filterElement match $ elem $ db where- match e | elName e == name "valsi"- , Just w' <- attr "word" e = w' == w- | otherwise = False--instance Show JbovlasteDB where- show (JDB path _) = "JbovlasteDB: " ++ path---- | Opaque data type to be operated on.-data JbovlasteDB = JDB { path :: FilePath, elem :: Element }--instance Show JbovlasteEntry where- show (Entry e g) = thetype ++ word ++ selmaho ++ rafsi ++ gloss ++ def ++ notes where- thetype = fromMaybe "" $ attr "type" e- word = maybe "" (\w -> " {" ++ w ++ "}") $ attr "word" e- selmaho = maybe "" selmaho' (strContent <$> findChild (name "selmaho") e)- selmaho' e = ", of selma'o {" ++ e ++ "}"- rafsi = rafsi' $ commas $ map strContent $ findChildren (name "rafsi") e- rafsi' "" = ""- rafsi' rs = " with rafsi {" ++ rs ++ "}"- def = maybe "" (": "++) $ strContent <$> findChild (name "definition") e- notes = maybe "" notes' $ strContent <$> findChild (name "notes") e- notes' n = " (" ++ n ++ ")"- gloss = maybe "" ((", glossing to {"++) . (++"}")) g--instance Eq JbovlasteEntry where- x == y = ((==) `on` entryType) x y && ((==) `on` entryWord) x y---- | Opaque data type for entries.-data JbovlasteEntry = Entry { entryElem :: Element, _entryGloss :: Maybe String }-data JbovlasteEntryType = Gismu | Cmavo | Lujvo | Other deriving (Eq,Show,Ord)---- Utilities--- Make a simple name.-name n = QName n Nothing Nothing--- Find an attribute of a specific name.-attr = findAttr . name--- Just separate a list by commas.-commas = concat . intersperse ", "----lower = map toLower
− Lojban/Lujvo.hs
@@ -1,76 +0,0 @@-module Lojban.Lujvo (rafsis,Rafsi(..)) where--import Prelude hiding ((^),(*),(/),(+))-import Text.ParserCombinators.Parsec hiding (notFollowedBy)-import Control.Monad-import Control.Applicative ((<$>))--data Rafsi = ShortRafsi [Char] | Rafsi4Let [Char] | Rafsi5Let [Char]-instance Show Rafsi where- show (ShortRafsi e) = e- show (Rafsi4Let e) = e- show (Rafsi5Let e) = e--rafsis :: String -> [Rafsi]-rafsis s = - case parse lujvo "" s of- Right rs -> rs- Left _ -> []--lujvo = ((rafsi5 <!anyChar / rafsi3 / rafsi4)+) <!anyChar-rafsi3 = ShortRafsi <$> ((cvc / ccv / cvv) <!y <!(anyChar >> y))-rafsi4 = Rafsi4Let <$> (ct & (vt & ct / ct & vt) & ct <&anyChar <&!(y?))-rafsi5 = do (Rafsi4Let ls) <- rafsi4; v <- vowel; return $ Rafsi5Let (ls++v)-cvc = ct & vt & ct <&anyChar <&!(y?)-ccv = ct & ct & vt <&!(((r / n) <& consonant)?)-cvv = ct & (diphthong / vt & h & vt) <&!(((r / n) <& consonant)?)-ct = consonant-vt = vowel-syllabic = l / m / n / r-consonant = voiced / unvoiced / syllabic-diphthong = (a & i / a & u / e & i / o & i) <!nucleus <!glide-vowel = (a / e / i / o / u) <!nucleus-a = oneOf' "aA"-e = oneOf' "eE"-i = oneOf' "iI"-o = oneOf' "oO"-u = oneOf' "uU"-y = oneOf' "yY"-affricate = t & c / t & s / d & j / d & z-glide = (i / u) <&nucleus <!glide-nucleus = vowel / diphthong / y <!nucleus-voiced = b / d / g / j / v / z-unvoiced = c / f / k / p / s / t / x-l = oneOf' "lL" <!l-m = oneOf' "mM" <!m <!z-n = oneOf' "nN" <!n <!affricate-r = oneOf' "rR" <!r-b = oneOf' "bB" <!b <!unvoiced-d = oneOf' "dD" <!d <!unvoiced-g = oneOf' "gG" <!g <!unvoiced-v = oneOf' "vV" <!v <!unvoiced-j = oneOf' "jJ" <!j <!z <!unvoiced-z = oneOf' "zZ" <!z <!j <!unvoiced-s = oneOf' "sS" <!s <!c <!voiced-c = oneOf' "cC" <!c <!s <!x <!voiced-x = oneOf' "xX" <!x <!c <!k <!voiced-k = oneOf' "kK" <!k <!x <!voiced-f = oneOf' "fF" <!f <!voiced-p = oneOf' "pP" <!p <!voiced-t = oneOf' "tT" <!t <!voiced-h = oneOf' "'h" <!h <&nucleus--p <&! p1 = do r <- p; p1; return r-infixl 2 <&!-oneOf' p = oneOf p >>= return . (:[])-(+) p = many1 (try p)-(*) p = many (try p)-(<!) a a1 = do r <- a; ((try a1 >>= unexpected . show) <|> return r)-infixl 2 <!-(/) a a1 = (try a <|> a1)-infixl 1 /-(&) a a1 = (do r <- a; r1 <- a1; return $ mplus r r1)-infixl 4 &-(<&) a a1 = do r <- a; lookAhead a1; return r-infixl 2 <&-(?) p = (try p <|> return mzero)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
+ Utils.hs view
@@ -0,0 +1,28 @@+module Utils+ (list+ ,run+ ,trim)+ where++import System.Process+import System.IO+import System.Exit+import qualified System.IO.Strict as StrictIO++list :: Eq a => b -> ([a] -> b) -> [a] -> b+list nil cons v = if v == [] then nil else cons v++run :: String -> String -> IO (Either String (String,String))+run cmd input = do+ Right (inp,out,err,pid) <- catch (Right `fmap` runInteractiveCommand cmd)+ (const $ return $ Left "Broken pipe")+ catch (do hPutStr inp input; hClose inp+ output <- StrictIO.hGetContents out+ errput <- StrictIO.hGetContents err+ e <- catch (waitForProcess pid)+ (const $ return ExitSuccess)+ return $ Right (errput,output))+ (const $ return $ Left "Broken pipe")++trim :: String -> String+trim = unwords . words
+ WildCard.hs view
@@ -0,0 +1,66 @@+module WildCard (wildcard) where++import Data.List++wildcard :: String -> String -> Maybe Error+wildcard consumer input = go False input $ split '*' consumer where+ -- End of input+ go wildc "" cons | null cons = Nothing+ | wildc && all (=="*") cons = Nothing+ | otherwise = unexpected ""+ -- End of consumers+ go True input [] = Nothing+ go False input [] = unexpected input+ -- Set wild card to `on'+ go wildc input ("*":xs) = go True input xs+ -- Try to consume immediately+ go False input (x :xs) = case consume x input of+ Just new -> go False new xs+ Nothing -> unexpected input+ -- Wildcard is on; try to consume until the end of the string+ go True input (x :xs) = case walkConsume x input of+ Just new -> go False new xs+ Nothing -> unexpected input++unexpected e = Just $ "unexpected \"" ++ e ++ "\""++split :: Char -> String -> [String]+split c = filter (/="") . go where+ go [] = []+ go xs = let (ys,xs') = break (==c) xs+ in ys : take 1 xs' : go (drop 1 xs')++consume :: String -> String -> Maybe String+consume cons inp | isPrefixOf cons inp = Just $ drop (length cons) inp+ | otherwise = Nothing++walkConsume :: String -> String -> Maybe String+walkConsume cons = fmap (drop (length cons)) . findLast (isPrefixOf cons) . tails++findLast :: (a -> Bool) -> [a] -> Maybe a+findLast p = foldl try Nothing where+ try last x | p x = Just x+ | otherwise = last++type Error = String++{-++*WildCard> wildcard "hello" ""+Just "unexpected \"\""+*WildCard> wildcard "hello" "hello"+Nothing+*WildCard> wildcard "hello" "hello dave"+Just "unexpected \" dave\""+*WildCard> wildcard "hello*" "hello dave"+Nothing+*WildCard> wildcard "hello*" "oh, hello dave"+Just "unexpected \"oh, hello dave\""+*WildCard> wildcard "*hello*" "oh, hello dave"+Nothing+*WildCard> wildcard "*hello*" "oh, hel!!lo dave"+Just "unexpected \"oh, hel!!lo dave\""+*WildCard> wildcard "*hel*lo*" "oh, hel!!lo dave"+Nothing++-}
lojban.cabal view
@@ -1,5 +1,5 @@ name: lojban-version: 0.0.0+version: 0.1 synopsis: Useful utilities for the Lojban language description: Some utilities such as querying Jbovlaste XML exports for gismu, gloss, rafsi, etc. and @@ -14,6 +14,12 @@ build-type: Simple library- build-depends: base,xml,strict,parsec- exposed-modules: Lojban.Jbovlaste,Lojban.Lujvo+ build-depends: base,xml,strict,parsec,process,regex-compat,containers,tagsoup,HTTP,curl+ exposed-modules: Language.Lojban.Jbovlaste,Language.Lojban.Lujvo,Language.Lojban.Util,Language.Lojban.CLL+ other-modules: WildCard, Utils+ ghc-options: -O2++executable jbovlastegendb+ build-depends: haskell98+ main-is: GenDB.hs ghc-options: -O2