{-# LANGUAGE LambdaCase, OverloadedStrings, ExtendedDefaultRules, TupleSections #-} module LexiconEditor ( LexRow(..), createEditableLexicon, segsFromFt ) where import Graphics.UI.Gtk import Control.FRPNow hiding (swap, when) import Control.FRPNow.GTK import Control.Monad import Control.Exception import Data.Foldable import Data.Tuple import Data.Tuple.Select import Data.Maybe import Text.PhonotacticLearner.PhonotacticConstraints import Text.PhonotacticLearner.PhonotacticConstraints.FileFormats import Text.PhonotacticLearner import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T import qualified Data.ByteString as B import qualified Data.Map.Lazy as M import qualified Data.Set as S import Control.DeepSeq import Text.Read (readMaybe) default(T.Text) data LexSourceType = FieroList | FieroText data LexSource = Custom | FromStored LexSourceType T.Text segsFromFt :: FeatureTable String -> S.Set String segsFromFt = M.keysSet . segLookup setLexContents :: TreeView -> S.Set String -> [LexRow] -> IO (ListStore LexRow) setLexContents editor segs initlist = do model <- listStoreNew initlist oldcols <- treeViewGetColumns editor forM_ oldcols $ \col -> treeViewRemoveColumn editor col treeViewSetModel editor model wcol <- treeViewColumnNew set wcol [treeViewColumnTitle := "Word", treeViewColumnExpand := True] wcell <- cellRendererTextNew set wcell [cellTextEditable := True] cellLayoutPackStart wcol wcell True treeViewAppendColumn editor wcol cellLayoutSetAttributes wcol wcell model $ \(LexRow w _) -> [cellText := joinFiero segs w] on wcell edited $ \[i] rawword -> do let newword = segmentFiero segs rawword LexRow w f <- listStoreGetValue model i when (w /= newword) $ listStoreSetValue model i (LexRow newword f) adj <- adjustmentNew 1 1 10000 1 10 0 fcol <- treeViewColumnNew set fcol [treeViewColumnTitle := "Frequency"] fcell <- cellRendererSpinNew set fcell [cellTextEditable := True, cellRendererSpinAdjustment := adj] cellLayoutPackStart fcol fcell True treeViewAppendColumn editor fcol cellLayoutSetAttributes fcol fcell model $ \(LexRow _ f) -> [cellText := show f] on fcell edited $ \[i] newval -> do LexRow w f <- listStoreGetValue model i case readMaybe newval of Just newfreq | (f /= newfreq) -> listStoreSetValue model i (LexRow w newfreq) _ -> return () return model watchLexModel :: LexSource -> S.Set String -> ListStore LexRow -> Now (Behavior (LexSource, S.Set String, [LexRow])) watchLexModel src segs model = do (lexChanged, changeLex) <- callbackStream initlist <- sync $ listStoreToList model let changecb = listStoreToList model >>= changeLex sync $ do on model rowChanged $ \_ _ -> changecb on model rowInserted $ \_ _ -> changecb on model rowDeleted $ \_ -> changecb sample $ fromChanges (src, segs, initlist) (fmap (Custom, segs, ) lexChanged) createEditableLexicon :: Maybe Window -> Behavior (S.Set String) -> EvStream [LexRow] -> Now (VBox, Behavior [LexRow]) createEditableLexicon transwin currentsegs extreplace = do vb <- sync $ vBoxNew False 2 editor <- sync treeViewNew (addButton,addPressed) <- createButton (Just "list-add") Nothing (delButton,delPressed) <- createButton (Just "list-remove") Nothing (loadListButton, loadListPressed) <- createButton (Just "document-open") (Just "Load Lexicon") (loadTextButton, loadTextPressed) <- createButton (Just "document-open") (Just "Collate Text") (saveButton, savePressed) <- createButton (Just "document-save") (Just "Save Lexicon") vb <- createVBox 2 $ do bstretch =<< createFrame ShadowIn =<< createScrolledWindow editor bpack <=< createHBox 2 $ do bpack addButton bpack delButton bspacer bpack loadListButton bpack loadTextButton bpack saveButton let segsChanged = toChanges currentsegs (modelChanged, changeModel) <- callbackStream (dLexChanged, changeDLex) <- callbackStream initsegs <- sample $ currentsegs initmodel <- sync $ setLexContents editor initsegs [] initDLex <- watchLexModel Custom initsegs initmodel currentModel <- sample $ fromChanges initmodel modelChanged currentLex <- sample $ foldrSwitch initDLex dLexChanged flip callStream addPressed $ \_ -> do (store) <- sample currentModel let newRow = LexRow [] 1 sync $ listStoreAppend store newRow return () flip callStream delPressed $ \_ -> do (store) <- sample currentModel (cur, _) <- sync $ treeViewGetCursor editor sync $ case cur of [i] -> listStoreRemove store i _ -> return () txtfilter <- sync fileFilterNew allfilter <- sync fileFilterNew sync $ do fileFilterAddMimeType txtfilter "text/*" fileFilterSetName txtfilter "Text Files" fileFilterAddPattern allfilter "*" fileFilterSetName allfilter "All Files" saveDialog <- sync $ fileChooserDialogNew (Just "Save Lexicon") transwin FileChooserActionSave [("gtk-cancel", ResponseCancel), ("gtk-save", ResponseAccept)] sync $ fileChooserAddFilter saveDialog txtfilter sync $ fileChooserAddFilter saveDialog allfilter flip callStream savePressed $ \_ -> do (_,segs,rows) <- sample currentLex savePicked <- runFileChooserDialog saveDialog planNow . ffor savePicked $ \case Nothing -> return () Just fn -> do async $ do let out = serWordlist segs rows binout = T.encodeUtf8 out B.writeFile fn binout putStrLn $ "Wrote Feature Table " ++ fn return () return () loadListDialog <- sync $ fileChooserDialogNew (Just "Load Lexicon") transwin FileChooserActionOpen [("gtk-cancel", ResponseCancel), ("gtk-open", ResponseAccept)] sync $ fileChooserAddFilter loadListDialog txtfilter sync $ fileChooserAddFilter loadListDialog allfilter flip callStream loadListPressed $ \_ -> do filePicked <- runFileChooserDialog loadListDialog loaded <- planNow . ffor filePicked $ \case Nothing -> return never Just fn -> async $ do rawfile <- fmap (T.decodeUtf8With T.lenientDecode) (B.readFile fn) evaluate rawfile return (fn,rawfile) planNow . ffor (join loaded) $ \(fn,rawfile) -> do segs <- sample currentsegs let initrows = parseWordlist segs rawfile src = FromStored FieroList rawfile newmodel <- sync $ setLexContents editor segs initrows newDLex <- watchLexModel src segs newmodel sync $ do changeModel newmodel changeDLex newDLex putStrLn "Lexicon sucessfully loaded." return () loadTextDialog <- sync $ fileChooserDialogNew (Just "Load Text For New Lexicon") transwin FileChooserActionOpen [("gtk-cancel", ResponseCancel), ("gtk-open", ResponseAccept)] sync $ fileChooserAddFilter loadTextDialog allfilter sync $ fileChooserAddFilter loadTextDialog txtfilter flip callStream loadTextPressed $ \_ -> do filePicked <- runFileChooserDialog loadTextDialog loaded <- planNow . ffor filePicked $ \case Nothing -> return never Just fn -> async $ do rawfile <- fmap (T.decodeUtf8With T.lenientDecode) (B.readFile fn) evaluate rawfile return (fn,rawfile) planNow . ffor (join loaded) $ \(fn,rawfile) -> do segs <- sample currentsegs let initrows = collateWordlist segs rawfile src = FromStored FieroText rawfile newmodel <- sync $ setLexContents editor segs initrows newDLex <- watchLexModel src segs newmodel sync $ do changeModel newmodel changeDLex newDLex putStrLn "Lexicon sucessfully created." return () flip callStream segsChanged $ \newsegs' -> do let newsegs = last newsegs' (src, oldsegs, oldrows) <- sample currentLex let newrows = case src of Custom -> let raw = serWordlist oldsegs oldrows in parseWordlist newsegs raw FromStored FieroList raw -> parseWordlist newsegs raw FromStored FieroText raw -> collateWordlist newsegs raw newmodel <- sync $ setLexContents editor newsegs newrows newDLex <- watchLexModel src newsegs newmodel sync $ do changeModel newmodel changeDLex newDLex putStrLn "Lexicon resegmented." flip callStream extreplace $ \newrows' -> do let newrows = last newrows' segs <- sample currentsegs newmodel <- sync $ setLexContents editor segs newrows newDLex <- watchLexModel Custom segs newmodel sync $ do changeModel newmodel changeDLex newDLex return (vb, fmap sel3 currentLex)