5c6b4cea-5a3d-4f3d-adbf-5c55fe9a6a6b

Committed 04 Jun 2025 05:04PM UTC coverage: 32.165%. First build

Build # 5c6b4cea-5a3d-4f3d-adbf-5c55fe9a6a6b

Build Type

Pull #1566

circleci

Committed by

matt-dahlgren

Commit Message

Another redundant import

Pull Request Pull Request #1566: Refactoring the Graph Methods

Run Details

21 of 140 branches covered (15.0%)

Branch coverage included in aggregate %.

0 of 50 new or added lines in 1 file covered. (0.0%)

640 of 1915 relevant lines covered (33.42%)

26.37 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

0.0

/app/Models/Graph.hs

module Models.Graph
    (getGraph,
    saveGraphJSON) where

import Config (runDb)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (Value, decode, object, toJSON)
import Data.List (partition)
import qualified Data.Text as T (Text)
import Database.DataType (ShapeType (BoolNode, Hybrid, Node))
import Database.Persist.Sqlite (Entity, PersistEntity, PersistValue (PersistInt64), SqlPersistM,
                                entityKey, entityVal, insert, insertMany_, keyToValues, selectFirst,
                                selectList, (<-.), (==.))
import Database.Tables hiding (paths, shapes, texts)
import Happstack.Server (Response, ServerPart, lookBS, lookText', toResponse)
import Svg.Builder (buildEllipses, buildPath, buildRect, intersectsWithShape)

getGraph :: T.Text -> IO (Maybe Value)
getGraph graphName = runDb $ do
    graphEnt :: (Maybe (Entity Graph)) <- selectFirst [GraphTitle ==. graphName] []
    case graphEnt of
        Nothing -> return Nothing
        Just graph -> do
            let gId = entityKey graph
            sqlTexts    :: [Entity Text] <- selectList [TextGraph ==. gId] []
            sqlRects    :: [Entity Shape] <- selectList
                                                 [ShapeType_ <-. [Node, Hybrid],
                                                  ShapeGraph ==. gId] []
            sqlEllipses :: [Entity Shape] <- selectList
                                                 [ShapeType_ ==. BoolNode,
                                                  ShapeGraph ==. gId] []
            sqlPaths    :: [Entity Path] <- selectList [PathGraph ==. gId] []

            let
                keyAsInt :: PersistEntity a => Entity a -> Integer
                keyAsInt = fromIntegral . (\(PersistInt64 x) -> x) . head . keyToValues . entityKey

                graphtexts          = map entityVal sqlTexts
                rects          = zipWith (buildRect graphtexts)
                                         (map entityVal sqlRects)
                                         (map keyAsInt sqlRects)
                ellipses       = zipWith (buildEllipses graphtexts)
                                         (map entityVal sqlEllipses)
                                         (map keyAsInt sqlEllipses)
                graphpaths     = zipWith (buildPath rects ellipses)
                                         (map entityVal sqlPaths)
                                         (map keyAsInt sqlPaths)
                (regions, _)   = partition pathIsRegion graphpaths
                regionTexts    = filter (not .
                                         intersectsWithShape (rects ++ ellipses))
                                        graphtexts

                response = object [
                        ("texts", toJSON $ graphtexts ++ regionTexts),
                        ("shapes", toJSON $ rects ++ ellipses),
                        ("paths", toJSON $ graphpaths ++ regions),
                        ("width", toJSON $ graphWidth $ entityVal graph),
                        ("height", toJSON $ graphHeight $ entityVal graph)
                    ]

            return (Just response)

-- | Inserts SVG graph data into Texts, Shapes, and Paths tables
saveGraphJSON :: ServerPart Response
saveGraphJSON = do
    jsonStr <- lookBS "jsonData"
    nameStr <- lookText' "nameData"
    let jsonObj = decode jsonStr :: Maybe SvgJSON
    case jsonObj of
        Nothing -> return $ toResponse ("Error" :: String)
        Just (SvgJSON texts shapes paths) -> do
            _ <- liftIO $ runDb $ insertGraph nameStr texts shapes paths
            return $ toResponse ("Success" :: String)
    where
        insertGraph :: T.Text -> [Text] -> [Shape] -> [Path] -> SqlPersistM ()
        insertGraph nameStr_ texts shapes paths = do
            gId <- insert $ Graph nameStr_ 256 256 False
            insertMany_ $ map (\text -> text {textGraph = gId}) texts
            insertMany_ $ map (\shape -> shape {shapeGraph = gId}) shapes
            insertMany_ $ map (\path -> path {pathGraph = gId}) paths

1	module Models.Graph
2	(getGraph,
3	saveGraphJSON) where
4
5	import Config (runDb)
6	import Control.Monad.IO.Class (liftIO)
7	import Data.Aeson (Value, decode, object, toJSON)
8	import Data.List (partition)
9	import qualified Data.Text as T (Text)
10	import Database.DataType (ShapeType (BoolNode, Hybrid, Node))
11	import Database.Persist.Sqlite (Entity, PersistEntity, PersistValue (PersistInt64), SqlPersistM,
12	entityKey, entityVal, insert, insertMany_, keyToValues, selectFirst,
13	selectList, (<-.), (==.))
14	import Database.Tables hiding (paths, shapes, texts)
15	import Happstack.Server (Response, ServerPart, lookBS, lookText', toResponse)
16	import Svg.Builder (buildEllipses, buildPath, buildRect, intersectsWithShape)
17
18	getGraph :: T.Text -> IO (Maybe Value)
NEW 19	getGraph graphName = runDb $ do	×
NEW 20	graphEnt :: (Maybe (Entity Graph)) <- selectFirst [GraphTitle ==. graphName] []	×
NEW 21	case graphEnt of	×
NEW 22	Nothing -> return Nothing	×
NEW 23	Just graph -> do	×
NEW 24	let gId = entityKey graph	×
NEW 25	sqlTexts :: [Entity Text] <- selectList [TextGraph ==. gId] []	×
NEW 26	sqlRects :: [Entity Shape] <- selectList	×
NEW 27	[ShapeType_ <-. [Node, Hybrid],	×
NEW 28	ShapeGraph ==. gId] []	×
NEW 29	sqlEllipses :: [Entity Shape] <- selectList	×
NEW 30	[ShapeType_ ==. BoolNode,	×
NEW 31	ShapeGraph ==. gId] []	×
NEW 32	sqlPaths :: [Entity Path] <- selectList [PathGraph ==. gId] []	×
33
34	let
35	keyAsInt :: PersistEntity a => Entity a -> Integer
NEW 36	keyAsInt = fromIntegral . (\(PersistInt64 x) -> x) . head . keyToValues . entityKey	×
37
NEW 38	graphtexts = map entityVal sqlTexts	×
NEW 39	rects = zipWith (buildRect graphtexts)	×
NEW 40	(map entityVal sqlRects)	×
NEW 41	(map keyAsInt sqlRects)	×
NEW 42	ellipses = zipWith (buildEllipses graphtexts)	×
NEW 43	(map entityVal sqlEllipses)	×
NEW 44	(map keyAsInt sqlEllipses)	×
NEW 45	graphpaths = zipWith (buildPath rects ellipses)	×
NEW 46	(map entityVal sqlPaths)	×
NEW 47	(map keyAsInt sqlPaths)	×
NEW 48	(regions, _) = partition pathIsRegion graphpaths	×
NEW 49	regionTexts = filter (not .	×
NEW 50	intersectsWithShape (rects ++ ellipses))	×
NEW 51	graphtexts	×
52
NEW 53	response = object [	×
NEW 54	("texts", toJSON $ graphtexts ++ regionTexts),	×
NEW 55	("shapes", toJSON $ rects ++ ellipses),	×
NEW 56	("paths", toJSON $ graphpaths ++ regions),	×
NEW 57	("width", toJSON $ graphWidth $ entityVal graph),	×
NEW 58	("height", toJSON $ graphHeight $ entityVal graph)	×
59	]
60
NEW 61	return (Just response)	×
62
63	-- \| Inserts SVG graph data into Texts, Shapes, and Paths tables
64	saveGraphJSON :: ServerPart Response
NEW 65	saveGraphJSON = do	×
NEW 66	jsonStr <- lookBS "jsonData"	×
NEW 67	nameStr <- lookText' "nameData"	×
NEW 68	let jsonObj = decode jsonStr :: Maybe SvgJSON	×
NEW 69	case jsonObj of	×
NEW 70	Nothing -> return $ toResponse ("Error" :: String)	×
NEW 71	Just (SvgJSON texts shapes paths) -> do	×
NEW 72	_ <- liftIO $ runDb $ insertGraph nameStr texts shapes paths	×
NEW 73	return $ toResponse ("Success" :: String)	×
74	where
75	insertGraph :: T.Text -> [Text] -> [Shape] -> [Path] -> SqlPersistM ()
NEW 76	insertGraph nameStr_ texts shapes paths = do	×
NEW 77	gId <- insert $ Graph nameStr_ 256 256 False	×
NEW 78	insertMany_ $ map (\text -> text {textGraph = gId}) texts	×
NEW 79	insertMany_ $ map (\shape -> shape {shapeGraph = gId}) shapes	×
NEW 80	insertMany_ $ map (\path -> path {pathGraph = gId}) paths	×

Courseography / courseography / 5c6b4cea-5a3d-4f3d-adbf-5c55fe9a6a6b

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous