From 1950b451575a895b884d8a929c4ccd7e78b3b37e Mon Sep 17 00:00:00 2001 From: towards-a-new-leftypol Date: Fri, 9 Feb 2024 09:19:32 -0500 Subject: [PATCH] Parsing PostBodies seems to work okay - tie in parsing into the threadview update function - that may not be the final place for it but it works for now to just bring out the Show instances. - need a renderer now --- index.html | 2 +- src/Action.hs | 2 ++ src/BodyParser.hs | 24 ++++++++++++++---------- src/Component/ThreadView.hs | 33 +++++++++++++++++++++++++++++---- src/Main.hs | 14 ++++++++++++-- 5 files changed, 58 insertions(+), 17 deletions(-) diff --git a/index.html b/index.html index 2a1701f..4692ffc 100644 --- a/index.html +++ b/index.html @@ -3,7 +3,7 @@ - + Chandlr diff --git a/src/Action.hs b/src/Action.hs index e93c329..e60fc21 100644 --- a/src/Action.hs +++ b/src/Action.hs @@ -12,6 +12,7 @@ import qualified Network.ClientTypes as C import Network.CatalogPostType (CatalogPost) import Network.Http (HttpResult) import Network.SiteType (Site) +import qualified Component.ThreadView as Thread data GetThreadArgs = GetThreadArgs { website :: Text @@ -26,5 +27,6 @@ data Action | HaveLatest (HttpResult [ CatalogPost ]) | HaveThread (HttpResult [ Site ]) | forall a. (FromJSON a) => ClientAction (HttpResult a -> Action) (C.Action a) + | ThreadAction Thread.Action | ChangeURI URI | NoAction diff --git a/src/BodyParser.hs b/src/BodyParser.hs index 6beed32..f5c6b31 100644 --- a/src/BodyParser.hs +++ b/src/BodyParser.hs @@ -22,6 +22,7 @@ import GHCJS.DOM.JSFFI.Generated.Node hiding (contains) import qualified GHCJS.DOM.JSFFI.Generated.NodeList as NodeList import GHCJS.DOM.JSFFI.Generated.DOMTokenList (contains) import Data.Text (Text) +import Miso (consoleLog) data PostPart @@ -40,7 +41,7 @@ data PostPart | Underlined [ PostPart ] | Italics [ PostPart ] | Strikethrough [ PostPart ] - deriving Show + deriving (Show, Eq) nodeListToList :: NodeList -> IO [ Node ] @@ -80,13 +81,16 @@ toPostPart_ node_type node tagName :: JSString <- getTagName element case tagName of - "a" -> parseAnchor element - "span" -> parseSpan element - "em" -> parseEm element - "strong" -> parseStrong element - "u" -> parseU element - "s" -> parseS element - _ -> return $ SimpleText "Unsupported element" + "A" -> parseAnchor element + "SPAN" -> parseSpan element + "EM" -> parseEm element + "STRONG" -> parseStrong element + "U" -> parseU element + "S" -> parseS element + "BR" -> return Skip + _ -> do + consoleLog tagName + return $ SimpleText "Unsupported element" | otherwise = return Skip where @@ -124,10 +128,10 @@ parseSpan element = do | otherwise -> return $ SimpleText "Unsupported span class" -parseNodeList :: NodeList -> IO [PostPart] +parseNodeList :: NodeList -> IO [ PostPart ] parseNodeList nodes = nodeListToList nodes >>= mapM toPostPart -parseChildNodes :: Element -> IO [PostPart] +parseChildNodes :: Element -> IO [ PostPart ] parseChildNodes element = getChildNodes element >>= parseNodeList parseEm :: Element -> IO PostPart diff --git a/src/Component/ThreadView.hs b/src/Component/ThreadView.hs index 76a83cc..ea246be 100644 --- a/src/Component/ThreadView.hs +++ b/src/Component/ThreadView.hs @@ -6,6 +6,7 @@ module Component.ThreadView , Action (..) , update , view +, Interface (..) ) where import Miso @@ -21,9 +22,11 @@ import Miso , h2_ , rawHtml , Attribute + , (<#) + , consoleLog ) -import Data.Maybe (maybeToList) +import Data.Maybe (maybeToList, catMaybes) import Miso.String (toMisoString) import GHCJS.DOM.Types (JSString) @@ -37,21 +40,42 @@ import Component.Thread.Files (files) import Component.Thread.Intro (intro) import BodyParser +type PostWithBody = (Post, [ PostPart ]) + data Model = Model { site :: Site , media_root :: JSString + , post_bodies :: [ PostWithBody ] } deriving Eq initialModel :: JSString -> Site -> Model initialModel mroot s = Model { site = s + , post_bodies = [] , media_root = mroot } -data Action = RenderSite Site +data Action + = RenderSite Site + | UpdatePostBodies [ PostWithBody ] + +data Interface a = Interface { passAction :: Action -> a } + +update :: Interface a -> Action -> Model -> Effect a Model +update iface (RenderSite s) m = m { site = s } <# do + bodies <- mapM parsePostBody (catMaybes $ map Post.body posts) + + mapM_ (consoleLog . toMisoString . show) bodies + + return $ passAction iface $ UpdatePostBodies $ zip posts bodies + + where + posts :: [ Post ] + posts = Thread.posts $ head $ Board.threads $ head $ Site.boards s +--update (RenderSite s) m = noEff (m { site = s }) + +update _ (UpdatePostBodies pwbs) m = noEff m { post_bodies = pwbs } -update :: Action -> Model -> Effect a Model -update (RenderSite s) m = noEff (m { site = s }) view :: Model -> View a view m = @@ -109,6 +133,7 @@ op m op_post = | length (Post.attachments op_post) > 1 = [ class_ "multifile" ] | otherwise = [] + reply :: Model -> Post -> View a reply m post = div_ [ class_ "postcontainer" diff --git a/src/Main.hs b/src/Main.hs index a21e18e..2c555d3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,7 +6,7 @@ module Main where import Data.Proxy -import Data.Maybe (maybe) +import Data.Maybe (maybe, fromJust) import Data.Text (Text) import qualified Data.Text as T import Network.URI (uriPath) @@ -180,7 +180,7 @@ mainUpdate (HaveThread Client.Error) m = m <# do mainUpdate (HaveThread (Client.HttpResponse {..})) m = new_model <# do consoleLog "Have Thread!" - return NoAction + return $ ThreadAction $ Thread.RenderSite $ Thread.site $ fromJust $ thread_model new_model where new_model = m @@ -217,6 +217,13 @@ mainUpdate (ClientAction action ca) m = Client.update (iClient action) ca (client_model m) >>= \cm -> noEff (m { client_model = cm }) +mainUpdate (ThreadAction ta) model = do + tm :: Maybe Thread.Model <- case thread_model model of + Nothing -> noEff Nothing + Just m -> Thread.update iThread ta m >>= return . Just + + noEff model { thread_model = tm } + iGrid :: Grid.Interface Action iGrid = Grid.Interface @@ -238,6 +245,9 @@ iClient action = Client.Interface , Client.returnResult = action } +iThread :: Thread.Interface Action +iThread = Thread.Interface { Thread.passAction = ThreadAction } + {- - TODO: - - Create the thread view