{-# LANGUAGE LambdaCase, OverloadedStrings, ExtendedDefaultRules, TupleSections, ScopedTypeVariables #-}
module GrammarEditor where
import Graphics.UI.Gtk
import Control.FRPNow hiding (swap, when)
import Control.FRPNow.GTK
import Control.Monad
import Control.Monad.IO.Class
import Control.Exception
import Data.Foldable
import Data.Maybe
import Text.PhonotacticLearner.PhonotacticConstraints
import Text.PhonotacticLearner.PhonotacticConstraints.FileFormats
import Text.PhonotacticLearner.MaxentGrammar
import Text.PhonotacticLearner.Util.Ring
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.Map.Lazy as M
import qualified Data.ByteString as B
import qualified Data.Set as S
import Data.Array.IArray
import Control.DeepSeq
import Text.Read (readMaybe)
import Data.IORef
import Numeric
import qualified Graphics.Rendering.Cairo as C
import Graphics.Rendering.Chart.Easy hiding (indices, set')
import Graphics.Rendering.Chart.Renderable
import Graphics.Rendering.Chart.Geometry
import Graphics.Rendering.Chart.Drawing
import Graphics.Rendering.Chart.Backend.Cairo
import Graphics.Rendering.Chart.State(EC, execEC)
default (T.Text)
createChartWidget :: (Eq a, ToRenderable c) => Behavior a -> (a -> c) -> Now DrawingArea
createChartWidget datafeed chartmaker = do
box <- sync $ drawingAreaNew
initdata <- sample datafeed
chartref <- sync $ newIORef (chartmaker initdata)
let doDraw :: C.Render ()
doDraw = do
w <- fromIntegral <$> liftIO (widgetGetAllocatedWidth box)
h <- fromIntegral <$> liftIO (widgetGetAllocatedHeight box)
chart <- liftIO $ readIORef chartref
void $ runBackend (defaultEnv bitmapAlignmentFns) (render (toRenderable chart) (w,h))
sync $ on box draw doDraw
callIOStream (\dat -> writeIORef chartref (chartmaker dat) >> widgetQueueDraw box) (toChanges datafeed)
return box
createLoadableGrammar :: Maybe Window -> Behavior (S.Set T.Text) -> EvStream PhonoGrammar -> Now (VBox, Behavior (Maybe PhonoGrammar))
createLoadableGrammar transwin validsegs extreplace = do
(grammarLoaded, loadReplace) <- callbackStream
let grammarChanged = merge grammarLoaded (fmap Just extreplace)
currentGrammar <- sample $ fromChanges Nothing grammarChanged
let lenData = fmap (fmap lengthDist) currentGrammar
lenChart mdat = layout where
layout = def & layout_x_axis . laxis_title .~ "Word Length (Segments)"
& layout_y_axis . laxis_title .~ "Frequency"
& layout_x_axis . laxis_override .~ axisGridHide
& layout_left_axis_visibility .~ AxisVisibility True False False
& layout_y_axis . laxis_override .~ (\ad -> ad{_axis_grid = [], _axis_ticks = [], _axis_labels = []})
& layout_legend .~ Nothing
& layout_plots .~ fmap plotBars mbars
mbars = case mdat of
Nothing -> []
Just arr -> let
total :: Double = fromIntegral (sum arr)
bardata = fmap (\(x,y) -> (x, [fromIntegral y / total])) (assocs arr)
barplot = def & plot_bars_titles .~ [""]
& plot_bars_values .~ bardata
& plot_bars_spacing .~ BarsFixGap 0 5
in [barplot]
let rulelist (PhonoGrammar _ cs ws) = reverse (zip cs (coords ws))
rulefeed = fmap (maybe [] rulelist) currentGrammar
gvalid = do
segs <- validsegs
let allValid (ClassGlob _ _ gp) = all (\(_,NClass _ fs) -> all (\(_,f) -> S.member f segs) fs) gp
cg <- currentGrammar
return $ fmap (\(PhonoGrammar _ g _) -> all allValid g) cg
validdesc = ffor gvalid $ \case
Just True -> ""
Just False -> "Invalid Features Detected, will ignore"
Nothing -> "No Grammar Loaded"
lenchartdisplay <- createChartWidget lenData lenChart
validlabel <- createLabelDisplay validdesc
(ruledisplay,_) <- createListDisplay rulefeed $ do
tvColumn "Weight" $ tvTextDisplay (\(_,w) -> T.pack (showFFloat (Just 2) w []))
tvColumn "Constraint" $ tvShowDisplay fst
(loadButton, loadPressed) <- createButton (Just "document-open") (Just "Load Grammar")
(saveButton, savePressed) <- createButton (Just "document-save") (Just "Save Grammar")
setAttr widgetSensitive saveButton (fmap isJust currentGrammar)
vb <- createVBox 2 $ do
bpack =<< createFrame ShadowIn =<< set' [widgetHeightRequest := 125] lenchartdisplay
bstretch =<< createFrame ShadowIn =<< createScrolledWindow ruledisplay
bpack <=< createHBox 2 $ do
bstretch =<< set' [widgetWidthRequest := 125, widgetMarginRight := 10] validlabel
bpack loadButton
bpack saveButton
txtfilter <- sync fileFilterNew
allfilter <- sync fileFilterNew
sync $ do
fileFilterAddMimeType txtfilter "text/*"
fileFilterSetName txtfilter "Text Files"
fileFilterAddPattern allfilter "*"
fileFilterSetName allfilter "All Files"
loadDialog <- sync $ fileChooserDialogNew (Just "Load Grammar") transwin FileChooserActionOpen
[("gtk-cancel", ResponseCancel), ("gtk-open", ResponseAccept)]
sync $ fileChooserAddFilter loadDialog txtfilter
sync $ fileChooserAddFilter loadDialog allfilter
flip callStream loadPressed $ \_ -> do
filePicked <- runFileChooserDialog loadDialog
planNow . ffor filePicked $ \case
Nothing -> return never
Just fn -> async $ do
rawfile <- fmap (T.decodeUtf8With T.lenientDecode) (B.readFile fn)
mg <- evaluate . force $ parseGrammar rawfile
loadReplace mg
putStrLn $ case mg of
Just _ -> "Grammar loaded: " ++ fn
Nothing -> "Invalid Grammar: " ++ fn
return ()
saveDialog <- sync $ fileChooserDialogNew (Just "Save Grammar") transwin FileChooserActionSave
[("gtk-cancel", ResponseCancel), ("gtk-save", ResponseAccept)]
sync $ fileChooserAddFilter saveDialog txtfilter
sync $ fileChooserAddFilter saveDialog allfilter
flip callStream savePressed $ \_ -> do
mg <- sample currentGrammar
case mg of
Just g -> do
savePicked <- runFileChooserDialog saveDialog
planNow . ffor savePicked $ \case
Nothing -> return ()
Just fn -> do
async $ do
let out = serGrammar g
binout = T.encodeUtf8 out
B.writeFile fn binout
putStrLn $ "Wrote Grammar " ++ fn
return ()
return ()
Nothing -> return ()
return (vb, currentGrammar)