diff options
| -rw-r--r-- | Alpha.hs | 4 | ||||
| -rw-r--r-- | Biz/App.hs | 2 | ||||
| -rw-r--r-- | Biz/Auth.hs | 4 | ||||
| -rw-r--r-- | Biz/Bild/Deps/Haskell.nix | 1 | ||||
| -rw-r--r-- | Biz/Ibb/Client.hs | 2 | ||||
| -rw-r--r-- | Biz/Ibb/Core.hs | 69 | ||||
| -rw-r--r-- | Biz/Ibb/Influencers.hs | 14 | ||||
| -rw-r--r-- | Biz/Ibb/Keep.hs | 31 | ||||
| -rw-r--r-- | Biz/Ibb/Move.hs | 9 | ||||
| -rw-r--r-- | Biz/Ibb/Server.hs | 52 | ||||
| -rw-r--r-- | Biz/Pie.hs | 14 | ||||
| -rw-r--r-- | Biz/Que/Host.hs | 14 | ||||
| -rw-r--r-- | Control/Concurrent/Go.hs | 27 | ||||
| -rw-r--r-- | Control/Concurrent/Sema.hs | 2 | ||||
| -rw-r--r-- | Hero/Core.hs | 67 | ||||
| -rw-r--r-- | Hero/Host.hs | 157 | ||||
| -rw-r--r-- | Hero/Keep.hs | 40 | ||||
| -rw-r--r-- | Hero/Look.hs | 93 | ||||
| -rw-r--r-- | Hero/Look/Typography.hs | 2 | ||||
| -rw-r--r-- | Hero/Node.hs | 136 | ||||
| -rw-r--r-- | Hero/Part.hs | 2 | ||||
| -rw-r--r-- | System/Random/Shuffle.hs | 10 |
22 files changed, 381 insertions, 371 deletions
@@ -64,7 +64,7 @@ import Data.String import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText -import Protolude as X hiding (($), (&)) +import Protolude as X hiding (($), (&), (.)) -- | Debugging printf say :: Text -> IO () @@ -112,7 +112,7 @@ f |> g = g f -- | Alias for <&>. Can be read as "and then". Basically does into a -- functor, does some computation, then returns the same kind of --- functor. Could also be defined as `f >>= return . g` +-- functor. Could also be defined as `f >>= return <. g` (/>) :: Functor f => f a -> (a -> b) -> f b f /> g = fmap g f @@ -29,7 +29,7 @@ instance Accept CSS where contentType _ = "text" // "css" /: ("charset", "utf-8") instance MimeRender CSS Text where - mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict + mimeRender _ = Lazy.encodeUtf8 <. Lazy.fromStrict -- | The manifest describes your app for web app thumbnails, iPhone tiles, etc. data Manifest = Manifest diff --git a/Biz/Auth.hs b/Biz/Auth.hs index 2f4d17a..3648395 100644 --- a/Biz/Auth.hs +++ b/Biz/Auth.hs @@ -2,7 +2,8 @@ module Biz.Auth ( Error (..), Password, Username, - ) where + ) +where import Data.ByteString (ByteString) import Data.Text (Text) @@ -13,4 +14,5 @@ data Error | BadPassword type Password = MisoString + type Username = MisoString diff --git a/Biz/Bild/Deps/Haskell.nix b/Biz/Bild/Deps/Haskell.nix index 78ae6b2..1153e28 100644 --- a/Biz/Bild/Deps/Haskell.nix +++ b/Biz/Bild/Deps/Haskell.nix @@ -5,7 +5,6 @@ "aeson" "async" "bytestring" - # "capability" # broken deps "clay" "cmark" "config-ini" diff --git a/Biz/Ibb/Client.hs b/Biz/Ibb/Client.hs index d0ed3e3..efe4e84 100644 --- a/Biz/Ibb/Client.hs +++ b/Biz/Ibb/Client.hs @@ -29,7 +29,7 @@ import Miso ) main :: IO () -main = miso $ \u -> App {model = init u, ..} +main = miso <| \u -> App {model = init u, ..} where initialAction = FetchPeople update = move diff --git a/Biz/Ibb/Core.hs b/Biz/Ibb/Core.hs index 007d835..ec6ef10 100644 --- a/Biz/Ibb/Core.hs +++ b/Biz/Ibb/Core.hs @@ -22,34 +22,32 @@ import Servant.Links -- * entity data types -data Person - = Person - { -- | Their full name. - _name :: Text, - -- | A link to their picture. - _pic :: Text, - -- | Their twitter handle, without the `@` prefix. - _twitter :: Text, - -- | Their main website, fully formed: `https://example.com` - _website :: Text, - -- | A short list of the books they recommend. - _books :: [Book], - -- | A short "about" section, like you would see on the jacket flap of a book. - _blurb :: Text - } +data Person = Person + { -- | Their full name. + _name :: Text, + -- | A link to their picture. + _pic :: Text, + -- | Their twitter handle, without the `@` prefix. + _twitter :: Text, + -- | Their main website, fully formed: `https://example.com` + _website :: Text, + -- | A short list of the books they recommend. + _books :: [Book], + -- | A short "about" section, like you would see on the jacket flap of a book. + _blurb :: Text + } deriving (Generic, Show, Eq, Typeable, Data, Ord) instance FromJSON Person instance ToJSON Person -data Book - = Book - { _title :: Text, - _author :: Text, - -- | Amazon REF number, for creating affiliate links. - _amznref :: Text - } +data Book = Book + { _title :: Text, + _author :: Text, + -- | Amazon REF number, for creating affiliate links. + _amznref :: Text + } deriving (Generic, Show, Eq, Typeable, Data, Ord) instance FromJSON Book @@ -62,11 +60,10 @@ type AppRoutes = Home type Home = View Action -data Model - = Model - { uri :: URI, - people :: WebData [Person] - } +data Model = Model + { uri :: URI, + people :: WebData [Person] + } deriving (Show, Eq) type WebData a = RemoteData MisoString a @@ -92,7 +89,7 @@ notfound :: View Action notfound = div_ [] [text "404"] goHome :: URI -goHome = linkURI $ safeLink (Proxy :: Proxy AppRoutes) (Proxy :: Proxy Home) +goHome = linkURI <| safeLink (Proxy :: Proxy AppRoutes) (Proxy :: Proxy Home) see :: Model -> View Action see m = @@ -113,7 +110,7 @@ see m = ] ] ], - div_ [class_ "card-columns"] $ case people m of + div_ [class_ "card-columns"] <| case people m of NotAsked -> [text "Initializing..."] Loading -> [text "Loading..."] Failure err -> [text err] @@ -126,22 +123,22 @@ seePerson person = [class_ "card"] [ div_ [class_ "card-img"] - [img_ [class_ "card-img img-fluid", src_ $ ms $ _pic person]], + [img_ [class_ "card-img img-fluid", src_ <| ms <| _pic person]], div_ [class_ "card-body"] - [ h4_ [class_ "card-title"] [text $ ms $ _name person], + [ h4_ [class_ "card-title"] [text <| ms <| _name person], h6_ [] [ a_ [ class_ "fab fa-twitter", - href_ $ "https://twitter.com/" <> ms (_twitter person) + href_ <| "https://twitter.com/" <> ms (_twitter person) ] [], - a_ [class_ "fas fa-globe", href_ $ ms $ _website person] [] + a_ [class_ "fas fa-globe", href_ <| ms <| _website person] [] ], p_ [class_ "card-text"] - [text $ ms $ _blurb person, ul_ [] $ seeBook </ _books person] + [text <| ms <| _blurb person, ul_ [] <| seeBook </ _books person] ] ] @@ -151,7 +148,7 @@ seeBook book = [] [ a_ [ class_ "text-dark", - href_ $ "https://www.amazon.com/dp/" <> ms (_amznref book) + href_ <| "https://www.amazon.com/dp/" <> ms (_amznref book) ] - [text $ ms $ _title book] + [text <| ms <| _title book] ] diff --git a/Biz/Ibb/Influencers.hs b/Biz/Ibb/Influencers.hs index 08ce3e8..e41f5b1 100644 --- a/Biz/Ibb/Influencers.hs +++ b/Biz/Ibb/Influencers.hs @@ -81,7 +81,7 @@ allPeople = { _name = "Bill Gates", _pic = "https://pbs.twimg.com/profile_images/988775660163252226/XpgonN0X_400x400.jpg", _twitter = "BillGates", - _blurb = "Sharing things I'm learning through my foundation work and other interests. Founder of Microsoft and Bill & Melinda Gates Foundation", + _blurb = "Sharing things I'm learning through my foundation work and other interests. Founder of Microsoft and Bill |> Melinda Gates Foundation", _website = "https://www.gatesnotes.com", _books = [ Book @@ -138,7 +138,7 @@ allPeople = { _name = "Susan Cain", _pic = "https://pbs.twimg.com/profile_images/1474290079/SusanCain5smaller-1_400x400.jpg", _twitter = "susancain", - _blurb = "Bestselling author, award-winning speaker, http://Quietrev.com curator. Lover of bittersweet music & bittersweet chocolate, in equal measure.", + _blurb = "Bestselling author, award-winning speaker, http://Quietrev.com curator. Lover of bittersweet music |> bittersweet chocolate, in equal measure.", _website = "https://www.quietrev.com", _books = [ Book @@ -195,7 +195,7 @@ allPeople = { _name = "Luis Von Ahn", _pic = "https://pbs.twimg.com/profile_images/1020343581087678464/NIXD5MdC_400x400.jpg", _twitter = "LuisvonAhn", - _blurb = "CEO & co-founder of duolingo. Invented reCAPTCHA. Computer science professor at Carnegie Mellon. Proud Guatemalan", + _blurb = "CEO |> co-founder of duolingo. Invented reCAPTCHA. Computer science professor at Carnegie Mellon. Proud Guatemalan", _website = "https://www.duolingo.com/", _books = [ Book @@ -271,7 +271,7 @@ allPeople = { _name = "Allen Walton", _pic = "https://pbs.twimg.com/profile_images/1038905908678545409/yUbF9Ruc_400x400.jpg", _twitter = "allenthird", - _blurb = "Created http://SpyGuy.com and blogs about stuff at http://AllenWalton.com . All things ecommerce, personal dev, and Simpsons.", + _blurb = "Created http://SpyGuy.com and blogs about stuff at http://AllenWalton.com <. All things ecommerce, personal dev, and Simpsons.", _website = "https://www.allenwalton.com", _books = [ Book @@ -290,7 +290,7 @@ allPeople = { _name = "Peter Mallouk", _pic = "https://pbs.twimg.com/profile_images/713172266968715264/KsyDYghf_400x400.jpg", _twitter = "PeterMallouk", - _blurb = "President of Creative Planning. Author “5 Mistakes Every Investor Makes & How to Avoid Them”. Radically moderate.", + _blurb = "President of Creative Planning. Author “5 Mistakes Every Investor Makes |> How to Avoid Them”. Radically moderate.", _website = "https://creativeplanning.com", _books = [ Book @@ -423,7 +423,7 @@ allPeople = { _name = "Robert Herjavec", _pic = "https://pbs.twimg.com/profile_images/608643660876423170/DgxUW3eZ_400x400.jpg", _twitter = "robertherjavec", - _blurb = "Dad, Husband, Founder & CEO of global cybersecurity firm HerjavecGroup, Shark on ABC’s Shark Tank, Former Dragon, Author", + _blurb = "Dad, Husband, Founder |> CEO of global cybersecurity firm HerjavecGroup, Shark on ABC’s Shark Tank, Former Dragon, Author", _website = "https://www.robertherjavec.com/", _books = [ Book @@ -470,7 +470,7 @@ allPeople = _amznref = "1585424331" }, Book - { _title = "How to Win Friends & Influence People", + { _title = "How to Win Friends |> Influence People", _author = "Dale Carnegie", _amznref = "0671027034" } diff --git a/Biz/Ibb/Keep.hs b/Biz/Ibb/Keep.hs index c7dabb0..074a42a 100644 --- a/Biz/Ibb/Keep.hs +++ b/Biz/Ibb/Keep.hs @@ -28,10 +28,9 @@ import qualified Data.Text as Text -- * Keep -- | Main database. Need to think of a better name for this. -newtype IbbKeep - = IbbKeep - { _people :: IxSet Person - } +newtype IbbKeep = IbbKeep + { _people :: IxSet Person + } deriving (Data, Typeable) $(deriveSafeCopy 0 'base ''IbbKeep) @@ -51,20 +50,20 @@ newtype PersonBlurb instance Indexable Person where empty = ixSet - [ ixFun $ \p -> [PersonName $ _name p], - ixFun $ \p -> [_pic p], - ixFun $ \p -> [_twitter p], - ixFun $ \p -> [_website p], - ixFun $ \p -> [_books p], - ixFun $ \p -> [PersonBlurb $ _blurb p] + [ ixFun <| \p -> [PersonName <| _name p], + ixFun <| \p -> [_pic p], + ixFun <| \p -> [_twitter p], + ixFun <| \p -> [_website p], + ixFun <| \p -> [_books p], + ixFun <| \p -> [PersonBlurb <| _blurb p] ] -- | updates the `IbbKeep` with a new `Person` newPerson :: Text -> Text -> Update IbbKeep Person newPerson name blurb = do keep <- get - put $ - k + put + <| k { _people = IxSet.insert p (_people k) } return p @@ -97,16 +96,16 @@ newtype BookAuthor instance Indexable Book where empty = ixSet - [ ixFun $ \b -> [BookTitle $ _title b], - ixFun $ \b -> [BookAuthor $ _author b], - ixFun $ \b -> [_amznref b] + [ ixFun <| \b -> [BookTitle <| _title b], + ixFun <| \b -> [BookAuthor <| _author b], + ixFun <| \b -> [_amznref b] ] -- | updates the `IbbKeep` with a new `Book` -- newBook :: Text -> Text -> Text -> Update IbbKeep Book -- newBook title author amznref = do -- ibbKeep <- get --- put $ ibbKeep { _books = IxSet.insert b (_books ibbKeep) +-- put <| ibbKeep { _books = IxSet.insert b (_books ibbKeep) -- , _people = _people ibbKeep -- } -- return b diff --git a/Biz/Ibb/Move.hs b/Biz/Ibb/Move.hs index 0dec4e5..2135f85 100644 --- a/Biz/Ibb/Move.hs +++ b/Biz/Ibb/Move.hs @@ -27,8 +27,9 @@ import Network.RemoteData move :: Action -> Model -> Effect Action Model move Nop m = noEff m move (HandleRoute u) m = m {uri = u} <# pure Nop -move (ChangeRoute u) m = m <# do - pushURI u >> pure Nop +move (ChangeRoute u) m = + m <# do + pushURI u >> pure Nop move FetchPeople m = m <# (SetPeople </ fetchPeople) move (SetPeople ps) m = noEff m {people = ps} @@ -36,9 +37,9 @@ fetchPeople :: IO (WebData [Core.Person]) fetchPeople = do mjson <- contents </ xhrByteString req case mjson of - Nothing -> pure $ Failure "could not read from server" + Nothing -> pure <| Failure "could not read from server" Just a -> - pure $ fromEither $ either (Left . ms) pure $ eitherDecodeStrict a + pure <| fromEither <| either (Left <. ms) pure <| eitherDecodeStrict a where req = Request diff --git a/Biz/Ibb/Server.hs b/Biz/Ibb/Server.hs index 058bbdc..3e4b662 100644 --- a/Biz/Ibb/Server.hs +++ b/Biz/Ibb/Server.hs @@ -56,10 +56,10 @@ main :: IO () main = do say "rise: ibb" staticDir <- fromMaybe "static" <$> lookupEnv "STATIC_DIR" :: IO String - port <- (read . fromMaybe "3000" <$> lookupEnv "PORT") :: IO Int + port <- (read <. fromMaybe "3000" <$> lookupEnv "PORT") :: IO Int keep <- Keep.openLocal "_/keep/" say "port: 3000" - run port $ logStdout $ compress $ app staticDir keep + run port <| logStdout <| compress <| app staticDir keep where compress = gzip def {gzipFiles = GzipCompress} @@ -68,12 +68,13 @@ newtype HtmlPage a = HtmlPage a instance L.ToHtml a => L.ToHtml (HtmlPage a) where toHtmlRaw = L.toHtml - toHtml (HtmlPage x) = L.doctypehtml_ $ do - L.head_ $ do - L.meta_ [L.charset_ "utf-8"] - jsRef "/static/ibb.js" - cssRef "/css/main.css" - L.body_ page + toHtml (HtmlPage x) = + L.doctypehtml_ <| do + L.head_ <| do + L.meta_ [L.charset_ "utf-8"] + jsRef "/static/ibb.js" + cssRef "/css/main.css" + L.body_ page where page = L.toHtml x jsRef href = @@ -94,18 +95,17 @@ type ServerRoutes = ToServerRoutes AppRoutes HtmlPage Action handle404 :: Application handle404 _ respond = respond - $ responseLBS status404 [("Content-Type", "text/html")] - $ renderBS - $ toHtml - $ HtmlPage notfound + <| responseLBS status404 [("Content-Type", "text/html")] + <| renderBS + <| toHtml + <| HtmlPage notfound -newtype CSS - = CSS - { unCSS :: Text - } +newtype CSS = CSS + { unCSS :: Text + } instance MimeRender CSS Text where - mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict + mimeRender _ = Lazy.encodeUtf8 <. Lazy.fromStrict instance Accept CSS where contentType _ = "text" // "css" /: ("charset", "utf-8") @@ -122,16 +122,16 @@ type Routes = :<|> Raw cssHandlers :: Server CssRoute -cssHandlers = return . Lazy.toStrict . Clay.render $ Look.main +cssHandlers = return <. Lazy.toStrict <. Clay.render <| Look.main app :: String -> AcidState Keep.IbbKeep -> Application app staticDir keep = - serve (Proxy @Routes) $ - static - :<|> cssHandlers - :<|> serverHandlers - :<|> apiHandlers keep - :<|> Tagged handle404 + serve (Proxy @Routes) + <| static + :<|> cssHandlers + :<|> serverHandlers + :<|> apiHandlers keep + :<|> Tagged handle404 where static = serveDirectoryWith (defaultWebAppSettings staticDir) @@ -140,9 +140,9 @@ type ApiRoutes = "people" :> Get '[JSON] [Person] serverHandlers :: Server ServerRoutes serverHandlers = homeHandler where - send f u = pure $ HtmlPage $ f Model {uri = u, people = NotAsked} + send f u = pure <| HtmlPage <| f Model {uri = u, people = NotAsked} homeHandler = send home goHome -- | for now we just have one api endpoint, which returns all the people apiHandlers :: AcidState Keep.IbbKeep -> Server ApiRoutes -apiHandlers keep = Acid.query' keep $ Keep.GetPeople 20 +apiHandlers keep = Acid.query' keep <| Keep.GetPeople 20 @@ -70,18 +70,18 @@ main = do addCommand "new" "start new a weekly sprint" - (const . move New) + (const <. move New) (pure mempty) addCommand "update" "submit weekly update for a namespace" - (move . Update) - (optNamespace) + (move <. Update) + optNamespace addCommand "feedback" "submit user feedback for a namespace" - (move . Feedback) - (optNamespace) + (move <. Feedback) + optNamespace cwd <- Directory.getCurrentDirectory root <- Env.getEnv "BIZ_ROOT" let fullNamespace = @@ -101,7 +101,7 @@ optNamespace = <> short 'n' <> value "Devalloc" -data Form = Form {roll :: [Entry]} +newtype Form = Form {roll :: [Entry]} deriving (Generic, Aeson.ToJSON, Aeson.FromJSON, Show) instance Monoid Form where @@ -136,7 +136,7 @@ data Move move :: Move -> Form -> IO Form move mov form = case mov of New -> do - week <- Time.getCurrentTime >>= return . Time.formatTime Time.defaultTimeLocale "%V" + week <- Time.getCurrentTime >>= return <. Time.formatTime Time.defaultTimeLocale "%V" let branch = "sprint-" <> week proc <- Process.spawnProcess "git" ["show-ref", branch] Process.waitForProcess proc >>= \case diff --git a/Biz/Que/Host.hs b/Biz/Que/Host.hs index 4817fd6..3668a29 100644 --- a/Biz/Que/Host.hs +++ b/Biz/Que/Host.hs @@ -63,7 +63,7 @@ main = Exception.bracket startup shutdown <| uncurry Warp.run putText <| "skey: " <> (show <| queSkey c) return (quePort c, waiapp) shutdown :: a -> IO a - shutdown = pure . identity + shutdown = pure <. identity newtype App a = App { runApp :: ReaderT (STM.TVar AppState) IO a @@ -129,9 +129,9 @@ routes cfg = do Scotty.get (Scotty.regex quepath) <| do (ns, qp) <- extract guardNs ns ["pub", "_"] - app . modify <| upsertNamespace ns + app <. modify <| upsertNamespace ns q <- app <| que ns qp - poll <- Scotty.param "poll" !: (pure . const False) + poll <- Scotty.param "poll" !: (pure <. const False) if poll then Scotty.stream <| streamQue q else do @@ -151,7 +151,7 @@ routes cfg = do >> Scotty.finish guardNs ns ["pub", "_"] -- passed all auth checks - app . modify <| upsertNamespace ns + app <. modify <| upsertNamespace ns q <- app <| que ns qp qdata <- Scotty.body _ <- liftIO <| Go.write q <| BSL.toStrict qdata @@ -184,7 +184,7 @@ streamQue q write _ = loop q where loop c = Go.read c - >>= (write . Builder.byteStringInsert) + >>= (write <. Builder.byteStringInsert) >> loop c -- | Gets the thing from the Hashmap. Call's 'error' if key doesn't exist. @@ -218,11 +218,11 @@ app = lift -- | Get something from the app state gets :: (AppState -> b) -> App b -gets f = ask >>= liftIO . STM.readTVarIO >>= return </ f +gets f = ask >>= liftIO <. STM.readTVarIO >>= return </ f -- | Apply a function to the app state modify :: (AppState -> AppState) -> App () -modify f = ask >>= liftIO . atomically . flip STM.modifyTVar' f +modify f = ask >>= liftIO <. atomically <. flip STM.modifyTVar' f -- | housing for a set of que paths type Namespace = Text.Lazy.Text diff --git a/Control/Concurrent/Go.hs b/Control/Concurrent/Go.hs index 69d35b8..92444f4 100644 --- a/Control/Concurrent/Go.hs +++ b/Control/Concurrent/Go.hs @@ -30,17 +30,16 @@ import Data.Text (Text) import qualified System.IO.Unsafe as Unsafe -- | A standard channel. -data Channel a - = Channel - { _in :: Chan.InChan a, - _out :: Chan.OutChan a, - _size :: Int - } +data Channel a = Channel + { _in :: Chan.InChan a, + _out :: Chan.OutChan a, + _size :: Int + } instance Aeson.ToJSON (Channel a) where toJSON c = Aeson.String ("#<channel " <> len c <> ">" :: Text) where - len = show . Unsafe.unsafePerformIO . Chan.estimatedLength . _in + len = show <. Unsafe.unsafePerformIO <. Chan.estimatedLength <. _in -- | Starts a background process. fork :: IO () -> IO Concurrent.ThreadId @@ -58,26 +57,26 @@ type Mult a = Chan.OutChan a -- | Duplicates a channel, but then anything written to the source will -- be available to both. This is like Clojure's `core.async/mult` mult :: Channel a -> IO (Mult a) -mult = Chan.dupChan . _in +mult = Chan.dupChan <. _in -- | Read a value from a 'Mult'. This is like Clojure's `core.async/tap`. -- -- You can use this to read from a channel in a background process, e.g.: -- -- >>> c <- Go.chan --- >>> Go.fork . forever <| Go.mult c >>= Go.tap >>= print +-- >>> Go.fork <. forever <| Go.mult c >>= Go.tap >>= print tap :: Mult a -> IO a tap = Chan.readChan -- | Take from a channel. Blocks until a value is received. read :: Channel a -> IO a -read = Chan.readChan . _out +read = Chan.readChan <. _out -- | Write to a channel. Blocks if the channel is full. write :: Channel a -> a -> IO Bool -write = Chan.tryWriteChan . _in +write = Chan.tryWriteChan <. _in --- $example +-- <|example -- -- A simple example from ghci: -- @@ -94,9 +93,9 @@ write = Chan.tryWriteChan . _in -- >>> Go.read c -- "hi" -- >>> Go.fork --- >>> Go.fork $ forever $ Go.mult c >>= Go.tap >>= \t -> print ("one: " <> t) +-- >>> Go.fork <| forever <| Go.mult c >>= Go.tap >>= \t -> print ("one: " <> t) -- ThreadId 810 --- >>> Go.fork $ forever $ Go.mult c >>= Go.tap >>= \t -> print ("two: " <> t) +-- >>> Go.fork <| forever <| Go.mult c >>= Go.tap >>= \t -> print ("two: " <> t) -- ThreadId 825 -- >>> Go.write c "test" -- "two: t"eosnte": diff --git a/Control/Concurrent/Sema.hs b/Control/Concurrent/Sema.hs index 5b32bab..c105cf8 100644 --- a/Control/Concurrent/Sema.hs +++ b/Control/Concurrent/Sema.hs @@ -9,4 +9,4 @@ import qualified Control.Concurrent.MSem as Sem mapPool :: Traversable t => Int -> (a -> IO b) -> t a -> IO (t b) mapPool n f xs = do sima <- Sem.new n - mapConcurrently (Sem.with sima . f) xs + mapConcurrently (Sem.with sima <. f) xs diff --git a/Hero/Core.hs b/Hero/Core.hs index 8f865da..86b0638 100644 --- a/Hero/Core.hs +++ b/Hero/Core.hs @@ -77,12 +77,11 @@ comicSlug Comic {..} = snake comicName <> "-" <> comicIssue -- * user -data User - = User - { userEmail :: Text, - userName :: Text, - userLibrary :: [Comic] - } +data User = User + { userEmail :: Text, + userName :: Text, + userLibrary :: [Comic] + } deriving (Show, Eq, Generic, Data, Ord) instance Semigroup User where @@ -158,7 +157,7 @@ instance Elemental Button where [ img_ [src_ <| ms <| Pack.icon <> "save.svg"], span_ [] [text "saved"] ] - else-- not in library + else -- not in library a_ [class_ "wrs-button", onClick <| ToggleInLibrary c] @@ -173,7 +172,7 @@ instance Elemental Button where onClick <| ToggleInLibrary c ] [img_ [src_ <| ms <| Pack.demo <> "library-add.png"]] - else-- not in library + else -- not in library button_ [ class_ "button is-large has-background-black-bis", @@ -231,16 +230,15 @@ findComic id = List.find (\c -> comicId c == id) -- -- Try to prefix component-specific state with the component initials: 'd' for -- discover, 'cp' for comic player. -data Form - = Form - { uri :: Api.URI, - appComics :: RemoteData MisoString [Comic], - user :: User, - dMediaInfo :: Maybe Comic, - cpState :: ComicReaderState, - cpAudioState :: AudioState, - magnification :: Magnification - } +data Form = Form + { uri :: Api.URI, + appComics :: RemoteData MisoString [Comic], + user :: User, + dMediaInfo :: Maybe Comic, + cpState :: ComicReaderState, + cpAudioState :: AudioState, + magnification :: Magnification + } deriving (Show, Eq) initForm :: Api.URI -> Form @@ -323,6 +321,7 @@ pubRoutes :: Proxy PubRoutes pubRoutes = Proxy -- * pages + -- -- TODO: consider making a typeclass, something like: -- @@ -334,6 +333,7 @@ pubRoutes = Proxy -- link :: Api.URI -- ** home + -- -- this is the unauthenticated page that you see when you first visit @@ -481,15 +481,14 @@ discoverFooter = -- ** comic -data Comic - = Comic - { comicId :: ComicId, - comicPages :: Integer, - comicName :: Text, - -- | Ideally this would be a dynamic number-like type - comicIssue :: Text, - comicDescription :: Text - } +data Comic = Comic + { comicId :: ComicId, + comicPages :: Integer, + comicName :: Text, + -- | Ideally this would be a dynamic number-like type + comicIssue :: Text, + comicDescription :: Text + } deriving (Show, Eq, Generic, Data, Ord) instance ToJSON Comic where @@ -534,11 +533,11 @@ instance IsMediaObject Comic where <| Pack.demo <> comicSlug comic <> "-logo.png" ] ], - div_ [class_ "comic-action-menu"] <| - el </ [Watch comic, Read comic, Save comic lib], + div_ [class_ "comic-action-menu"] + <| el </ [Watch comic, Read comic, Save comic lib], p_ [class_ "description"] - [ text . ms <| comicDescription comic + [ text <. ms <| comicDescription comic ] ] ] @@ -800,7 +799,7 @@ comicVideo _ _ _ = ] ] --- * general page components & utils +-- * general page components |> utils -- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty' maybeView :: (a -> View action) -> Maybe a -> View action @@ -899,9 +898,9 @@ comicControls comic page form = ] ] where - leftPage = ms . Legacy.show <| page - rightPage = ms . Legacy.show <| 1 + page - totalpages = ms . Legacy.show <| comicPages comic + leftPage = ms <. Legacy.show <| page + rightPage = ms <. Legacy.show <| 1 + page + totalpages = ms <. Legacy.show <| comicPages comic topbar :: View Move topbar = diff --git a/Hero/Host.hs b/Hero/Host.hs index d547fa5..9d10f02 100644 --- a/Hero/Host.hs +++ b/Hero/Host.hs @@ -9,7 +9,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoImplicitPrelude #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Hero web app @@ -83,57 +82,59 @@ main = bracket startup shutdown run where run (cfg, app, _) = Warp.run (heroPort cfg) app prn = IO.hPutStrLn IO.stderr - startup = Envy.decodeEnv >>= \case - Left e -> Exit.die e - Right cfg -> - do - keep <- Keep.open (heroKeep cfg) - skey <- upsertKey (heroSkey cfg) - say "hero" - prn <| "port: " ++ show (heroPort cfg) - prn <| "keep: " ++ heroKeep cfg - prn <| "node: " ++ heroNode cfg - prn <| "skey: " ++ heroSkey cfg - let jwts = Auth.defaultJWTSettings skey - cs = - Auth.defaultCookieSettings - { -- uncomment this for insecure dev - Auth.cookieIsSecure = Auth.NotSecure, - Auth.cookieXsrfSetting = Nothing - } - ctx = cs :. jwts :. EmptyContext - proxy = Proxy @(AllRoutes '[Auth.JWT, Auth.Cookie]) - static = serveDirectoryWith <| defaultWebAppSettings <| heroNode cfg - server = - -- assets, auth, and the homepage is public - static - :<|> cssHandlers - :<|> pure heroManifest - :<|> pubHostHandlers - :<|> authHandler cs jwts - -- app and api are private - :<|> wrapAuth (jsonHandlers keep) - :<|> wrapAuth appHostHandlers - -- fall through to 404 - :<|> Tagged handle404 - return - ( cfg, - serveWithContext - proxy - ctx - server, - keep - ) + startup = + Envy.decodeEnv >>= \case + Left e -> Exit.die e + Right cfg -> + do + keep <- Keep.open (heroKeep cfg) + skey <- upsertKey (heroSkey cfg) + say "hero" + prn <| "port: " ++ show (heroPort cfg) + prn <| "keep: " ++ heroKeep cfg + prn <| "node: " ++ heroNode cfg + prn <| "skey: " ++ heroSkey cfg + let jwts = Auth.defaultJWTSettings skey + cs = + Auth.defaultCookieSettings + { -- uncomment this for insecure dev + Auth.cookieIsSecure = Auth.NotSecure, + Auth.cookieXsrfSetting = Nothing + } + ctx = cs :. jwts :. EmptyContext + proxy = Proxy @(AllRoutes '[Auth.JWT, Auth.Cookie]) + static = serveDirectoryWith <| defaultWebAppSettings <| heroNode cfg + server = + -- assets, auth, and the homepage is public + static + :<|> cssHandlers + :<|> pure heroManifest + :<|> pubHostHandlers + :<|> authHandler cs jwts + -- app and api are private + :<|> wrapAuth (jsonHandlers keep) + :<|> wrapAuth appHostHandlers + -- fall through to 404 + :<|> Tagged handle404 + return + ( cfg, + serveWithContext + proxy + ctx + server, + keep + ) shutdown :: App -> IO () shutdown (_, _, keep) = do Keep.close keep return () upsertKey :: FilePath -> IO Crypto.JWK -upsertKey fp = Directory.doesFileExist fp >>= \exists -> - if exists - then Auth.readKey fp - else Auth.writeKey fp >> Auth.readKey fp +upsertKey fp = + Directory.doesFileExist fp >>= \exists -> + if exists + then Auth.readKey fp + else Auth.writeKey fp >> Auth.readKey fp -- This part is a little confusing. I have: -- @@ -150,13 +151,12 @@ upsertKey fp = Directory.doesFileExist fp >>= \exists -> -- | This can be generalized I think, put in Biz.App, or something type App = (Config, Application, AcidState Keep.HeroKeep) -data Config - = Config - { heroPort :: Warp.Port, - heroNode :: FilePath, - heroKeep :: FilePath, - heroSkey :: FilePath - } +data Config = Config + { heroPort :: Warp.Port, + heroNode :: FilePath, + heroKeep :: FilePath, + heroSkey :: FilePath + } deriving (Generic, Show) instance Envy.DefConfig Config where @@ -206,12 +206,13 @@ type CssRoute = "css" :> "main.css" :> Get '[CSS] Text cssHandlers :: Server CssRoute cssHandlers = - return . Lazy.toStrict . Clay.render <| Typography.main <> Look.main + return <. Lazy.toStrict <. Clay.render <| Typography.main <> Look.main type AuthRoute = "auth" :> ReqBody '[JSON] LoginForm - :> Post '[JSON] + :> Post + '[JSON] ( Headers '[ Header "Set-Cookie" Auth.SetCookie, Header "Set-Cookie" Auth.SetCookie @@ -291,37 +292,37 @@ instance L.ToHtml a => L.ToHtml (Templated a) where L.link_ [ L.rel_ "apple-touch-icon", L.sizes_ "180x180", - L.href_ <| - Pack.cdnEdge - <> "/old-assets/images/favicons/apple-touch-icon.png" + L.href_ + <| Pack.cdnEdge + <> "/old-assets/images/favicons/apple-touch-icon.png" ] L.link_ [ L.rel_ "icon", L.type_ "image/png", L.sizes_ "32x32", - L.href_ <| - Pack.cdnEdge - <> "/old-assets/images/favicons/favicon-32x32.png" + L.href_ + <| Pack.cdnEdge + <> "/old-assets/images/favicons/favicon-32x32.png" ] L.link_ [ L.rel_ "icon", L.type_ "image/png", L.sizes_ "16x16", - L.href_ <| - Pack.cdnEdge - <> "/old-assets/images/favicons/favicon-16x16.png" + L.href_ + <| Pack.cdnEdge + <> "/old-assets/images/favicons/favicon-16x16.png" ] L.link_ [ L.rel_ "manifest", - L.href_ <| - Pack.cdnEdge - <> "/old-assets/images/favicons/manifest.json" + L.href_ + <| Pack.cdnEdge + <> "/old-assets/images/favicons/manifest.json" ] L.link_ [ L.rel_ "mask-icon", - L.href_ <| - Pack.cdnEdge - <> "/old-assets/images/favicons/safari-pinned-tab.svg" + L.href_ + <| Pack.cdnEdge + <> "/old-assets/images/favicons/safari-pinned-tab.svg" ] L.meta_ [L.charset_ "utf-8"] L.meta_ [L.name_ "theme-color", L.content_ "#000"] @@ -373,30 +374,30 @@ bulmaRef = "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css" homeHandler :: Handler (Templated (View Move)) -homeHandler = pure . Templated . home <| initForm homeLink +homeHandler = pure <. Templated <. home <| initForm homeLink comicCoverHandler :: ComicId -> Handler (Templated (View Move)) comicCoverHandler id = - pure . Templated . comicCover id . initForm <| comicLink id + pure <. Templated <. comicCover id <. initForm <| comicLink id comicPageHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) comicPageHandler id n = - pure . Templated . comicReader id n . initForm <| comicReaderSpreadLink id n + pure <. Templated <. comicReader id n <. initForm <| comicReaderSpreadLink id n comicPageFullHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) comicPageFullHandler id n = - pure . Templated . comicReader id n . initForm <| comicReaderFullLink id n + pure <. Templated <. comicReader id n <. initForm <| comicReaderFullLink id n comicVideoHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) comicVideoHandler id n = - pure . Templated . comicReader id n . initForm <| comicVideoLink id n + pure <. Templated <. comicReader id n <. initForm <| comicVideoLink id n discoverHandler :: Handler (Templated (View Move)) -discoverHandler = pure . Templated . discover <| initForm discoverLink +discoverHandler = pure <. Templated <. discover <| initForm discoverLink chooseExperienceHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) chooseExperienceHandler id n = - pure . Templated . comicReader id n . initForm <| chooseExperienceLink id n + pure <. Templated <. comicReader id n <. initForm <| chooseExperienceLink id n loginHandler :: Handler (Templated (View Move)) -loginHandler = pure . Templated . login <| initForm loginLink +loginHandler = pure <. Templated <. login <| initForm loginLink diff --git a/Hero/Keep.hs b/Hero/Keep.hs index 72bd6c2..744313b 100644 --- a/Hero/Keep.hs +++ b/Hero/Keep.hs @@ -16,11 +16,11 @@ module Hero.Keep where import Alpha -import qualified Data.Acid as Acid import Data.Acid (Update, makeAcidic) +import qualified Data.Acid as Acid import Data.Data (Data, Typeable) -import qualified Data.IxSet as IxSet import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet) +import qualified Data.IxSet as IxSet import Data.SafeCopy (base, deriveSafeCopy) import qualified Data.Text as Text import Hero.Core @@ -28,11 +28,10 @@ import Hero.Core -- * Keep -- | Main database. -data HeroKeep - = HeroKeep - { _comics :: (IxSet Comic), - _users :: (IxSet User) - } +data HeroKeep = HeroKeep + { _comics :: IxSet Comic, + _users :: IxSet User + } deriving (Data, Typeable) $(deriveSafeCopy 0 'base ''HeroKeep) @@ -48,25 +47,25 @@ $(deriveSafeCopy 0 'base ''ComicId) instance Indexable Comic where empty = ixSet - [ ixFun $ \c -> [comicId c], - ixFun $ \c -> [comicPages c], - ixFun $ \c -> [comicName c], - ixFun $ \c -> [comicIssue c], - ixFun $ \c -> [comicDescription c] + [ ixFun <| \c -> [comicId c], + ixFun <| \c -> [comicPages c], + ixFun <| \c -> [comicName c], + ixFun <| \c -> [comicIssue c], + ixFun <| \c -> [comicDescription c] ] instance Indexable User where empty = ixSet - [ ixFun $ \u -> [userEmail u], - ixFun $ \u -> [userName u], - ixFun $ \u -> [userLibrary u] + [ ixFun <| \u -> [userEmail u], + ixFun <| \u -> [userName u], + ixFun <| \u -> [userLibrary u] ] newComic :: Comic -> Update HeroKeep Comic newComic c = do keep <- get - put $ keep {_comics = IxSet.insert c (_comics keep)} + put <| keep {_comics = IxSet.insert c (_comics keep)} return c getComics :: Int -> Acid.Query HeroKeep [Comic] @@ -80,10 +79,11 @@ initialHeroKeep :: HeroKeep initialHeroKeep = HeroKeep { _comics = IxSet.fromList [theRed], - _users = IxSet.fromList - [ User "a" "micheal" [], - User "b" "ben" [] - ] + _users = + IxSet.fromList + [ User "a" "micheal" [], + User "b" "ben" [] + ] } where theRed = diff --git a/Hero/Look.hs b/Hero/Look.hs index 03f64b3..e3958d5 100644 --- a/Hero/Look.hs +++ b/Hero/Look.hs @@ -2,12 +2,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} +{- HLINT ignore "Use |>" -} + -- | Styles -- -- Eventually move make this mostly well-typed. Use this EDSL: -- http://fvisser.nl/clay/ module Hero.Look where +import Alpha hiding (rem, (**), (|>)) import Clay import qualified Clay.Flexbox as Flexbox import qualified Clay.Media as Media @@ -16,9 +19,8 @@ import qualified Clay.Stylesheet as Stylesheet import qualified Data.Map as Map import qualified Data.Text.Lazy as L import Hero.Look.Typography as Typo -import Miso ((=:), Attribute, style_) +import Miso (Attribute, style_, (=:)) import Miso.String (MisoString, toMisoString) -import Protolude hiding ((&), (**), rem) main :: Css main = do @@ -33,8 +35,8 @@ main = do textDecoration none ".loading" ? do centered - height $ vh 100 - width $ vw 100 + height <| vh 100 + width <| vw 100 -- animations ".grow" ? do transition "all" (sec 0.2) easeInOut (sec 0.2) @@ -51,13 +53,13 @@ main = do forwards keyframes "blur" - [ (0, Clay.filter $ blur (px 0)), - (50, Clay.filter $ blur (px 0)), - (100, Clay.filter $ blur (px 10)) + [ (0, Clay.filter <| blur (px 0)), + (50, Clay.filter <| blur (px 0)), + (100, Clay.filter <| blur (px 10)) ] html <> body ? do background nite - mobile $ do + mobile <| do overflowX hidden width (vw 100) -- general app wrapper stuf @@ -85,19 +87,19 @@ main = do borderBottom solid (px 3) grai wide top (px 0) - mobile $ noBorder <> width (vw 100) + mobile <| noBorder <> width (vw 100) "#app-body" ? do display flex - desktop $ width (vw 93) + desktop <| width (vw 93) alignContent center alignItems flexStart justifyContent flexStart flexDirection column flexShrink 0 padding (px 0) 0 0 0 - marginY $ px 74 - mobile $ flexDirection column - "#discover #app-body" ? do desktop $ marginLeft appmenuWidth + marginY <| px 74 + mobile <| flexDirection column + "#discover #app-body" ? do desktop <| marginLeft appmenuWidth "#app-head-right" ? do display flex justifyContent spaceBetween @@ -137,7 +139,7 @@ main = do zIndex 1 height (vh 100) width (px 400) - mobile $ width (vw 90) + mobile <| width (vw 90) "#login" ** ".help" ** a ? do color white display flex @@ -159,17 +161,17 @@ main = do euro <> wide flexCenter width (pct 100) - desktop $ marginLeft appmenuWidth <> height (vh 90) - mobile $ marginX (rem 0) <> marginTop (rem 0) <> minHeight (vh 90) + desktop <| marginLeft appmenuWidth <> height (vh 90) + mobile <| marginX (rem 0) <> marginTop (rem 0) <> minHeight (vh 90) h2 ? do thicc <> wide <> smol <> lower <> coat 2 textAlign center - mobile $ coat 0.8 + mobile <| coat 0.8 p ? do thicc <> coat 0.8 <> textAlign center maxWidth (px 900) marginAll (rem 1) - mobile $ coat 0.6 + mobile <| coat 0.6 ul ? do display flex flexDirection row @@ -181,7 +183,7 @@ main = do display flex flexDirection column textAlign center - mobile $ coat 0.6 + mobile <| coat 0.6 coat 0.8 <> clickable divv <? do position relative @@ -207,7 +209,7 @@ main = do justifyContent center alignItems center display flex - ".comic-video" |> iframe ? do + ".comic-video" & iframe ? do position absolute height (pct 93) width (pct 100) @@ -219,8 +221,8 @@ main = do fontSize z lineHeight z let m = 24 :: Double - top $ px $ navbarHeight + m - left $ px m + top <| px <| navbarHeight + m + left <| px m zIndex 999 -- zoom button and slider "#zoom-button" ? do @@ -229,15 +231,15 @@ main = do let sliderYY = 250 euro <> wide input ? do - transform $ Clay.rotate (deg (-90)) + transform <| Clay.rotate (deg (-90)) margin 0 0 (px sliderYY) 0 position absolute - height $ px sliderY - width $ px 200 + height <| px sliderY + width <| px 200 hide label ? do coat 0.9 - marginBottom $ px $ 2 * sliderYY + marginBottom <| px <| 2 * sliderYY position absolute hide ":hover" & ".ctrl" ? visibility visible @@ -252,7 +254,7 @@ main = do borderBottom solid (px 1) white flexDirection row centerJustify - mobile $ do + mobile <| do margin (rem 2) 0 (rem 2) 0 padding 0 0 0 (rem 0) noBorder @@ -263,7 +265,7 @@ main = do display flex flexDirection row divv # lastChild <? paddingLeft (rem 1) - mobile $ do + mobile <| do width (vw 90) -- this line can be commented if you want to center the meta img ? width (px 150) order (-1) @@ -271,7 +273,7 @@ main = do ".media-info-summary" ? do Flexbox.flex 2 1 (px 0) paddingRight (rem 3) - mobile $ do + mobile <| do marginAll (rem 1) padding 0 0 0 (rem 0) ".media-info-actions" ? do @@ -280,7 +282,7 @@ main = do display flex flexDirection column justifyContent spaceAround - mobile $ do + mobile <| do maxWidth (vw 100) flexDirection row order 1 @@ -308,8 +310,8 @@ main = do a |> img ? do width (px 22) height (px 22) - desktop $ a |> span ? remove - mobile $ do + desktop <| a |> span ? remove + mobile <| do order 2 flexDirection row position fixed @@ -329,14 +331,14 @@ main = do flexDirection column Typo.euro height (px 411) - mobile $ do + mobile <| do padding (px 0) 0 0 0 margin 0 0 (px 50) 0 after & do display block position relative - background $ - linearGradient + background + <| linearGradient (straight sideTop) [ (setA 0 nite, pct 0), (nite, pct 100) @@ -356,13 +358,13 @@ main = do position relative minHeight (px 411) minWidth (px 1214) - mobile $ marginLeft (px (-310)) + mobile <| marginLeft (px (-310)) "#featured-content" ? do position absolute width (pct 100) zIndex 9 top (px 200) -- b/c Firefox & WebKit autocalc "top" differently - mobile $ do + mobile <| do marginTop (px 200) alignItems center display flex @@ -382,7 +384,7 @@ main = do fontSize (rem 0.8) fontVariant smallCaps euro <> thicc <> wide - mobile $ do + mobile <| do height (px 26) width (px 100) margin 0 (px 5) 0 (px 5) @@ -393,7 +395,7 @@ main = do img ? do marginRight (px 7) height (px 15) - mobile $ height (px 10) + mobile <| height (px 10) -- ".comic-action-menu" ? display flex <> justifyContent (JustifyContentValue "left") -- shelving @@ -402,7 +404,7 @@ main = do flexDirection column justifyContent flexStart alignItems flexStart - mobile $ do + mobile <| do padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5) width (vw 100) ".comic" ? do @@ -518,15 +520,16 @@ grai = rgb 221 221 221 -- #dddddd -- dynamically as JavaScript object properties. The implementation is a bit -- hacky, but works. css :: Clay.Css -> Attribute action -css = Miso.style_ . Map.fromList . f . Clay.renderWith Clay.htmlInline [] +css = Miso.style_ <. Map.fromList <. f <. Clay.renderWith Clay.htmlInline [] where f :: L.Text -> [(MisoString, MisoString)] - f t = L.splitOn ";" t - <&> L.splitOn ":" - <&> \(x : y) -> (toMisoString x, toMisoString $ L.intercalate ":" y) + f t = + L.splitOn ";" t + <&> L.splitOn ":" + <&> \(x : y) -> (toMisoString x, toMisoString <| L.intercalate ":" y) inlineCss :: Css -> MisoString -inlineCss = toMisoString . render +inlineCss = toMisoString <. render type Style = Map MisoString MisoString diff --git a/Hero/Look/Typography.hs b/Hero/Look/Typography.hs index 7c28f21..603e78b 100644 --- a/Hero/Look/Typography.hs +++ b/Hero/Look/Typography.hs @@ -44,7 +44,7 @@ upper = textTransform uppercase -- | apparently "coat" is a synonym for "size" coat :: Double -> Css -coat = fontSize . Clay.rem +coat = fontSize <. Clay.rem fontRoot :: Text fontRoot = Pack.cdnEdge <> "/old-assets/fonts/eurostile/Eurostile" diff --git a/Hero/Node.hs b/Hero/Node.hs index 70b8217..38f540d 100644 --- a/Hero/Node.hs +++ b/Hero/Node.hs @@ -26,13 +26,13 @@ import qualified Data.Set as Set import qualified GHC.Show as Legacy import GHCJS.Types (JSVal) import Hero.Core - ( Move (..), - AudioState (..), + ( AudioState (..), Comic (..), ComicReaderState (..), ComicReaderView (..), - LoginForm (..), Form (..), + LoginForm (..), + Move (..), User (..), audioId, chooseExperienceLink, @@ -57,7 +57,7 @@ import Protolude -- | Entry point for a miso application main :: IO () -main = miso $ \currentURI -> App {model = initForm currentURI, ..} +main = miso <| \currentURI -> App {model = initForm currentURI, ..} where update = move view = see @@ -97,38 +97,42 @@ foreign import javascript unsafe "$1.value" -- | Updates form, optionally introduces side effects move :: Move -> Form -> Effect Move Form move NoOp form = noEff form -move Dumpform form = form <# do - jslog $ ms $ Legacy.show form - pure NoOp -move (SelectExperience comic) form = form {cpState = ChooseExperience (comicId comic) 1} - <# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1 -move (StartReading comic) form = form {cpState = Reading Spread (comicId comic) 1} - <# do pure $ ChangeURI $ comicReaderSpreadLink (comicId comic) 1 -move (StartWatching comic) form = form {cpState = Watching (comicId comic)} - <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1 +move Dumpform form = + form <# do + jslog <| ms <| Legacy.show form + pure NoOp +move (SelectExperience comic) form = + form {cpState = ChooseExperience (comicId comic) 1} + <# do pure <| ChangeURI <| chooseExperienceLink (comicId comic) 1 +move (StartReading comic) form = + form {cpState = Reading Spread (comicId comic) 1} + <# do pure <| ChangeURI <| comicReaderSpreadLink (comicId comic) 1 +move (StartWatching comic) form = + form {cpState = Watching (comicId comic)} + <# do pure <| ChangeURI <| comicVideoLink (comicId comic) 1 move NextPage form = case cpState form of Reading Spread id pg -> form {cpState = Reading Spread id (pg + 2)} <# do - pure $ ChangeURI $ comicReaderSpreadLink id (pg + 2) + pure <| ChangeURI <| comicReaderSpreadLink id (pg + 2) Reading Full id pg -> form {cpState = Reading Full id (pg + 1)} <# do - pure $ ChangeURI $ comicReaderFullLink id (pg + 1) + pure <| ChangeURI <| comicReaderFullLink id (pg + 1) Cover id -> form {cpState = Reading Spread id 1} <# do - pure $ ChangeURI $ comicReaderSpreadLink id 1 + pure <| ChangeURI <| comicReaderSpreadLink id 1 _ -> noEff form move PrevPage form = case cpState form of Reading Spread id pg -> form {cpState = Reading Spread id (pg -2)} <# do - pure $ ChangeURI $ comicReaderSpreadLink id (pg -2) + pure <| ChangeURI <| comicReaderSpreadLink id (pg -2) Reading Full id pg -> form {cpState = Reading Full id (pg -1)} <# do - pure $ ChangeURI $ comicReaderFullLink id (pg -1) + pure <| ChangeURI <| comicReaderFullLink id (pg -1) Cover _ -> noEff form _ -> noEff form move (ToggleZoom c pg) m = m {cpState = newState} <# pure act where - goto lnk = ChangeURI $ lnk (comicId c) pg + goto lnk = ChangeURI <| lnk (comicId c) pg reading v = Reading v (comicId c) pg (newState, act) = case cpState m of Reading Full _ _ -> (reading Spread, goto comicReaderSpreadLink) @@ -138,45 +142,50 @@ move (ToggleInLibrary c) form = form {user = newUser} <# pure NoOp where newUser = (user form) {userLibrary = newLib} newLib - | c `elem` (userLibrary $ user form) = - Protolude.filter (/= c) $ userLibrary $ user form - | otherwise = c : (userLibrary $ user form) + | c `elem` (userLibrary <| user form) = + Protolude.filter (/= c) <| userLibrary <| user form + | otherwise = c : (userLibrary <| user form) move (HandleURI u) form = form {uri = u} <# pure NoOp -move (ChangeURI u) form = form <# do - pushURI u - pure NoOp +move (ChangeURI u) form = + form <# do + pushURI u + pure NoOp move FetchComics form = form <# (SetComics <$> fetchComics) move (SetComics cs) form = noEff form {appComics = cs} -move (ToggleAudio i) form = form {cpAudioState = newState} <# do - el <- Document.getElementById i - toggle el - pure NoOp +move (ToggleAudio i) form = + form {cpAudioState = newState} <# do + el <- Document.getElementById i + toggle el + pure NoOp where (newState, toggle) = case cpAudioState form of Playing -> (Paused, Audio.pause) Paused -> (Playing, Audio.play) -move ToggleFullscreen form = form {cpState = newState} <# do - el <- Document.querySelector "body" - -- TODO: check Document.fullscreenEnabled - -- https://developer.mozilla.org/en-US/docs/Web/API/Document/fullscreenEnabled - _ <- toggle el - pure NoOp +move ToggleFullscreen form = + form {cpState = newState} <# do + el <- Document.querySelector "body" + -- TODO: check Document.fullscreenEnabled + -- https://developer.mozilla.org/en-US/docs/Web/API/Document/fullscreenEnabled + _ <- toggle el + pure NoOp where (toggle, newState) = case cpState form of Reading Full c n -> (const Fullscreen.exit, Reading Full c n) Reading Spread c n -> (Fullscreen.request, Reading Spread c n) -- otherwise, do nothing: x -> (pure, x) -move (SetMediaInfo x) form = form {dMediaInfo = x} - <# case x of - Just Comic {comicId = id} -> - pure $ ScrollIntoView $ "comic-" <> ms id - Nothing -> - pure NoOp -move (ScrollIntoView id) form = form <# do - jslog $ ms $ Legacy.show id - scrollIntoView id - pure NoOp +move (SetMediaInfo x) form = + form {dMediaInfo = x} + <# case x of + Just Comic {comicId = id} -> + pure <| ScrollIntoView <| "comic-" <> ms id + Nothing -> + pure NoOp +move (ScrollIntoView id) form = + form <# do + jslog <| ms <| Legacy.show id + scrollIntoView id + pure NoOp move ValidateUserPassword form = batchEff form @@ -193,15 +202,16 @@ move ValidateUserPassword form = Network.NotAsked -> pure NoOp fetchComics :: IO (Network.RemoteData MisoString [Comic]) -fetchComics = Ajax.xhrByteString req /> Ajax.contents >>= \case - Nothing -> - pure $ Network.Failure "Could not fetch comics from server." - Just json -> - json - |> Aeson.eitherDecodeStrict - |> either (Left . ms) pure - |> Network.fromEither - |> pure +fetchComics = + Ajax.xhrByteString req /> Ajax.contents >>= \case + Nothing -> + pure <| Network.Failure "Could not fetch comics from server." + Just json -> + json + |> Aeson.eitherDecodeStrict + |> either (Left <. ms) pure + |> Network.fromEither + |> pure where req = Ajax.Request @@ -217,16 +227,18 @@ sendLogin :: Auth.Username -> Auth.Password -> IO - ( Network.RemoteData MisoString + ( Network.RemoteData + MisoString User ) -sendLogin u p = Ajax.xhrByteString req /> Ajax.contents >>= \case - Nothing -> - pure $ Network.Failure "Could not send login request." - Just json -> - pure $ Network.fromEither - $ either (Left . ms) pure - $ Aeson.eitherDecodeStrict json +sendLogin u p = + Ajax.xhrByteString req /> Ajax.contents >>= \case + Nothing -> + pure <| Network.Failure "Could not send login request." + Just json -> + pure <| Network.fromEither + <| either (Left <. ms) pure + <| Aeson.eitherDecodeStrict json where req = Ajax.Request diff --git a/Hero/Part.hs b/Hero/Part.hs index fb34fff..4244721 100644 --- a/Hero/Part.hs +++ b/Hero/Part.hs @@ -1,3 +1 @@ module Hero.Part () where - - diff --git a/System/Random/Shuffle.hs b/System/Random/Shuffle.hs index d3cd387..d26361f 100644 --- a/System/Random/Shuffle.hs +++ b/System/Random/Shuffle.hs @@ -16,7 +16,7 @@ -- main = do -- rng <- newStdGen -- let xs = [1,2,3,4,5] --- print $ shuffle' xs (length xs) rng +-- print <| shuffle' xs (length xs) rng module System.Random.Shuffle ( shuffle, shuffle', @@ -48,10 +48,10 @@ data Tree a -- | Convert a sequence (e1...en) to a complete binary tree buildTree :: [a] -> Tree a -buildTree = fix growLevel . map Leaf +buildTree = fix growLevel <. map Leaf where growLevel _ [node] = node - growLevel self l = self $ inner l + growLevel self l = self <| inner l inner [] = [] inner [e] = [e] inner (e1 : e2 : es) = e1 `seq` e2 `seq` join e1 e2 : inner es @@ -92,13 +92,13 @@ shuffle elements = shuffleTree (buildTree elements) -- generator, compute the corresponding permutation of the input -- sequence. shuffle' :: RandomGen gen => [a] -> Int -> gen -> [a] -shuffle' elements len = shuffle elements . rseq len +shuffle' elements len = shuffle elements <. rseq len where -- The sequence (r1,...r[n-1]) of numbers such that r[i] is an -- independent sample from a uniform random distribution -- [0..n-i] rseq :: RandomGen gen => Int -> gen -> [Int] - rseq n = map fst . rseq' (n - 1) + rseq n = map fst <. rseq' (n - 1) where rseq' :: RandomGen gen => Int -> gen -> [(Int, gen)] rseq' 0 _ = [] |