diff --git a/GenDB.hs b/GenDB.hs new file mode 100644 --- /dev/null +++ b/GenDB.hs @@ -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 " diff --git a/Language/Lojban/CLL.hs b/Language/Lojban/CLL.hs new file mode 100644 --- /dev/null +++ b/Language/Lojban/CLL.hs @@ -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 diff --git a/Language/Lojban/Jbovlaste.hs b/Language/Lojban/Jbovlaste.hs new file mode 100644 --- /dev/null +++ b/Language/Lojban/Jbovlaste.hs @@ -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 diff --git a/Language/Lojban/Lujvo.hs b/Language/Lojban/Lujvo.hs new file mode 100644 --- /dev/null +++ b/Language/Lojban/Lujvo.hs @@ -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 ((cvc / ccv / cvv) > 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) >= return . (:[]) +(+) p = many1 (try p) +(*) p = many (try p) +(>= unexpected . show) <|> return r) +infixl 2 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) diff --git a/Language/Lojban/Util.hs b/Language/Lojban/Util.hs new file mode 100644 --- /dev/null +++ b/Language/Lojban/Util.hs @@ -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 diff --git a/Lojban/Jbovlaste.hs b/Lojban/Jbovlaste.hs deleted file mode 100644 --- a/Lojban/Jbovlaste.hs +++ /dev/null @@ -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 diff --git a/Lojban/Lujvo.hs b/Lojban/Lujvo.hs deleted file mode 100644 --- a/Lojban/Lujvo.hs +++ /dev/null @@ -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 ((cvc / ccv / cvv) > 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) >= return . (:[]) -(+) p = many1 (try p) -(*) p = many (try p) -(>= unexpected . show) <|> return r) -infixl 2 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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -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 diff --git a/WildCard.hs b/WildCard.hs new file mode 100644 --- /dev/null +++ b/WildCard.hs @@ -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 + +-} diff --git a/lojban.cabal b/lojban.cabal --- a/lojban.cabal +++ b/lojban.cabal @@ -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