be4e284 · denis · git.iko.soy

denis/src/Data/Completions.hsnew file+42

compare with master

unifiedsplit

@@ -0,0 +1,42 @@

1+{-# LANGUAGE

2+ TupleSections,

3+ DeriveGeneric,

4+ FlexibleInstances #-}

5+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

6+

7+module Data.Completions (

8+ CompletionTree(..),

9+ mkCompletionTree

10+ ) where

11+

12+import qualified Data.Map as M

13+import Data.Aeson

14+import Data.List

15+import Data.Function

16+import Data.Either

17+import Data.Bifunctor

18+import Data.Maybe

19+import GHC.Generics

20+import Servant.Docs

21+

22+instance ToSample (CompletionTree Char) where

23+ toSamples _ = singleSample . mkCompletionTree $

24+ ["aa", "aaab", "ba", "b", "bab"]

25+

26+data CompletionTree a = CompletionTreeNode {

27+ value :: Maybe [a],

28+ subtree :: M.Map a (CompletionTree a)

29+ } deriving (Show, Generic)

30+

31+instance ToJSON (CompletionTree Char) where

32+

33+mkCompletionTree :: (Ord a) => [[a]] -> CompletionTree a

34+mkCompletionTree = mkCompletionTree' . map (\ a -> (a, a)) . sort

35+ where

36+ mkCompletionTree' :: (Ord a) => [([a], [a])] -> CompletionTree a

37+ mkCompletionTree' = uncurry CompletionTreeNode . bimap listToMaybe (M.map mkCompletionTree' . M.fromList) .

38+ second (map (\ u@((k,_):_) -> (k, map snd u)) . groupBy ((==) `on` fst)) . partitionEithers . map processGroup

39+ where

40+ processGroup :: ([a], [a]) -> Either [a] (a, ([a], [a]))

41+ processGroup ([], b) = Left b

42+ processGroup ((k:rest), aa) = Right (k, (rest, aa))

denis/src/Data/Connection.hs+2−2

@@ -33,7 +33,7 @@ type StaticPQ = PoolPQ Schema Handler

33

34

35runQ :: ServantErr -> StaticPQ a -> App a

36−runQ err req = handleSqueal (const $ throwError err) $ asks getPool >>= lift . runPoolPQ req

36+runQ err req = handleSqueal ((>> throwError err) . liftIO . print) $ asks getPool >>= lift . runPoolPQ req

37

38runQ' :: DBConnection -> ServantErr -> StaticPQ a -> Handler a

39runQ' conn err req = handleSqueal (const $ throwError err) $ runPoolPQ req conn

@@ -53,6 +53,6 @@ maybeInvalidToken :: App (Maybe a) -> App a

53maybeInvalidToken = (>>= (\t -> case t of

54 Just y -> return y

55 Nothing -> throwError invalidToken))

56−

56+

57commitedTransactionallyUpdate :: (MonadBaseControl IO tx, MonadPQ schema tx) => tx x -> tx x

58commitedTransactionallyUpdate = transactionally $ TransactionMode ReadCommitted ReadWrite NotDeferrable

denis/src/Data/Query.hs+7−1

@@ -30,7 +30,8 @@ module Data.Query (

30 deleteNamedChannel,

31 HasUsers(..),

32 wrapIntoUsers,

33− ResponseWithUsers(..)

33+ ResponseWithUsers(..),

34+ getTags

34) where

35) where

35

36

36import Squeal.PostgreSQL

37import Squeal.PostgreSQL

@@ -226,6 +227,9 @@ getChannelPostsQ lim uIds tags = selectStar $ from (subquery $ postsQ' `As` #bar

226 Nothing -> id

227 Nothing -> id

227 postsQ' = unionWithUsers $ getPostQ id $ where_ $ jsonbLit tags .?| #postRowTags

228 postsQ' = unionWithUsers $ getPostQ id $ where_ $ jsonbLit tags .?| #postRowTags

228

229

230+getTagsQ :: Query Schema '[] (RowPG (Only String))

231+getTagsQ = selectDistinct (unsafeFunction "unnest" #postRowTags `as` #fromOnly) $

232+ from (table #posts)

229

233

230-- MARK: FrontEnd Data Structures

234-- MARK: FrontEnd Data Structures

231

235

@@ -347,6 +351,8 @@ deleteNamedChannel uId cId = commitedTransactionallyUpdate $ do

347 _ <- manipulateParams deleteNamedChannelQ (Only cId)

351 _ <- manipulateParams deleteNamedChannelQ (Only cId)

348 return ()

352 return ()

349

353

354+getTags :: StaticPQ [String]

355+getTags = map fromOnly <$> (runQuery getTagsQ >>= getRows)

350

356

351-- MARK: Utils

357-- MARK: Utils

352

358

denis/src/Server/API.hs+5−2

@@ -27,6 +27,7 @@ import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))

27import Server.API.Channels

28import Control.Lens

29import Server.Query.ComplexQuery

30+import Server.API.Completions

30

31

31-- MARK: Documentation

32-- MARK: Documentation

32

33

@@ -48,7 +49,8 @@ type API =

48 "users" :> "all" :> Post '[JSON] [User] :<|>

49 "users" :> "all" :> Post '[JSON] [User] :<|>

49 "posts" :> PostApi :<|>

50 "posts" :> PostApi :<|>

50 "channels" :> ChannelsApi

51 "channels" :> ChannelsApi

51− )

52+ ) :<|>

53+ CompletionsAPI

52

54

53serverProxy :: Proxy API

55serverProxy :: Proxy API

54serverProxy = Proxy

56serverProxy = Proxy

@@ -62,4 +64,5 @@ mkServerAPI l =

62 runQnotFound getAllUsers :<|>

64 runQnotFound getAllUsers :<|>

63 postApi uId :<|>

65 postApi uId :<|>

64 channelsApi uId

66 channelsApi uId

65− )

67+ ) :<|>

68+ completionServer

denis/src/Server/API/Completions.hsnew file+66

@@ -0,0 +1,66 @@

1+{-# LANGUAGE

2+ DataKinds ,

3+ DeriveGeneric ,

4+ OverloadedLabels,

5+ OverloadedStrings ,

6+ TypeApplications ,

7+ TypeOperators #-}

8+

9+module Server.API.Completions (

10+ CompletionsAPI,

11+ completionServer

12+ ) where

13+

14+import Servant.Server

15+import Servant

16+import Data.Completions

17+import Server.App

18+import Data.Connection

19+import Data.Query

20+

21+type CompletionsDescription = Description "\

22+ \Gets tag completion tree\n\n\

23+ \```haskell\n\

24+ \data CompletionTree = CompletionTreeNode {\n\

25+ \ value :: Maybe String,\n\

26+ \ subtree :: Map Char CompletionTree\n\

27+ \}\n\

28+ \```\n\n\

29+ \The psuedocode for retrieving all completions from the tree:\n\n\

30+ \```swift\n\

31+ \func getCompletion(tree: CompletionTree, word: String) -> [String] {\n\

32+ \ if word == \"\" {\n\

33+ \ return getValues(tree: tree)\n\

34+ \ }\n\

35+ \\n\

36+ \ let character = word.first\n\

37+ \\n\

38+ \ if tree.subtree[character] == null {\n\

39+ \ return []\n\

40+ \ } else {\n\

41+ \ return getCompletion(tree: tree.subtree[character], word.withoutFirst)\n\

42+ \ }\n\

43+ \}\n\

44+ \\n\

45+ \func getValues(tree: CompletionTree) -> [String] {\n\

46+ \ var out = []\n\

47+ \\n\

48+ \ if tree.value != null {\n\

49+ \ out += tree.value\n\

50+ \ }\n\

51+ \\n\

52+ \ for (key, subtree) in tree {\n\

53+ \ out += getValues(tree: tree)\n\

54+ \ }\n\

55+ \\n\

56+ \ return out\n\

57+ \}\n\

58+ \```"

59+

60+type CompletionsAPI = "tagCompletions" :> CompletionsDescription :> Get '[JSON] (CompletionTree Char)

61+

62+completionServer :: ServerT CompletionsAPI App

63+completionServer = completionHandler

64+

65+completionHandler :: ServerT CompletionsAPI App

66+completionHandler = runQerror $ mkCompletionTree <$> getTags