summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Alpha.hs51
-rw-r--r--Biz/Ibb/Client.hs38
-rw-r--r--Biz/Ibb/Core.hs184
-rw-r--r--Biz/Ibb/Influencers.hs908
-rw-r--r--Biz/Ibb/Keep.hs116
-rw-r--r--Biz/Ibb/Look.hs22
-rw-r--r--Biz/Ibb/Move.hs62
-rw-r--r--Biz/Ibb/Server.hs136
-rw-r--r--Biz/Language/Bs.hs5
-rw-r--r--Biz/Language/Bs/Cli.hs46
-rw-r--r--Biz/Language/Bs/Eval.hs183
-rw-r--r--Biz/Language/Bs/Expr.hs157
-rw-r--r--Biz/Language/Bs/Parser.hs84
-rw-r--r--Biz/Language/Bs/Primitives.hs179
-rw-r--r--Biz/Language/Bs/Repl.hs11
-rw-r--r--Control/Concurrent/Go.hs121
-rw-r--r--Control/Concurrent/Sema.hs8
-rw-r--r--Hero/App.hs1012
-rw-r--r--Hero/Assets.hs3
-rw-r--r--Hero/Client.hs259
-rw-r--r--Hero/Database.hs38
-rw-r--r--Hero/Look.hs753
-rw-r--r--Hero/Look/Typography.hs48
-rw-r--r--Hero/Server.hs277
-rw-r--r--Miso/FFI/Audio.hs1
-rw-r--r--Miso/FFI/Document.hs1
-rw-r--r--Miso/FFI/Fullscreen.hs1
-rw-r--r--Network/RemoteData.hs29
-rw-r--r--Que/Server.hs214
-rw-r--r--Que/Website.hs147
-rw-r--r--System/Random/Shuffle.hs196
31 files changed, 2792 insertions, 2498 deletions
diff --git a/Alpha.hs b/Alpha.hs
index fe5c9df..8f823da 100644
--- a/Alpha.hs
+++ b/Alpha.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE NoImplicitPrelude #-}
+
-- | Commonly useful functions, a Prelude replacement.
--
-- This is designed to be imported everywhere, unqualified (generally
@@ -16,32 +17,35 @@
-- It seems unnecessarily different at first but it makes things easier
-- to read quickly.
module Alpha
- (
- -- * Re-export Protolude
- module X
- -- * Applying
- , (<|)
- , (|>)
- -- * Mapping
- , (/>)
- , (</)
- , (<//)
- -- * Text
- , chomp
- , lchomp
- , joinWith
- -- * Debugging tools
- , say
+ ( -- * Re-export Protolude
+ module X,
+
+ -- * Applying
+ (<|),
+ (|>),
+
+ -- * Mapping
+ (/>),
+ (</),
+ (<//),
+
+ -- * Text
+ chomp,
+ lchomp,
+ joinWith,
+
+ -- * Debugging tools
+ say,
)
where
-import Data.Function ( (&) )
-import Data.Functor ( (<&>) )
-import Data.String
-import Data.Text ( Text )
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as LazyText
-import Protolude as X
+import Data.Function ((&))
+import Data.Functor ((<&>))
+import Data.String
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as LazyText
+import Protolude as X
-- | Debugging printf
say :: Text -> IO ()
@@ -61,6 +65,7 @@ say msg = putStrLn msg
-- return value to the function on the left side.
(<|) :: (a -> b) -> a -> b
(<|) = ($)
+
infixr 0 <|
-- | Reverse function application. Do the left side, then pass the
diff --git a/Biz/Ibb/Client.hs b/Biz/Ibb/Client.hs
index e40ff36..89e0ffc 100644
--- a/Biz/Ibb/Client.hs
+++ b/Biz/Ibb/Client.hs
@@ -16,23 +16,25 @@
-- : dep ghcjs-base
module Biz.Ibb.Client where
-import Alpha
-import Biz.Ibb.Core ( Action(..)
- , see
- , init
- )
-import Biz.Ibb.Move ( move )
-import Miso ( App(..)
- , defaultEvents
- , miso
- )
+import Alpha
+import Biz.Ibb.Core
+ ( Action (..),
+ init,
+ see,
+ )
+import Biz.Ibb.Move (move)
+import Miso
+ ( App (..),
+ defaultEvents,
+ miso,
+ )
main :: IO ()
-main = miso $ \u -> App { model = init u, .. }
- where
- initialAction = FetchPeople
- update = move
- view = see
- events = defaultEvents
- subs = []
- mountPoint = Nothing
+main = miso $ \u -> App {model = init u, ..}
+ where
+ initialAction = FetchPeople
+ update = move
+ view = see
+ events = defaultEvents
+ subs = []
+ mountPoint = Nothing
diff --git a/Biz/Ibb/Core.hs b/Biz/Ibb/Core.hs
index fb82ff0..2c1fbae 100644
--- a/Biz/Ibb/Core.hs
+++ b/Biz/Ibb/Core.hs
@@ -1,53 +1,59 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
-- | Main app logic
module Biz.Ibb.Core where
-import Alpha
-import Network.RemoteData
-import Data.Aeson hiding ( Success )
-import Data.Data ( Data
- , Typeable
- )
-import Data.Text ( Text )
-import GHC.Generics ( Generic )
-import Miso
-import Miso.String
-import Servant.API
-import Servant.Links
+import Alpha
+import Data.Aeson hiding (Success)
+import Data.Data
+ ( Data,
+ Typeable,
+ )
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import Miso
+import Miso.String
+import Network.RemoteData
+import Servant.API
+import Servant.Links
-- * entity data types
-data Person = Person
- { _name :: Text
- -- ^ Their full name.
- , _pic :: Text
- -- ^ A link to their picture.
- , _twitter :: Text
- -- ^ Their twitter handle, without the `@` prefix.
- , _website :: Text
- -- ^ Their main website, fully formed: `https://example.com`
- , _books :: [Book]
- -- ^ A short list of the books they recommend.
- , _blurb :: Text
- -- ^ A short "about" section, like you would see on the jacket flap of a book.
- } deriving (Generic, Show, Eq, Typeable, Data, Ord)
+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
- , _amznref :: Text
- -- ^ Amazon REF number, for creating affiliate links.
- } deriving (Generic, Show, Eq, Typeable, Data, Ord)
+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
+
instance ToJSON Book
-- * app data types
@@ -56,10 +62,12 @@ type AppRoutes = Home
type Home = View Action
-data Model = Model
- { uri :: URI
- , people :: WebData [Person]
- } deriving (Show, Eq)
+data Model
+ = Model
+ { uri :: URI,
+ people :: WebData [Person]
+ }
+ deriving (Show, Eq)
type WebData a = RemoteData MisoString a
@@ -87,57 +95,63 @@ goHome :: URI
goHome = linkURI $ safeLink (Proxy :: Proxy AppRoutes) (Proxy :: Proxy Home)
see :: Model -> View Action
-see m = div_
- [class_ "container mt-5"]
- [ div_
- [class_ "jumbotron"]
- [ h1_ [class_ "display-4"] [text "Influenced by books"]
- , p_ [class_ "lead"]
- [text "Influential people and the books that made them."]
- , p_
- [class_ "lead"]
- [ a_
- [href_ "http://eepurl.com/ghBFjv"]
- [ text
- "Get new book recommendations from the world's influencers in your email."
- ]
- ]
+see m =
+ div_
+ [class_ "container mt-5"]
+ [ div_
+ [class_ "jumbotron"]
+ [ h1_ [class_ "display-4"] [text "Influenced by books"],
+ p_
+ [class_ "lead"]
+ [text "Influential people and the books that made them."],
+ p_
+ [class_ "lead"]
+ [ a_
+ [href_ "http://eepurl.com/ghBFjv"]
+ [ text
+ "Get new book recommendations from the world's influencers in your email."
+ ]
+ ]
+ ],
+ div_ [class_ "card-columns"] $ case people m of
+ NotAsked -> [text "Initializing..."]
+ Loading -> [text "Loading..."]
+ Failure err -> [text err]
+ Success ps -> seePerson </ ps
]
- , div_ [class_ "card-columns"] $ case people m of
- NotAsked -> [text "Initializing..."]
- Loading -> [text "Loading..."]
- Failure err -> [text err]
- Success ps -> seePerson </ ps
- ]
seePerson :: Person -> View Action
-seePerson person = div_
- [class_ "card"]
- [ div_ [class_ "card-img"]
- [img_ [class_ "card-img img-fluid", src_ $ ms $ _pic person]]
- , div_
- [class_ "card-body"]
- [ h4_ [class_ "card-title"] [text $ ms $ _name person]
- , h6_
- []
- [ a_
- [ class_ "fab fa-twitter"
- , href_ $ "https://twitter.com/" <> (ms $ _twitter person)
+seePerson person =
+ div_
+ [class_ "card"]
+ [ div_
+ [class_ "card-img"]
+ [img_ [class_ "card-img img-fluid", src_ $ ms $ _pic person]],
+ div_
+ [class_ "card-body"]
+ [ h4_ [class_ "card-title"] [text $ ms $ _name person],
+ h6_
+ []
+ [ a_
+ [ class_ "fab fa-twitter",
+ href_ $ "https://twitter.com/" <> (ms $ _twitter person)
+ ]
+ [],
+ a_ [class_ "fas fa-globe", href_ $ ms $ _website person] []
+ ],
+ p_
+ [class_ "card-text"]
+ [text $ ms $ _blurb person, ul_ [] $ seeBook </ _books person]
]
- []
- , a_ [class_ "fas fa-globe", href_ $ ms $ _website person] []
- ]
- , p_ [class_ "card-text"]
- [text $ ms $ _blurb person, ul_ [] $ seeBook </ _books person]
]
- ]
seeBook :: Book -> View Action
-seeBook book = li_
- []
- [ a_
- [ class_ "text-dark"
- , href_ $ "https://www.amazon.com/dp/" <> (ms $ _amznref book)
- ]
- [text $ ms $ _title book]
- ]
+seeBook book =
+ li_
+ []
+ [ a_
+ [ class_ "text-dark",
+ href_ $ "https://www.amazon.com/dp/" <> (ms $ _amznref book)
+ ]
+ [text $ ms $ _title book]
+ ]
diff --git a/Biz/Ibb/Influencers.hs b/Biz/Ibb/Influencers.hs
index c31e962..cf53cc0 100644
--- a/Biz/Ibb/Influencers.hs
+++ b/Biz/Ibb/Influencers.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
module Biz.Ibb.Influencers where
@@ -8,400 +8,512 @@ import Biz.Ibb.Core
allPeople :: [Person]
allPeople =
- [ Person { _name = "Joe Rogan"
- , _pic = "https://pbs.twimg.com/profile_images/552307347851210752/vrXDcTFC_400x400.jpeg"
- , _twitter = "joerogan"
- , _blurb = "Stand up comic/mixed martial arts fanatic/psychedelic adventurer Host of The Joe Rogan Experience"
- , _website = "http://joerogan.com"
- , _books = [ Book {_title = "Food of the Gods"
- , _author = "Terence McKenna"
- , _amznref = "0553371304"
- }
- , Book { _title = "The War of Art"
- , _author ="Steven Pressfield"
- , _amznref ="B007A4SDCG"
- }
- ]
- }
- , Person { _name = "Beyoncé"
- , _pic = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcTxT84sF19lxdnSiblIXAp-Y4wAigpQn8sZ2GtAerIR_ApiiEJfFQ"
- , _twitter = "Beyonce"
- , _blurb = "American singer, songwriter, actress, record producer and dancer"
- , _website = "http://beyonce.com"
- , _books = [ Book { _title = "What Will It Take To Make A Woman President?"
- , _author = "Marianne Schnall"
- , _amznref = "B00E257Y7G"}
- ]
- }
- , Person { _name = "Barrack Obama"
- , _pic = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcQeLzftR36p0hYI-EKNa5fm7CYDuN-vyz23_R48ocqa8X1nPr6C"
- , _twitter = "BarackObama"
- , _blurb = "Dad, husband, President, citizen. 44th POTUS"
- , _website = "http://barackobama.com"
- , _books = [ Book { _title = "An American Marriage"
- , _author = "Tayari Jones"
- , _amznref = "B01NCUXEFR"}
- , Book { _title = "Americanah"
- , _author = "Chimamanda Ngozi Adichie"
- , _amznref = "B00A9ET4MC"}
- ]
- }
- , Person { _name = "Warren Buffet"
- , _pic = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcQQbmnUykS6zqgzaf44tsq1RAsnHe6H7fapEoSqUwAoJGSFKbAPSw"
- , _twitter = "WarrenBuffett"
- , _blurb = "Chairman and CEO of Berkshire Hathaway"
- , _website = "http://berkshirehathaway.com"
- , _books = [ Book { _title = "The Intelligent Investor"
- , _author = "Benjamin Graham"
- , _amznref = "B000FC12C8"}
- , Book { _title = "Security Analysis"
- , _author = "Benjamin Graham"
- , _amznref = "B0037JO5J8"}
- ]
- }
- , Person { _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"
- , _website = "https://www.gatesnotes.com"
- , _books = [ Book { _title = "Leonardo da Vinci"
- , _author = "Walter Isaacson"
- , _amznref = "1501139169"
- }
- , Book { _title = "Educated"
- , _author = "Tara Wetsover"
- , _amznref = "B072BLVM83"
- }
- ]
- }
- , Person { _name = "Stephen King"
- , _pic = "https://pbs.twimg.com/profile_images/378800000836981162/b683f7509ec792c3e481ead332940cdc_400x400.jpeg"
- , _twitter = "StephenKing"
- , _blurb = "World renowned Author"
- , _website = "https://stephenking.com/"
- , _books = [ Book { _title = "Red Moon"
- , _author = "Benjamin Percy"
- , _amznref = "B008TU2592"
- }
- , Book { _title = "The Marauders"
- , _author = "Tom Cooper"
- , _amznref = "B00MKZBVTM"
- }
- ]
- }
- , Person { _name = "Tobi Lütke"
- , _pic = "https://pbs.twimg.com/profile_images/551403375141457920/28EOlhnM_400x400.jpeg"
- , _twitter = "tobi"
- , _blurb = "Shopify CEO by day, Dad in the evening, hacker at night. - Rails Core alumni; Author of ActiveMerchant, Liquid. Comprehensivist"
- , _website = "https://www.shopify.com"
- , _books = [ Book { _title = "Influence"
- , _author ="Robert B. Cialdini"
- , _amznref = "006124189X"
- }
- , Book { _title = "High Output Management"
- , _author ="Andrew S. Grove"
- , _amznref = "B015VACHOK"
- }
- ]
- }
- , Person { _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."
- , _website = "https://www.quietrev.com"
- , _books = [ Book { _title = "Bird by Bird"
- , _author ="Anne Lamott"
- , _amznref = "0385480016"
- }
- , Book { _title = "Waking Up"
- , _author ="Sam Harris"
- , _amznref = "1451636024"
- }
- ]
- }
- , Person { _name = "Oprah Winfrey"
- , _pic = "https://pbs.twimg.com/profile_images/1013835283698049025/q5ZN4yv3_400x400.jpg"
- , _twitter = "Oprah"
- , _blurb = "Oprah Winfrey is an American media executive, actress, talk show host, television producer and philanthropis"
- , _website = "http://www.oprah.com/index.html"
- , _books = [ Book { _title = "A New Earth"
- , _author ="Eckhart Tolle"
- , _amznref = "B000PC0S5K"
- }
- , Book { _title = "The Poisonwood Bible"
- , _author ="Barbara Kingsolver"
- , _amznref = "B000QTE9WU"
- }
- ]
- }
- , Person { _name = "Patrick Collison"
- , _pic = "https://pbs.twimg.com/profile_images/825622525342199809/_iAaSUQf_400x400.jpg"
- , _twitter = "patrickc"
- , _blurb = "Fallibilist, optimist. Stripe CEO"
- , _website = "https://patrickcollison.com"
- , _books = [ Book { _title = "How Judges Think"
- , _author ="Richard A. Posner"
- , _amznref = "0674048067"
- }
- , Book { _title = "Programmers at Work"
- , _author ="Susan Lammers"
- , _amznref = "1556152116"
- }
- ]
- }
- , Person { _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"
- , _website = "https://www.duolingo.com/"
- , _books = [ Book { _title = "Zero to One"
- , _author ="Peter Thiel"
- , _amznref = "B00J6YBOFQ"
- }
- , Book { _title = "The Hard Thing About Hard Things"
- , _author ="Ben Horowitz"
- , _amznref = "B00DQ845EA"
- }
- ]
- }
- , Person { _name = "Bryan Johnson"
- , _pic = "https://pbs.twimg.com/profile_images/1055165076372475904/vNp60sSl_400x400.jpg"
- , _twitter = "bryan_johnson"
- , _blurb = "Founder of Kernel, OS Fund and Braintree. Trying to go where there is no destination"
- , _website = "https://bryanjohnson.co"
- , _books = [ Book { _title = "A Good Man"
- , _author ="Mark Shriver"
- , _amznref = "B007CLBH0M"
- }
- , Book { _title = "Shackleton"
- , _author ="Nick Bertozzi"
- , _amznref = "1596434511"
- }
- ]
- }
- , Person { _name = "Peter Thiel"
- , _pic = "https://pbs.twimg.com/profile_images/1121220551/Peter_Thiel_400x400.jpg"
- , _twitter = "peterthiel"
- , _blurb = "Technology entrepreneur, investor, philanthropist."
- , _website = "http://zerotoonebook.com"
- , _books = [ Book { _title = "Deceit, Desire, and the Novel"
- , _author ="René Girard"
- , _amznref = "0801818303"
- }
- , Book { _title = "Violence and the Sacred"
- , _author ="René Girard"
- , _amznref = "0801822181"
- }
- ]
- }
- , Person { _name = "Tim Ferris"
- , _pic = "https://pbs.twimg.com/profile_images/49918572/half-face-ice_400x400.jpg"
- , _twitter = "tferriss"
- , _blurb = "Author of 5 #1 NYT/WSJ bestsellers, investor (FB, Uber, Twitter, 50+ more: http://angel.co/tim ), host of The Tim Ferriss Show podcast (300M+ downloads)"
- , _website = "http://tim.blog"
- , _books = [ Book { _title = "10% Happier"
- , _author ="Dan Harris"
- , _amznref = "0062265431"
- }
- , Book { _title = "A Guide to the Good Life"
- , _author ="William Irvine"
- , _amznref = "B0040JHNQG"
- }
- ]
- }
- , Person { _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."
- , _website = "https://www.allenwalton.com"
- , _books = [ Book { _title = "4 Hour Work Week"
- , _author ="Tim Ferris"
- , _amznref = "B002WE46UW"
- }
- , Book { _title = "Choose Yourself"
- , _author ="James Altucher"
- , _amznref = "B00CO8D3G4"
- }
- ]
- }
- , Person { _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."
- , _website = "https://creativeplanning.com"
- , _books = [ Book { _title = "Awareness"
- , _author ="Anthony de Mello SJ"
- , _amznref = "B005GFBP6W"
- }
- , Book { _title = "The Prophet"
- , _author ="Kahlil Gibran"
- , _amznref = "B07NDJ3LMW"
- }
- ]
- }
- , Person { _name = "Adam Robinson"
- , _pic = "https://pbs.twimg.com/profile_images/822708907051077632/y5KyboMV_400x400.jpg"
- , _twitter = "IAmAdamRobinson"
- , _blurb = "Entrepreneur. Systems builder. Wizard. Shaman of global financial markets. Manifester. Didact. Do-gooder. Alchemist. Aphorist. Seeker. Embracer of possibility."
- , _website = "http://robinsonglobalstrategies.com"
- , _books = [ Book { _title = "Wishcraft"
- , _author ="Barbara Sher"
- , _amznref = "0345465180"
- }
- , Book { _title = "You Can Be a Stock Market Genius"
- , _author ="Joel Greenblatt"
- , _amznref = "0684832135"
- }
- ]
- }
- , Person { _name = "Andrew Weil"
- , _pic = "https://pbs.twimg.com/profile_images/987461787422359553/mpoZAmPH_400x400.jpg"
- , _twitter = "DrWeil"
- , _blurb = "A world-renowned leader and pioneer in the field of integrative medicine, a healing oriented approach to health care which encompasses body, mind, and spirit."
- , _website = "https://www.drweil.com"
- , _books = [ Book { _title = "The Way Of Life According To Lao Tzu"
- , _author = "Witter Byner"
- , _amznref = "0399512985"
- }
- , Book { _title = "The Psychology of Romantic Love"
- , _author ="Nathaniel Branden"
- , _amznref = "B0012RMVJI"
- }
- ]
- }
- , Person { _name = "Hubert Joly"
- , _pic = "https://scontent-ort2-2.xx.fbcdn.net/v/t1.0-1/c1.0.193.193a/38444401_2156120597936470_9028564067043770368_n.jpg?_nc_cat=104&_nc_ht=scontent-ort2-2.xx&oh=162142edb167f389a5b585a329e4993a&oe=5CE1D578"
- , _twitter = "BBYCEO"
- , _blurb = "CEO of Best Buy"
- , _website = "https://www.bestbuy.com"
- , _books = [ Book { _title = "Who Says Elephants Can't Dance"
- , _author = "Louis. V. Gerstner"
- , _amznref = "0060523808"
- }
- , Book { _title = "Onward"
- , _author ="Howard Schultz"
- , _amznref = "1609613821"
- }
- ]
- }
- , Person { _name = "Esther Perel"
- , _pic = "https://pbs.twimg.com/profile_images/1091062675151319040/MzxCcgdU_400x400.jpg"
- , _twitter = "EstherPerel"
- , _blurb = "Exploring modern relationships. Author of MatingInCaptivity and TheStateOfAffairsBook. Podcast: WhereShouldWeBegin. Psychotherapist in NYC."
- , _website = "https://www.estherperel.com"
- , _books = [ Book { _title = "Crime And Punishment"
- , _author = "Fyodor Dostoyevsky"
- , _amznref = "B07NL94DFD"
- }
- , Book { _title = "If This Is a Man and The Truce"
- , _author ="Primo Levi"
- , _amznref = "0349100136"
- }
- ]
- }
- , Person { _name ="Neil deGrasse Tyson"
- , _pic = "https://pbs.twimg.com/profile_images/74188698/NeilTysonOriginsA-Crop_400x400.jpg"
- , _twitter = "neiltyson"
- , _blurb = "Astrophysicistthe. Fifth head since 1935 of the world-renowned Hayden Planetarium in New York City and the first occupant of its Frederick P. Rose Directorship. Research associate of the Department of Astrophysics at the American Museum of Natural History."
- , _website = "https://www.haydenplanetarium.org/tyson/"
- , _books = [ Book { _title = "The Prince"
- , _author = "Machiavelli"
- , _amznref = "B07ND3CM16"
- }
- , Book { _title = "The Art of War"
- , _author ="Sun Tzu"
- , _amznref = "1545211957"
- }
- ]
- }
- , Person { _name = "Mark Cuban"
- , _pic = "https://pbs.twimg.com/profile_images/1422637130/mccigartrophy_400x400.jpg"
- , _twitter = "mcuban"
- , _blurb = "Owner of Dallas Mavericks, Shark on ABC’s Shark Tank, chairman and CEO of AXS tv, and investor in an ever-growing portfolio of businesses"
- , _website = "http://markcubancompanies.com/"
- , _books = [ Book { _title = "The Fountainhead"
- , _author = "Ayn Rend"
- , _amznref = "0452273331"
- }
- , Book { _title = "The Gospel of Wealth "
- , _author ="Andrew Carnegie"
- , _amznref = "1409942171"
- }
- ]
- }
- , Person { _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"
- , _website = "https://www.robertherjavec.com/"
- , _books = [ Book { _title = "Why I Run"
- , _author = "Mark Sutcliffe"
- , _amznref = "B007OC9P3A"
- }
- , Book { _title = "Swim with the Sharks Without Being Eaten Alive"
- , _author ="Harvey B. Mackay"
- , _amznref = "006074281X"
- }
- ]
- }
- , Person { _name = "Caterina Fake"
- , _pic = "https://pbs.twimg.com/profile_images/378800000509318185/d968d62d1bc39f2c82d3fa44db478525_400x400.jpeg"
- , _twitter = "Caterina"
- , _blurb = "Host, Should this Exist? Investor, Yes VC. Cofounder: Flickr, Hunch, Sesat School. Etsy. Sundance. Homeschooling, film, literature. Dogs."
- , _website = "https://caterina.net"
- , _books = [ Book { _title = "Growth of the Soil"
- , _author = "Knut Hamsun"
- , _amznref = "0343181967"
- }
- , Book { _title = "The Thousand Autumns of Jacob de Zoet"
- , _author ="David Mitchell"
- , _amznref = "0812976363"
- }
- ]
- }
- , Person { _name = "Daymond John"
- , _pic = "https://pbs.twimg.com/profile_images/1048022980863954944/eZvGANn0_400x400.jpg"
- , _twitter = "TheSharkDaymond"
- , _blurb = "CEO of FUBU, Shark on ABC’s Shark Tank, Author."
- , _website = "https://daymondjohn.com/"
- , _books = [ Book { _title = "Think and Grow Rich"
- , _author = "Napoleon Hill"
- , _amznref = "1585424331"
- }
- , Book { _title = "How to Win Friends & Influence People"
- , _author ="Dale Carnegie"
- , _amznref = "0671027034"
- }
- ]
- }
- , Person { _name = "Kevin O'Leary"
- , _pic = "https://pbs.twimg.com/profile_images/1067383195597889536/cP6tNEt0_400x400.jpg"
- , _twitter = "kevinolearytv"
- , _blurb = "Chairman O'Shares ETFs, 4 time Emmy Award winning Shark Tank's Mr. Wonderful, bestselling author, CNBC contributor, wine maker, guitar dude and photographer."
- , _website = "http://askmrwonderful.eone.libsynpro.com/"
- , _books = [ Book { _title = "Competitive Advantage"
- , _author = "Michael Porter"
- , _amznref = "0684841460"
- }
- , Book { _title = "Secrets of Closing the Sale"
- , _author ="Zig Ziglar"
- , _amznref = "0425081028"
- }
- ]
- }
- , Person { _name = "Alex Rodriguez"
- , _pic = "https://pbs.twimg.com/profile_images/796405335388848128/LbvsjCA3_400x400.jpg"
- , _twitter = "AROD"
- , _blurb = "3-time MVP • 14-time All Star • World Series Champ • CEO of @_ARodCorp• @FoxSports Commentator/Analyst • Special Advisor to the Yankees, @ABCSharkTank and ESPN"
- , _website = "http://www.arodcorp.com/"
- , _books = [ Book { _title = "Blitzscaling"
- , _author = "Reid Hoffman"
- , _amznref = "1524761419"
- }
- , Book { _title = "Measure What Matters"
- , _author ="John Doerr"
- , _amznref = "0525536221"
- }
- ]
- }
+ [ Person
+ { _name = "Joe Rogan",
+ _pic = "https://pbs.twimg.com/profile_images/552307347851210752/vrXDcTFC_400x400.jpeg",
+ _twitter = "joerogan",
+ _blurb = "Stand up comic/mixed martial arts fanatic/psychedelic adventurer Host of The Joe Rogan Experience",
+ _website = "http://joerogan.com",
+ _books =
+ [ Book
+ { _title = "Food of the Gods",
+ _author = "Terence McKenna",
+ _amznref = "0553371304"
+ },
+ Book
+ { _title = "The War of Art",
+ _author = "Steven Pressfield",
+ _amznref = "B007A4SDCG"
+ }
+ ]
+ },
+ Person
+ { _name = "Beyoncé",
+ _pic = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcTxT84sF19lxdnSiblIXAp-Y4wAigpQn8sZ2GtAerIR_ApiiEJfFQ",
+ _twitter = "Beyonce",
+ _blurb = "American singer, songwriter, actress, record producer and dancer",
+ _website = "http://beyonce.com",
+ _books =
+ [ Book
+ { _title = "What Will It Take To Make A Woman President?",
+ _author = "Marianne Schnall",
+ _amznref = "B00E257Y7G"
+ }
+ ]
+ },
+ Person
+ { _name = "Barrack Obama",
+ _pic = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcQeLzftR36p0hYI-EKNa5fm7CYDuN-vyz23_R48ocqa8X1nPr6C",
+ _twitter = "BarackObama",
+ _blurb = "Dad, husband, President, citizen. 44th POTUS",
+ _website = "http://barackobama.com",
+ _books =
+ [ Book
+ { _title = "An American Marriage",
+ _author = "Tayari Jones",
+ _amznref = "B01NCUXEFR"
+ },
+ Book
+ { _title = "Americanah",
+ _author = "Chimamanda Ngozi Adichie",
+ _amznref = "B00A9ET4MC"
+ }
+ ]
+ },
+ Person
+ { _name = "Warren Buffet",
+ _pic = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcQQbmnUykS6zqgzaf44tsq1RAsnHe6H7fapEoSqUwAoJGSFKbAPSw",
+ _twitter = "WarrenBuffett",
+ _blurb = "Chairman and CEO of Berkshire Hathaway",
+ _website = "http://berkshirehathaway.com",
+ _books =
+ [ Book
+ { _title = "The Intelligent Investor",
+ _author = "Benjamin Graham",
+ _amznref = "B000FC12C8"
+ },
+ Book
+ { _title = "Security Analysis",
+ _author = "Benjamin Graham",
+ _amznref = "B0037JO5J8"
+ }
+ ]
+ },
+ Person
+ { _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",
+ _website = "https://www.gatesnotes.com",
+ _books =
+ [ Book
+ { _title = "Leonardo da Vinci",
+ _author = "Walter Isaacson",
+ _amznref = "1501139169"
+ },
+ Book
+ { _title = "Educated",
+ _author = "Tara Wetsover",
+ _amznref = "B072BLVM83"
+ }
+ ]
+ },
+ Person
+ { _name = "Stephen King",
+ _pic = "https://pbs.twimg.com/profile_images/378800000836981162/b683f7509ec792c3e481ead332940cdc_400x400.jpeg",
+ _twitter = "StephenKing",
+ _blurb = "World renowned Author",
+ _website = "https://stephenking.com/",
+ _books =
+ [ Book
+ { _title = "Red Moon",
+ _author = "Benjamin Percy",
+ _amznref = "B008TU2592"
+ },
+ Book
+ { _title = "The Marauders",
+ _author = "Tom Cooper",
+ _amznref = "B00MKZBVTM"
+ }
+ ]
+ },
+ Person
+ { _name = "Tobi Lütke",
+ _pic = "https://pbs.twimg.com/profile_images/551403375141457920/28EOlhnM_400x400.jpeg",
+ _twitter = "tobi",
+ _blurb = "Shopify CEO by day, Dad in the evening, hacker at night. - Rails Core alumni; Author of ActiveMerchant, Liquid. Comprehensivist",
+ _website = "https://www.shopify.com",
+ _books =
+ [ Book
+ { _title = "Influence",
+ _author = "Robert B. Cialdini",
+ _amznref = "006124189X"
+ },
+ Book
+ { _title = "High Output Management",
+ _author = "Andrew S. Grove",
+ _amznref = "B015VACHOK"
+ }
+ ]
+ },
+ Person
+ { _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.",
+ _website = "https://www.quietrev.com",
+ _books =
+ [ Book
+ { _title = "Bird by Bird",
+ _author = "Anne Lamott",
+ _amznref = "0385480016"
+ },
+ Book
+ { _title = "Waking Up",
+ _author = "Sam Harris",
+ _amznref = "1451636024"
+ }
+ ]
+ },
+ Person
+ { _name = "Oprah Winfrey",
+ _pic = "https://pbs.twimg.com/profile_images/1013835283698049025/q5ZN4yv3_400x400.jpg",
+ _twitter = "Oprah",
+ _blurb = "Oprah Winfrey is an American media executive, actress, talk show host, television producer and philanthropis",
+ _website = "http://www.oprah.com/index.html",
+ _books =
+ [ Book
+ { _title = "A New Earth",
+ _author = "Eckhart Tolle",
+ _amznref = "B000PC0S5K"
+ },
+ Book
+ { _title = "The Poisonwood Bible",
+ _author = "Barbara Kingsolver",
+ _amznref = "B000QTE9WU"
+ }
+ ]
+ },
+ Person
+ { _name = "Patrick Collison",
+ _pic = "https://pbs.twimg.com/profile_images/825622525342199809/_iAaSUQf_400x400.jpg",
+ _twitter = "patrickc",
+ _blurb = "Fallibilist, optimist. Stripe CEO",
+ _website = "https://patrickcollison.com",
+ _books =
+ [ Book
+ { _title = "How Judges Think",
+ _author = "Richard A. Posner",
+ _amznref = "0674048067"
+ },
+ Book
+ { _title = "Programmers at Work",
+ _author = "Susan Lammers",
+ _amznref = "1556152116"
+ }
+ ]
+ },
+ Person
+ { _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",
+ _website = "https://www.duolingo.com/",
+ _books =
+ [ Book
+ { _title = "Zero to One",
+ _author = "Peter Thiel",
+ _amznref = "B00J6YBOFQ"
+ },
+ Book
+ { _title = "The Hard Thing About Hard Things",
+ _author = "Ben Horowitz",
+ _amznref = "B00DQ845EA"
+ }
+ ]
+ },
+ Person
+ { _name = "Bryan Johnson",
+ _pic = "https://pbs.twimg.com/profile_images/1055165076372475904/vNp60sSl_400x400.jpg",
+ _twitter = "bryan_johnson",
+ _blurb = "Founder of Kernel, OS Fund and Braintree. Trying to go where there is no destination",
+ _website = "https://bryanjohnson.co",
+ _books =
+ [ Book
+ { _title = "A Good Man",
+ _author = "Mark Shriver",
+ _amznref = "B007CLBH0M"
+ },
+ Book
+ { _title = "Shackleton",
+ _author = "Nick Bertozzi",
+ _amznref = "1596434511"
+ }
+ ]
+ },
+ Person
+ { _name = "Peter Thiel",
+ _pic = "https://pbs.twimg.com/profile_images/1121220551/Peter_Thiel_400x400.jpg",
+ _twitter = "peterthiel",
+ _blurb = "Technology entrepreneur, investor, philanthropist.",
+ _website = "http://zerotoonebook.com",
+ _books =
+ [ Book
+ { _title = "Deceit, Desire, and the Novel",
+ _author = "René Girard",
+ _amznref = "0801818303"
+ },
+ Book
+ { _title = "Violence and the Sacred",
+ _author = "René Girard",
+ _amznref = "0801822181"
+ }
+ ]
+ },
+ Person
+ { _name = "Tim Ferris",
+ _pic = "https://pbs.twimg.com/profile_images/49918572/half-face-ice_400x400.jpg",
+ _twitter = "tferriss",
+ _blurb = "Author of 5 #1 NYT/WSJ bestsellers, investor (FB, Uber, Twitter, 50+ more: http://angel.co/tim ), host of The Tim Ferriss Show podcast (300M+ downloads)",
+ _website = "http://tim.blog",
+ _books =
+ [ Book
+ { _title = "10% Happier",
+ _author = "Dan Harris",
+ _amznref = "0062265431"
+ },
+ Book
+ { _title = "A Guide to the Good Life",
+ _author = "William Irvine",
+ _amznref = "B0040JHNQG"
+ }
+ ]
+ },
+ Person
+ { _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.",
+ _website = "https://www.allenwalton.com",
+ _books =
+ [ Book
+ { _title = "4 Hour Work Week",
+ _author = "Tim Ferris",
+ _amznref = "B002WE46UW"
+ },
+ Book
+ { _title = "Choose Yourself",
+ _author = "James Altucher",
+ _amznref = "B00CO8D3G4"
+ }
+ ]
+ },
+ Person
+ { _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.",
+ _website = "https://creativeplanning.com",
+ _books =
+ [ Book
+ { _title = "Awareness",
+ _author = "Anthony de Mello SJ",
+ _amznref = "B005GFBP6W"
+ },
+ Book
+ { _title = "The Prophet",
+ _author = "Kahlil Gibran",
+ _amznref = "B07NDJ3LMW"
+ }
+ ]
+ },
+ Person
+ { _name = "Adam Robinson",
+ _pic = "https://pbs.twimg.com/profile_images/822708907051077632/y5KyboMV_400x400.jpg",
+ _twitter = "IAmAdamRobinson",
+ _blurb = "Entrepreneur. Systems builder. Wizard. Shaman of global financial markets. Manifester. Didact. Do-gooder. Alchemist. Aphorist. Seeker. Embracer of possibility.",
+ _website = "http://robinsonglobalstrategies.com",
+ _books =
+ [ Book
+ { _title = "Wishcraft",
+ _author = "Barbara Sher",
+ _amznref = "0345465180"
+ },
+ Book
+ { _title = "You Can Be a Stock Market Genius",
+ _author = "Joel Greenblatt",
+ _amznref = "0684832135"
+ }
+ ]
+ },
+ Person
+ { _name = "Andrew Weil",
+ _pic = "https://pbs.twimg.com/profile_images/987461787422359553/mpoZAmPH_400x400.jpg",
+ _twitter = "DrWeil",
+ _blurb = "A world-renowned leader and pioneer in the field of integrative medicine, a healing oriented approach to health care which encompasses body, mind, and spirit.",
+ _website = "https://www.drweil.com",
+ _books =
+ [ Book
+ { _title = "The Way Of Life According To Lao Tzu",
+ _author = "Witter Byner",
+ _amznref = "0399512985"
+ },
+ Book
+ { _title = "The Psychology of Romantic Love",
+ _author = "Nathaniel Branden",
+ _amznref = "B0012RMVJI"
+ }
+ ]
+ },
+ Person
+ { _name = "Hubert Joly",
+ _pic = "https://scontent-ort2-2.xx.fbcdn.net/v/t1.0-1/c1.0.193.193a/38444401_2156120597936470_9028564067043770368_n.jpg?_nc_cat=104&_nc_ht=scontent-ort2-2.xx&oh=162142edb167f389a5b585a329e4993a&oe=5CE1D578",
+ _twitter = "BBYCEO",
+ _blurb = "CEO of Best Buy",
+ _website = "https://www.bestbuy.com",
+ _books =
+ [ Book
+ { _title = "Who Says Elephants Can't Dance",
+ _author = "Louis. V. Gerstner",
+ _amznref = "0060523808"
+ },
+ Book
+ { _title = "Onward",
+ _author = "Howard Schultz",
+ _amznref = "1609613821"
+ }
+ ]
+ },
+ Person
+ { _name = "Esther Perel",
+ _pic = "https://pbs.twimg.com/profile_images/1091062675151319040/MzxCcgdU_400x400.jpg",
+ _twitter = "EstherPerel",
+ _blurb = "Exploring modern relationships. Author of MatingInCaptivity and TheStateOfAffairsBook. Podcast: WhereShouldWeBegin. Psychotherapist in NYC.",
+ _website = "https://www.estherperel.com",
+ _books =
+ [ Book
+ { _title = "Crime And Punishment",
+ _author = "Fyodor Dostoyevsky",
+ _amznref = "B07NL94DFD"
+ },
+ Book
+ { _title = "If This Is a Man and The Truce",
+ _author = "Primo Levi",
+ _amznref = "0349100136"
+ }
+ ]
+ },
+ Person
+ { _name = "Neil deGrasse Tyson",
+ _pic = "https://pbs.twimg.com/profile_images/74188698/NeilTysonOriginsA-Crop_400x400.jpg",
+ _twitter = "neiltyson",
+ _blurb = "Astrophysicistthe. Fifth head since 1935 of the world-renowned Hayden Planetarium in New York City and the first occupant of its Frederick P. Rose Directorship. Research associate of the Department of Astrophysics at the American Museum of Natural History.",
+ _website = "https://www.haydenplanetarium.org/tyson/",
+ _books =
+ [ Book
+ { _title = "The Prince",
+ _author = "Machiavelli",
+ _amznref = "B07ND3CM16"
+ },
+ Book
+ { _title = "The Art of War",
+ _author = "Sun Tzu",
+ _amznref = "1545211957"
+ }
+ ]
+ },
+ Person
+ { _name = "Mark Cuban",
+ _pic = "https://pbs.twimg.com/profile_images/1422637130/mccigartrophy_400x400.jpg",
+ _twitter = "mcuban",
+ _blurb = "Owner of Dallas Mavericks, Shark on ABC’s Shark Tank, chairman and CEO of AXS tv, and investor in an ever-growing portfolio of businesses",
+ _website = "http://markcubancompanies.com/",
+ _books =
+ [ Book
+ { _title = "The Fountainhead",
+ _author = "Ayn Rend",
+ _amznref = "0452273331"
+ },
+ Book
+ { _title = "The Gospel of Wealth ",
+ _author = "Andrew Carnegie",
+ _amznref = "1409942171"
+ }
+ ]
+ },
+ Person
+ { _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",
+ _website = "https://www.robertherjavec.com/",
+ _books =
+ [ Book
+ { _title = "Why I Run",
+ _author = "Mark Sutcliffe",
+ _amznref = "B007OC9P3A"
+ },
+ Book
+ { _title = "Swim with the Sharks Without Being Eaten Alive",
+ _author = "Harvey B. Mackay",
+ _amznref = "006074281X"
+ }
+ ]
+ },
+ Person
+ { _name = "Caterina Fake",
+ _pic = "https://pbs.twimg.com/profile_images/378800000509318185/d968d62d1bc39f2c82d3fa44db478525_400x400.jpeg",
+ _twitter = "Caterina",
+ _blurb = "Host, Should this Exist? Investor, Yes VC. Cofounder: Flickr, Hunch, Sesat School. Etsy. Sundance. Homeschooling, film, literature. Dogs.",
+ _website = "https://caterina.net",
+ _books =
+ [ Book
+ { _title = "Growth of the Soil",
+ _author = "Knut Hamsun",
+ _amznref = "0343181967"
+ },
+ Book
+ { _title = "The Thousand Autumns of Jacob de Zoet",
+ _author = "David Mitchell",
+ _amznref = "0812976363"
+ }
+ ]
+ },
+ Person
+ { _name = "Daymond John",
+ _pic = "https://pbs.twimg.com/profile_images/1048022980863954944/eZvGANn0_400x400.jpg",
+ _twitter = "TheSharkDaymond",
+ _blurb = "CEO of FUBU, Shark on ABC’s Shark Tank, Author.",
+ _website = "https://daymondjohn.com/",
+ _books =
+ [ Book
+ { _title = "Think and Grow Rich",
+ _author = "Napoleon Hill",
+ _amznref = "1585424331"
+ },
+ Book
+ { _title = "How to Win Friends & Influence People",
+ _author = "Dale Carnegie",
+ _amznref = "0671027034"
+ }
+ ]
+ },
+ Person
+ { _name = "Kevin O'Leary",
+ _pic = "https://pbs.twimg.com/profile_images/1067383195597889536/cP6tNEt0_400x400.jpg",
+ _twitter = "kevinolearytv",
+ _blurb = "Chairman O'Shares ETFs, 4 time Emmy Award winning Shark Tank's Mr. Wonderful, bestselling author, CNBC contributor, wine maker, guitar dude and photographer.",
+ _website = "http://askmrwonderful.eone.libsynpro.com/",
+ _books =
+ [ Book
+ { _title = "Competitive Advantage",
+ _author = "Michael Porter",
+ _amznref = "0684841460"
+ },
+ Book
+ { _title = "Secrets of Closing the Sale",
+ _author = "Zig Ziglar",
+ _amznref = "0425081028"
+ }
+ ]
+ },
+ Person
+ { _name = "Alex Rodriguez",
+ _pic = "https://pbs.twimg.com/profile_images/796405335388848128/LbvsjCA3_400x400.jpg",
+ _twitter = "AROD",
+ _blurb = "3-time MVP • 14-time All Star • World Series Champ • CEO of @_ARodCorp• @FoxSports Commentator/Analyst • Special Advisor to the Yankees, @ABCSharkTank and ESPN",
+ _website = "http://www.arodcorp.com/",
+ _books =
+ [ Book
+ { _title = "Blitzscaling",
+ _author = "Reid Hoffman",
+ _amznref = "1524761419"
+ },
+ Book
+ { _title = "Measure What Matters",
+ _author = "John Doerr",
+ _amznref = "0525536221"
+ }
+ ]
+ }
]
diff --git a/Biz/Ibb/Keep.hs b/Biz/Ibb/Keep.hs
index ad6dc5c..d546aae 100644
--- a/Biz/Ibb/Keep.hs
+++ b/Biz/Ibb/Keep.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -9,68 +9,74 @@
-- If this proves useful, maybe we could make it a more general thing. Like
-- `Biz.Keep`. I could wrap all the safecopy stuff in my own template haskell
-- like `$(keep ''MyType)`.
---
module Biz.Ibb.Keep where
-import Biz.Ibb.Core (Person(..), Book(..))
+import Biz.Ibb.Core (Book (..), Person (..))
import qualified Biz.Ibb.Influencers as Influencers
-import Control.Monad.Reader (ask)
-import Control.Monad.State (get, put)
-import Data.Acid (Update, makeAcidic)
+import Control.Monad.Reader (ask)
+import Control.Monad.State (get, put)
+import Data.Acid (Update, makeAcidic)
import qualified Data.Acid as Acid
-import Data.Data (Data, Typeable)
-import Data.IxSet (Indexable(..), IxSet, ixFun, ixSet)
+import Data.Data (Data, Typeable)
+import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet)
import qualified Data.IxSet as IxSet
-import Data.SafeCopy
-import Data.Text (Text)
+import Data.SafeCopy
+import Data.Text (Text)
import qualified Data.Text as Text
-- * Keep
-- | Main database. Need to think of a better name for this.
-data IbbKeep = IbbKeep
- { _people :: IxSet Person
- }
+data IbbKeep
+ = IbbKeep
+ { _people :: IxSet Person
+ }
deriving (Data, Typeable)
$(deriveSafeCopy 0 'base ''IbbKeep)
-- * Index @Person@
-$(deriveSafeCopy 0 'base ''Person)
+$(deriveSafeCopy 0 'base ''Person)
-newtype PersonName =
- PersonName Text deriving (Eq, Ord, Data, Typeable)
+newtype PersonName
+ = PersonName Text
+ deriving (Eq, Ord, Data, Typeable)
-newtype PersonBlurb =
- PersonBlurb Text deriving (Eq, Ord, Data, Typeable)
+newtype PersonBlurb
+ = PersonBlurb Text
+ deriving (Eq, Ord, Data, Typeable)
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 ]
- ]
+ 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]
+ ]
-- | updates the `IbbKeep` with a new `Person`
newPerson :: Text -> Text -> Update IbbKeep Person
newPerson name blurb = do
k <- get
- put $ k { _people = IxSet.insert p (_people k)
- }
+ put $
+ k
+ { _people = IxSet.insert p (_people k)
+ }
return p
- where
- p = Person
- { _name = name
- , _pic = Text.empty
- , _twitter = Text.empty
- , _website = Text.empty
- , _books = []
- , _blurb = blurb
- }
+ where
+ p =
+ Person
+ { _name = name,
+ _pic = Text.empty,
+ _twitter = Text.empty,
+ _website = Text.empty,
+ _books = [],
+ _blurb = blurb
+ }
getPeople :: Int -> Acid.Query IbbKeep [Person]
getPeople n = do
@@ -79,24 +85,27 @@ getPeople n = do
-- * Index @Book@
-$(deriveSafeCopy 0 'base ''Book)
+$(deriveSafeCopy 0 'base ''Book)
-newtype BookTitle =
- BookTitle Text deriving (Eq, Ord, Data, Typeable)
+newtype BookTitle
+ = BookTitle Text
+ deriving (Eq, Ord, Data, Typeable)
-newtype BookAuthor =
- BookAuthor Text deriving (Eq, Ord, Data, Typeable)
+newtype BookAuthor
+ = BookAuthor Text
+ deriving (Eq, Ord, Data, Typeable)
instance Indexable Book where
- empty = ixSet
- [ ixFun $ \b -> [ BookTitle $ _title b ]
- , ixFun $ \b -> [ BookAuthor $ _author b ]
- , ixFun $ \b -> [ _amznref b ]
- ]
+ empty =
+ ixSet
+ [ 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
+-- newBook :: Text -> Text -> Text -> Update IbbKeep Book
+-- newBook title author amznref = do
-- ibbKeep <- get
-- put $ ibbKeep { _books = IxSet.insert b (_books ibbKeep)
-- , _people = _people ibbKeep
@@ -114,9 +123,10 @@ instance Indexable Book where
$(makeAcidic ''IbbKeep ['newPerson, 'getPeople])
initialIbbKeep :: IbbKeep
-initialIbbKeep = IbbKeep
- { _people = IxSet.fromList Influencers.allPeople
- }
+initialIbbKeep =
+ IbbKeep
+ { _people = IxSet.fromList Influencers.allPeople
+ }
openLocal :: String -> IO (Acid.AcidState IbbKeep)
openLocal dir =
diff --git a/Biz/Ibb/Look.hs b/Biz/Ibb/Look.hs
index 5f7ca6b..1ab12c1 100644
--- a/Biz/Ibb/Look.hs
+++ b/Biz/Ibb/Look.hs
@@ -4,12 +4,12 @@
-- | The look and feel of Ibb
module Biz.Ibb.Look where
-import Alpha hiding ( Selector )
-import Clay
-import qualified Clay.Flexbox as Flexbox
-import qualified Clay.Media as Media
-import qualified Clay.Render as Clay
-import qualified Clay.Stylesheet as Stylesheet
+import Alpha hiding (Selector)
+import Clay
+import qualified Clay.Flexbox as Flexbox
+import qualified Clay.Media as Media
+import qualified Clay.Render as Clay
+import qualified Clay.Stylesheet as Stylesheet
main :: Css
main = do
@@ -28,11 +28,11 @@ main = do
fontFamily ["GillSans", "Calibri", "Trebuchet"] [sansSerif]
headings ? do
fontFamily
- [ "Palatino"
- , "Palatino Linotype"
- , "Hoefler Text"
- , "Times New Roman"
- , "Times"
+ [ "Palatino",
+ "Palatino Linotype",
+ "Hoefler Text",
+ "Times New Roman",
+ "Times"
]
[serif]
diff --git a/Biz/Ibb/Move.hs b/Biz/Ibb/Move.hs
index 1e635ac..0dec4e5 100644
--- a/Biz/Ibb/Move.hs
+++ b/Biz/Ibb/Move.hs
@@ -1,34 +1,36 @@
-{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
-- | App update logic
module Biz.Ibb.Move
- ( move
- -- * Server interactions
- , fetchPeople
+ ( move,
+
+ -- * Server interactions
+ fetchPeople,
)
where
-import Alpha
-import Biz.Ibb.Core as Core
-import Network.RemoteData
-import Data.Aeson
-import JavaScript.Web.XMLHttpRequest ( Request(..)
- , Method(GET)
- , RequestData(NoData)
- , contents
- , xhrByteString
- )
-import Miso
-import Miso.String
+import Alpha
+import Biz.Ibb.Core as Core
+import Data.Aeson
+import JavaScript.Web.XMLHttpRequest
+ ( Method (GET),
+ Request (..),
+ RequestData (NoData),
+ contents,
+ xhrByteString,
+ )
+import Miso
+import Miso.String
+import Network.RemoteData
move :: Action -> Model -> Effect Action Model
-move Nop m = noEff m
-move (HandleRoute u) m = m { uri = u } <# pure Nop
+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 FetchPeople m = m <# (SetPeople </ fetchPeople)
-move (SetPeople ps) m = noEff m { people = ps }
+move FetchPeople m = m <# (SetPeople </ fetchPeople)
+move (SetPeople ps) m = noEff m {people = ps}
fetchPeople :: IO (WebData [Core.Person])
fetchPeople = do
@@ -37,12 +39,14 @@ fetchPeople = do
Nothing -> pure $ Failure "could not read from server"
Just a ->
pure $ fromEither $ either (Left . ms) pure $ eitherDecodeStrict a
- where
- req = Request { reqMethod = GET
- -- FIXME: can replace this hardcoding with a function?
- , reqURI = "/api/people"
- , reqLogin = Nothing
- , reqHeaders = []
- , reqWithCredentials = False
- , reqData = NoData
- }
+ where
+ req =
+ Request
+ { reqMethod = GET,
+ -- FIXME: can replace this hardcoding with a function?
+ reqURI = "/api/people",
+ reqLogin = Nothing,
+ reqHeaders = [],
+ reqWithCredentials = False,
+ reqData = NoData
+ }
diff --git a/Biz/Ibb/Server.hs b/Biz/Ibb/Server.hs
index 9f1ac5f..b5a7464 100644
--- a/Biz/Ibb/Server.hs
+++ b/Biz/Ibb/Server.hs
@@ -1,11 +1,11 @@
{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE NoImplicitPrelude #-}
-- | Server
--
@@ -27,41 +27,43 @@
-- : dep text
module Biz.Ibb.Server where
-import Alpha
+import Alpha
+import Biz.Ibb.Core
+import qualified Biz.Ibb.Keep as Keep
+import qualified Biz.Ibb.Look as Look
import qualified Clay
-import Biz.Ibb.Core
-import qualified Biz.Ibb.Keep as Keep
-import qualified Biz.Ibb.Look as Look
-import Network.RemoteData
-import Data.Acid ( AcidState )
-import qualified Data.Acid.Abstract as Acid
-import Data.Maybe ( fromMaybe )
-import qualified Data.Text.Lazy as Lazy
-import qualified Data.Text.Lazy.Encoding as Lazy
-import qualified Lucid as L
-import Lucid.Base
-import Miso
-import Network.HTTP.Media ( (//)
- , (/:)
- )
-import Network.HTTP.Types
-import Network.Wai
-import Network.Wai.Application.Static
-import Network.Wai.Handler.Warp
-import Network.Wai.Middleware.Gzip
-import Network.Wai.Middleware.RequestLogger
-import Servant
-import System.Environment ( lookupEnv )
+import Data.Acid (AcidState)
+import qualified Data.Acid.Abstract as Acid
+import Data.Maybe (fromMaybe)
+import qualified Data.Text.Lazy as Lazy
+import qualified Data.Text.Lazy.Encoding as Lazy
+import qualified Lucid as L
+import Lucid.Base
+import Miso
+import Network.HTTP.Media
+ ( (//),
+ (/:),
+ )
+import Network.HTTP.Types
+import Network.RemoteData
+import Network.Wai
+import Network.Wai.Application.Static
+import Network.Wai.Handler.Warp
+import Network.Wai.Middleware.Gzip
+import Network.Wai.Middleware.RequestLogger
+import Servant
+import System.Environment (lookupEnv)
main :: IO ()
main = do
say "rise: ibb"
staticDir <- fromMaybe "static" <$> lookupEnv "STATIC_DIR" :: IO [Char]
- port <- read <$> fromMaybe "3000" <$> lookupEnv "PORT" :: IO Int
- keep <- Keep.openLocal "_keep/"
+ port <- read <$> fromMaybe "3000" <$> lookupEnv "PORT" :: IO Int
+ keep <- Keep.openLocal "_keep/"
say "port: 3000"
run port $ logStdout $ compress $ app staticDir $ keep
- where compress = gzip def { gzipFiles = GzipCompress }
+ where
+ compress = gzip def {gzipFiles = GzipCompress}
newtype HtmlPage a = HtmlPage a
deriving (Show, Eq)
@@ -75,18 +77,20 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where
cssRef "/css/main.css"
L.body_ $ do
page
- where
- page = L.toHtml x
- jsRef href = L.with
- (L.script_ mempty)
- [ makeAttribute "src" href
- , makeAttribute "type" "text/javascript"
- , makeAttribute "async" mempty
- , makeAttribute "defer" mempty
- ]
- cssRef href = L.with
- (L.link_ mempty)
- [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]
+ where
+ page = L.toHtml x
+ jsRef href =
+ L.with
+ (L.script_ mempty)
+ [ makeAttribute "src" href,
+ makeAttribute "type" "text/javascript",
+ makeAttribute "async" mempty,
+ makeAttribute "defer" mempty
+ ]
+ cssRef href =
+ L.with
+ (L.link_ mempty)
+ [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]
type ServerRoutes = ToServerRoutes AppRoutes HtmlPage Action
@@ -99,9 +103,10 @@ handle404 _ respond =
$ HtmlPage
$ notfound
-newtype CSS = CSS
- { unCSS :: Text
- }
+newtype CSS
+ = CSS
+ { unCSS :: Text
+ }
instance MimeRender CSS Text where
mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict
@@ -111,41 +116,36 @@ instance Accept CSS where
type CssRoute = "css" :> "main.css" :> Get '[CSS] Text
-type Routes
- = "static"
- :>
- Raw
- :<|>
- CssRoute
- :<|>
- ServerRoutes
- :<|>
- "api"
- :>
- ApiRoutes
- :<|>
- Raw
+type Routes =
+ "static"
+ :> Raw
+ :<|> CssRoute
+ :<|> ServerRoutes
+ :<|> "api"
+ :> ApiRoutes
+ :<|> Raw
cssHandlers :: Server CssRoute
cssHandlers = return . Lazy.toStrict . Clay.render $ Look.main
app :: [Char] -> AcidState Keep.IbbKeep -> Application
app staticDir keep =
- serve (Proxy @Routes)
- $ static
- :<|> cssHandlers
- :<|> serverHandlers
- :<|> apiHandlers keep
- :<|> Tagged handle404
- where static = serveDirectoryWith (defaultWebAppSettings $ staticDir)
+ serve (Proxy @Routes) $
+ static
+ :<|> cssHandlers
+ :<|> serverHandlers
+ :<|> apiHandlers keep
+ :<|> Tagged handle404
+ where
+ static = serveDirectoryWith (defaultWebAppSettings $ staticDir)
type ApiRoutes = "people" :> Get '[JSON] [Person]
serverHandlers :: Server ServerRoutes
serverHandlers = homeHandler
- where
- send f u = pure $ HtmlPage $ f Model { uri = u, people = NotAsked }
- homeHandler = send home goHome
+ where
+ 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
diff --git a/Biz/Language/Bs.hs b/Biz/Language/Bs.hs
index a810706..f2d4c9d 100644
--- a/Biz/Language/Bs.hs
+++ b/Biz/Language/Bs.hs
@@ -1,8 +1,9 @@
-- https://github.com/write-you-a-scheme-v2/scheme
-- https://github.com/justinethier/husk-scheme
module Language.Bs
- ( module X
- ) where
+ ( module X,
+ )
+where
import Language.Bs.Cli as X
import Language.Bs.Eval as X
diff --git a/Biz/Language/Bs/Cli.hs b/Biz/Language/Bs/Cli.hs
index 4c48c86..d2ac1e4 100644
--- a/Biz/Language/Bs/Cli.hs
+++ b/Biz/Language/Bs/Cli.hs
@@ -1,8 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
-module Language.Bs.Cli (
- run
-) where
+
+module Language.Bs.Cli
+ ( run,
+ )
+where
import Data.String
import Data.Text.IO as TIO
@@ -17,12 +19,12 @@ import System.Directory
-- https://github.com/pcapriotti/optparse-applicative
-- https://hackage.haskell.org/package/optparse-applicative
-runScript :: FilePath -> IO ()
+runScript :: FilePath -> IO ()
runScript fname = do
exists <- doesFileExist fname
if exists
- then TIO.readFile fname >>= evalFile fname
- else TIO.putStrLn "File does not exist."
+ then TIO.readFile fname >>= evalFile fname
+ else TIO.putStrLn "File does not exist."
data LineOpts = UseReplLineOpts | RunScriptLineOpts String
@@ -30,14 +32,21 @@ parseLineOpts :: Parser LineOpts
parseLineOpts = runScriptOpt <|> runReplOpt
where
runScriptOpt =
- RunScriptLineOpts <$> strOption (long "script"
- <> short 's'
- <> metavar "SCRIPT"
- <> help "File containing the script you want to run")
+ RunScriptLineOpts
+ <$> strOption
+ ( long "script"
+ <> short 's'
+ <> metavar "SCRIPT"
+ <> help "File containing the script you want to run"
+ )
runReplOpt =
- UseReplLineOpts <$ flag' () (long "repl"
- <> short 'r'
- <> help "Run as interavtive read/evaluate/print/loop")
+ UseReplLineOpts
+ <$ flag'
+ ()
+ ( long "repl"
+ <> short 'r'
+ <> help "Run as interavtive read/evaluate/print/loop"
+ )
schemeEntryPoint :: LineOpts -> IO ()
schemeEntryPoint UseReplLineOpts = mainLoop --repl
@@ -46,7 +55,10 @@ schemeEntryPoint (RunScriptLineOpts script) = runScript script
run :: IO ()
run = execParser opts >>= schemeEntryPoint
where
- opts = info (helper <*> parseLineOpts)
- ( fullDesc
- <> header "Executable binary for Write You A Scheme v2.0"
- <> progDesc "contains an entry point for both running scripts and repl" )
+ opts =
+ info
+ (helper <*> parseLineOpts)
+ ( fullDesc
+ <> header "Executable binary for Write You A Scheme v2.0"
+ <> progDesc "contains an entry point for both running scripts and repl"
+ )
diff --git a/Biz/Language/Bs/Eval.hs b/Biz/Language/Bs/Eval.hs
index 290170b..1198a3e 100644
--- a/Biz/Language/Bs/Eval.hs
+++ b/Biz/Language/Bs/Eval.hs
@@ -1,19 +1,21 @@
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
-module Language.Bs.Eval (
- evalText
-, evalFile
-, runParseTest
-, safeExec
-, runASTinEnv
-, basicEnv
-, fileToEvalForm
-, textToEvalForm
-, getFileContents
-) where
+
+module Language.Bs.Eval
+ ( evalText,
+ evalFile,
+ runParseTest,
+ safeExec,
+ runASTinEnv,
+ basicEnv,
+ fileToEvalForm,
+ textToEvalForm,
+ getFileContents,
+ )
+where
import Control.Exception
import Control.Monad.Reader
@@ -28,23 +30,25 @@ import Protolude
import System.Directory
funcEnv :: Map.Map T.Text Expr
-funcEnv = Map.fromList $ primEnv
- <> [ ("read" , IFun $ IFunc $ unop readFn)
- , ("parse", IFun $ IFunc $ unop parseFn)
- , ("eval", IFun $ IFunc $ unop eval)
- , ("show", IFun $ IFunc $ unop (return . Tape . ppexpr))
- ]
+funcEnv =
+ Map.fromList $
+ primEnv
+ <> [ ("read", IFun $ IFunc $ unop readFn),
+ ("parse", IFun $ IFunc $ unop parseFn),
+ ("eval", IFun $ IFunc $ unop eval),
+ ("show", IFun $ IFunc $ unop (return . Tape . ppexpr))
+ ]
basicEnv :: Env
basicEnv = Env Map.empty funcEnv
readFn :: Expr -> Eval Expr
readFn (Tape txt) = lineToEvalForm txt
-readFn val = throw $ TypeMismatch "read expects string, instead got:" val
+readFn val = throw $ TypeMismatch "read expects string, instead got:" val
parseFn :: Expr -> Eval Expr
parseFn (Tape txt) = either (throw . ParseError . show) return $ readExpr txt
-parseFn val = throw $ TypeMismatch "parse expects string, instead got:" val
+parseFn val = throw $ TypeMismatch "parse expects string, instead got:" val
safeExec :: IO a -> IO (Either String a)
safeExec m = do
@@ -63,13 +67,13 @@ runASTinEnv :: Env -> Eval b -> IO b
runASTinEnv code action = runReaderT (unEval action) code
lineToEvalForm :: T.Text -> Eval Expr
-lineToEvalForm input = either (throw . ParseError . show ) eval $ readExpr input
+lineToEvalForm input = either (throw . ParseError . show) eval $ readExpr input
evalFile :: FilePath -> T.Text -> IO () -- program file
evalFile filePath fileExpr = (runASTinEnv basicEnv $ fileToEvalForm filePath fileExpr) >>= print
fileToEvalForm :: FilePath -> T.Text -> Eval Expr
-fileToEvalForm filePath input = either (throw . ParseError . show ) evalBody $ readExprFile filePath input
+fileToEvalForm filePath input = either (throw . ParseError . show) evalBody $ readExprFile filePath input
runParseTest :: T.Text -> T.Text -- for view AST
runParseTest input = either (T.pack . show) (T.pack . show) $ readExpr input
@@ -77,23 +81,23 @@ runParseTest input = either (T.pack . show) (T.pack . show) $ readExpr input
getFileContents :: FilePath -> IO T.Text
getFileContents fname = do
exists <- doesFileExist fname
- if exists then TIO.readFile fname else return "File does not exist."
+ if exists then TIO.readFile fname else return "File does not exist."
textToEvalForm :: T.Text -> Eval Expr
-textToEvalForm input = either (throw . ParseError . show ) evalBody $ readExpr input
+textToEvalForm input = either (throw . ParseError . show) evalBody $ readExpr input
evalText :: T.Text -> IO () --REPL
evalText textExpr = do
res <- runASTinEnv basicEnv $ textToEvalForm textExpr
print res
-getVar :: Expr -> Eval Expr
+getVar :: Expr -> Eval Expr
getVar (Atom atom) = do
- Env{..} <- ask
+ Env {..} <- ask
case Map.lookup atom (Map.union fenv env) of -- lookup, but prefer functions
- Just x -> return x
- Nothing -> throw $ UnboundVar atom
-getVar n = throw $ TypeMismatch "failure to get variable: " n
+ Just x -> return x
+ Nothing -> throw $ UnboundVar atom
+getVar n = throw $ TypeMismatch "failure to get variable: " n
ensureAtom :: Expr -> Eval Expr
ensureAtom n@(Atom _) = return n
@@ -106,136 +110,115 @@ extractVar n = throw $ TypeMismatch "expected an atomic value" n
getEven :: [t] -> [t]
getEven [] = []
-getEven (x:xs) = x : getOdd xs
+getEven (x : xs) = x : getOdd xs
getOdd :: [t] -> [t]
getOdd [] = []
-getOdd (_:xs) = getEven xs
+getOdd (_ : xs) = getEven xs
applyFunc :: Expr -> [Expr] -> [Expr] -> Eval Expr
applyFunc expr params args = bindArgsEval params args expr
bindArgsEval :: [Expr] -> [Expr] -> Expr -> Eval Expr
bindArgsEval params args expr = do
- Env{..} <- ask
- let newVars = zipWith (\a b -> (extractVar a,b)) params args
+ Env {..} <- ask
+ let newVars = zipWith (\a b -> (extractVar a, b)) params args
let (newEnv, newFenv) = Map.partition (not . isFunc) $ Map.fromList newVars
local (const $ Env (newEnv <> env) (newFenv <> fenv)) $ eval expr
isFunc :: Expr -> Bool
-isFunc (List ((Atom "lambda"):_)) = True
-isFunc _ = False
+isFunc (List ((Atom "lambda") : _)) = True
+isFunc _ = False
eval :: Expr -> Eval Expr
eval (List [Atom "dumpEnv", x]) = do
- Env{..} <- ask
+ Env {..} <- ask
liftIO $ print $ toList env
liftIO $ print $ toList fenv
eval x
-
-eval (Numb i) = return $ Numb i
-eval (Tape s) = return $ Tape s
-eval (Bool b) = return $ Bool b
-eval (List []) = return Nil
-eval Nil = return Nil
+eval (Numb i) = return $ Numb i
+eval (Tape s) = return $ Tape s
+eval (Bool b) = return $ Bool b
+eval (List []) = return Nil
+eval Nil = return Nil
eval n@(Atom _) = getVar n
-
-eval (List [Atom "showSF", rest]) = return . Tape . T.pack $ show rest
+eval (List [Atom "showSF", rest]) = return . Tape . T.pack $ show rest
eval (List ((:) (Atom "showSF") rest)) = return . Tape . T.pack . show $ List rest
-
eval (List [Atom "quote", val]) = return val
-
eval (List [Atom "if", pred_, then_, else_]) = do
ifRes <- eval pred_
case ifRes of
- (Bool True) -> eval then_
+ (Bool True) -> eval then_
(Bool False) -> eval else_
_ ->
throw $ BadSpecialForm "if's first arg must eval into a boolean"
-eval (List ( (:) (Atom "if") _)) =
+eval (List ((:) (Atom "if") _)) =
throw $ BadSpecialForm "(if <bool> <s-expr> <s-expr>)"
-
eval (List [Atom "begin", rest]) = evalBody rest
-eval (List ((:) (Atom "begin") rest )) = evalBody $ List rest
-
+eval (List ((:) (Atom "begin") rest)) = evalBody $ List rest
-- top-level define
-- TODO: how to make this eval correctly?
-eval (List [Atom "define", List (name:args), body]) = do
- Env{..} <- ask
+eval (List [Atom "define", List (name : args), body]) = do
+ Env {..} <- ask
_ <- eval body
- bindArgsEval (name:args) [body] name
-
+ bindArgsEval (name : args) [body] name
eval (List [Atom "define", name, body]) = do
- Env{..} <- ask
+ Env {..} <- ask
_ <- eval body
bindArgsEval [name] [body] name
-
eval (List [Atom "let", List pairs, expr]) = do
- Env{..} <- ask
+ Env {..} <- ask
atoms <- mapM ensureAtom $ getEven pairs
- vals <- mapM eval $ getOdd pairs
+ vals <- mapM eval $ getOdd pairs
bindArgsEval atoms vals expr
-
-eval (List (Atom "let":_) ) =
+eval (List (Atom "let" : _)) =
throw $ BadSpecialForm "let function expects list of parameters and S-Expression body\n(let <pairs> <s-expr>)"
-
-
eval (List [Atom "lambda", List params, expr]) = do
ctx <- ask
- return $ Func (IFunc $ applyFunc expr params) ctx
-eval (List (Atom "lambda":_) ) = throw $ BadSpecialForm "lambda function expects list of parameters and S-Expression body\n(lambda <params> <s-expr>)"
-
-
+ return $ Func (IFunc $ applyFunc expr params) ctx
+eval (List (Atom "lambda" : _)) = throw $ BadSpecialForm "lambda function expects list of parameters and S-Expression body\n(lambda <params> <s-expr>)"
-- needed to get cadr, etc to work
-eval (List [Atom "cdr", List [Atom "quote", List (_:xs)]]) =
+eval (List [Atom "cdr", List [Atom "quote", List (_ : xs)]]) =
return $ List xs
-eval (List [Atom "cdr", arg@(List (x:xs))]) =
+eval (List [Atom "cdr", arg@(List (x : xs))]) =
case x of
- -- proxy for if the list can be evaluated
- Atom _ -> do
- val <- eval arg
- eval $ List [Atom "cdr", val]
- _ -> return $ List xs
-
-
-eval (List [Atom "car", List [Atom "quote", List (x:_)]]) =
- return $ x
-eval (List [Atom "car", arg@(List (x:_))]) =
+ -- proxy for if the list can be evaluated
+ Atom _ -> do
+ val <- eval arg
+ eval $ List [Atom "cdr", val]
+ _ -> return $ List xs
+eval (List [Atom "car", List [Atom "quote", List (x : _)]]) =
+ return $ x
+eval (List [Atom "car", arg@(List (x : _))]) =
case x of
- Atom _ -> do
- val <- eval arg
- eval $ List [Atom "car", val]
- _ -> return $ x
-
-
+ Atom _ -> do
+ val <- eval arg
+ eval $ List [Atom "car", val]
+ _ -> return $ x
eval (List ((:) x xs)) = do
- Env{..} <- ask
+ Env {..} <- ask
funVar <- eval x
xVal <- mapM eval xs
case funVar of
- (IFun (IFunc internalFn)) ->
- internalFn xVal
-
- (Func (IFunc definedFn) (Env benv _)) ->
- local (const $ Env benv fenv) $ definedFn xVal
-
- _ ->
- throw $ NotFunction funVar
+ (IFun (IFunc internalFn)) ->
+ internalFn xVal
+ (Func (IFunc definedFn) (Env benv _)) ->
+ local (const $ Env benv fenv) $ definedFn xVal
+ _ ->
+ throw $ NotFunction funVar
updateEnv :: T.Text -> Expr -> Env -> Env
-updateEnv var e@(IFun _) Env{..} = Env env $ Map.insert var e fenv
-updateEnv var e@(Func _ _) Env{..} = Env env $ Map.insert var e fenv
-updateEnv var e Env{..} = Env (Map.insert var e env) fenv
+updateEnv var e@(IFun _) Env {..} = Env env $ Map.insert var e fenv
+updateEnv var e@(Func _ _) Env {..} = Env env $ Map.insert var e fenv
+updateEnv var e Env {..} = Env (Map.insert var e env) fenv
evalBody :: Expr -> Eval Expr
evalBody (List [List ((:) (Atom "define") [Atom var, defExpr]), rest]) = do
evalVal <- eval defExpr
ctx <- ask
local (const $ updateEnv var evalVal ctx) $ eval rest
-
evalBody (List ((:) (List ((:) (Atom "define") [Atom var, defExpr])) rest)) = do
evalVal <- eval defExpr
ctx <- ask
local (const $ updateEnv var evalVal ctx) $ evalBody $ List rest
-
evalBody x = eval x
diff --git a/Biz/Language/Bs/Expr.hs b/Biz/Language/Bs/Expr.hs
index a39c7b6..2452622 100644
--- a/Biz/Language/Bs/Expr.hs
+++ b/Biz/Language/Bs/Expr.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
module Language.Bs.Expr where
import Data.String (String)
@@ -13,17 +14,18 @@ import qualified Text.PrettyPrint.Leijen.Text as PP
import Text.PrettyPrint.Leijen.Text hiding ((<$>))
type Ctx = Map Text Expr
-data Env = Env { env :: Ctx, fenv :: Ctx }
- deriving (Eq)
-newtype Eval a = Eval { unEval :: ReaderT Env IO a }
- deriving (Monad, Functor, Applicative, MonadReader Env, MonadIO)
+data Env = Env {env :: Ctx, fenv :: Ctx}
+ deriving (Eq)
+
+newtype Eval a = Eval {unEval :: ReaderT Env IO a}
+ deriving (Monad, Functor, Applicative, MonadReader Env, MonadIO)
-data IFunc = IFunc { fn :: [Expr] -> Eval Expr }
- deriving (Typeable)
+data IFunc = IFunc {fn :: [Expr] -> Eval Expr}
+ deriving (Typeable)
instance Eq IFunc where
- (==) _ _ = False
+ (==) _ _ = False
data Expr
= Atom Text
@@ -37,7 +39,7 @@ data Expr
deriving (Typeable, Eq)
instance Show Expr where
- show = T.unpack . ppexpr
+ show = T.unpack . ppexpr
data LispErrorType
= NumArgs Integer [Expr]
@@ -55,12 +57,13 @@ data LispErrorType
data LispError = LispError Expr LispErrorType
instance Show LispErrorType where
- show = T.unpack . ppexpr
+ show = T.unpack . ppexpr
instance Show LispError where
- show = T.unpack . ppexpr
+ show = T.unpack . ppexpr
instance Exception LispErrorType
+
instance Exception LispError
ppexpr :: Pretty a => a -> Text
@@ -70,85 +73,67 @@ ppexpr x = PP.displayTStrict (PP.renderPretty 1.0 70 (pretty x))
--prettyList = encloseSep lparen rparen PP.space
instance Pretty Expr where
- pretty v =
- case v of
- Atom a ->
- textStrict a
-
- List ls ->
- prettyList $ fmap pretty ls
-
- Numb n ->
- integer n
-
- Tape t ->
- textStrict "\"" <> textStrict t <> textStrict "\""
-
- IFun _ ->
- textStrict "<internal function>"
-
- Func _ _ ->
- textStrict "<lambda function>"
-
- Bool True ->
- textStrict "#t"
-
- Bool False ->
- textStrict "#f"
-
- Nil ->
- textStrict "'()"
+ pretty v =
+ case v of
+ Atom a ->
+ textStrict a
+ List ls ->
+ prettyList $ fmap pretty ls
+ Numb n ->
+ integer n
+ Tape t ->
+ textStrict "\"" <> textStrict t <> textStrict "\""
+ IFun _ ->
+ textStrict "<internal function>"
+ Func _ _ ->
+ textStrict "<lambda function>"
+ Bool True ->
+ textStrict "#t"
+ Bool False ->
+ textStrict "#f"
+ Nil ->
+ textStrict "'()"
instance Pretty LispErrorType where
pretty err = case err of
- NumArgs i args ->
- textStrict "number of arguments"
- <$$> textStrict "expected"
- <+> textStrict (T.pack $ show i)
- <$$> textStrict "received"
- <+> textStrict (T.pack $ show $ length args)
-
-
- LengthOfList txt i ->
- textStrict "length of list in:"
- <+> textStrict txt
- <$$> textStrict "length:"
- <+> textStrict (T.pack $ show i)
-
- ParseError txt ->
- textStrict "cannot parse expr:"
- <+> textStrict (T.pack txt)
-
- TypeMismatch txt expr ->
- textStrict "type mismatch:"
- <$$> textStrict txt
- <$$> pretty expr
-
- BadSpecialForm txt ->
- textStrict "bad special form:"
- <$$> textStrict txt
-
- NotFunction expr ->
- textStrict "not a function"
- <$$> pretty expr
-
- UnboundVar txt ->
- textStrict "unbound variable:"
- <$$> textStrict txt
-
- Default _ ->
- textStrict "default error"
-
- ReadFileError txt ->
- textStrict "error reading file:"
- <$$> textStrict txt
-
- ExpectedList txt ->
- textStrict "expected list:"
- <$$> textStrict txt
+ NumArgs i args ->
+ textStrict "number of arguments"
+ <$$> textStrict "expected"
+ <+> textStrict (T.pack $ show i)
+ <$$> textStrict "received"
+ <+> textStrict (T.pack $ show $ length args)
+ LengthOfList txt i ->
+ textStrict "length of list in:"
+ <+> textStrict txt
+ <$$> textStrict "length:"
+ <+> textStrict (T.pack $ show i)
+ ParseError txt ->
+ textStrict "cannot parse expr:"
+ <+> textStrict (T.pack txt)
+ TypeMismatch txt expr ->
+ textStrict "type mismatch:"
+ <$$> textStrict txt
+ <$$> pretty expr
+ BadSpecialForm txt ->
+ textStrict "bad special form:"
+ <$$> textStrict txt
+ NotFunction expr ->
+ textStrict "not a function"
+ <$$> pretty expr
+ UnboundVar txt ->
+ textStrict "unbound variable:"
+ <$$> textStrict txt
+ Default _ ->
+ textStrict "default error"
+ ReadFileError txt ->
+ textStrict "error reading file:"
+ <$$> textStrict txt
+ ExpectedList txt ->
+ textStrict "expected list:"
+ <$$> textStrict txt
instance Pretty LispError where
pretty (LispError expr typ) =
- textStrict "error evaluating:"
+ textStrict "error evaluating:"
<$$> indent 4 (pretty expr)
<$$> pretty typ
diff --git a/Biz/Language/Bs/Parser.hs b/Biz/Language/Bs/Parser.hs
index 3044a60..574536d 100644
--- a/Biz/Language/Bs/Parser.hs
+++ b/Biz/Language/Bs/Parser.hs
@@ -1,10 +1,12 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
-module Language.Bs.Parser (
- readExpr
-, readExprFile
-) where
+
+module Language.Bs.Parser
+ ( readExpr,
+ readExprFile,
+ )
+where
import Control.Monad (fail)
import Control.Monad (mzero)
@@ -23,15 +25,16 @@ lexer :: Tok.GenTokenParser T.Text () Identity
lexer = Tok.makeTokenParser style
style :: Tok.GenLanguageDef T.Text () Identity
-style = Lang.emptyDef {
- Tok.commentStart = "#|"
- , Tok.commentEnd = "|#"
- , Tok.commentLine = ";"
- , Tok.opStart = mzero
- , Tok.opLetter = mzero
- , Tok.identStart = letter <|> oneOf "!$%&*/:<=>?^_~"
- , Tok.identLetter = digit <|> letter <|> oneOf "!$%&*/:<=>?^_~+-.@"
- }
+style =
+ Lang.emptyDef
+ { Tok.commentStart = "#|",
+ Tok.commentEnd = "|#",
+ Tok.commentLine = ";",
+ Tok.opStart = mzero,
+ Tok.opLetter = mzero,
+ Tok.identStart = letter <|> oneOf "!$%&*/:<=>?^_~",
+ Tok.identLetter = digit <|> letter <|> oneOf "!$%&*/:<=>?^_~+-.@"
+ }
parens :: Parser a -> Parser a
parens = Tok.parens lexer
@@ -48,9 +51,10 @@ quoted p = try (char '\'') *> p
identifier :: Parser T.Text
identifier = T.pack <$> (Tok.identifier lexer <|> specialIdentifier) <?> "identifier"
where
- specialIdentifier :: Parser String
- specialIdentifier = lexeme $ try $
- string "-" <|> string "+" <|> string "..."
+ specialIdentifier :: Parser String
+ specialIdentifier =
+ lexeme $ try $
+ string "-" <|> string "+" <|> string "..."
-- | The @Radix@ type consists of a base integer (e.g. @10@) and a parser for
-- digits in that base (e.g. @digit@).
@@ -61,7 +65,7 @@ type Radix = (Integer, Parser Char)
numberWithRadix :: Radix -> Parser Integer
numberWithRadix (base, baseDigit) = do
digits <- many1 baseDigit
- let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits
+ let n = foldl (\x d -> base * x + toInteger (digitToInt d)) 0 digits
seq n (return n)
decimal :: Parser Integer
@@ -70,9 +74,10 @@ decimal = Tok.decimal lexer
-- | Parse a sign, return either @id@ or @negate@ based on the sign parsed.
-- Copied from Text.Parsec.Token
sign :: Parser (Integer -> Integer)
-sign = char '-' *> return negate
- <|> char '+' *> return identity
- <|> return identity
+sign =
+ char '-' *> return negate
+ <|> char '+' *> return identity
+ <|> return identity
intRadix :: Radix -> Parser Integer
intRadix r = sign <*> numberWithRadix r
@@ -84,26 +89,29 @@ nil :: Parser ()
nil = try ((char '\'') *> string "()") *> return () <?> "nil"
hashVal :: Parser Expr
-hashVal = lexeme $ char '#'
- *> (char 't' *> return (Bool True)
- <|> char 'f' *> return (Bool False)
- <|> char 'b' *> (Numb <$> intRadix (2, oneOf "01"))
- <|> char 'o' *> (Numb <$> intRadix (8, octDigit))
- <|> char 'd' *> (Numb <$> intRadix (10, digit))
- <|> char 'x' *> (Numb <$> intRadix (16, hexDigit))
- <|> oneOf "ei" *> fail "Unsupported: exactness"
- <|> char '(' *> fail "Unsupported: vector"
- <|> char '\\' *> fail "Unsupported: char")
-
+hashVal =
+ lexeme $
+ char '#'
+ *> ( char 't' *> return (Bool True)
+ <|> char 'f' *> return (Bool False)
+ <|> char 'b' *> (Numb <$> intRadix (2, oneOf "01"))
+ <|> char 'o' *> (Numb <$> intRadix (8, octDigit))
+ <|> char 'd' *> (Numb <$> intRadix (10, digit))
+ <|> char 'x' *> (Numb <$> intRadix (16, hexDigit))
+ <|> oneOf "ei" *> fail "Unsupported: exactness"
+ <|> char '(' *> fail "Unsupported: vector"
+ <|> char '\\' *> fail "Unsupported: char"
+ )
lispVal :: Parser Expr
-lispVal = hashVal
- <|> Nil <$ nil
- <|> Numb <$> try (sign <*> decimal)
- <|> Atom <$> identifier
- <|> Tape <$> textLiteral
- <|> _Quote <$> quoted lispVal
- <|> List <$> parens manyExpr
+lispVal =
+ hashVal
+ <|> Nil <$ nil
+ <|> Numb <$> try (sign <*> decimal)
+ <|> Atom <$> identifier
+ <|> Tape <$> textLiteral
+ <|> _Quote <$> quoted lispVal
+ <|> List <$> parens manyExpr
manyExpr :: Parser [Expr]
manyExpr = lispVal `sepBy` whitespace
diff --git a/Biz/Language/Bs/Primitives.hs b/Biz/Language/Bs/Primitives.hs
index c074c59..4c70499 100644
--- a/Biz/Language/Bs/Primitives.hs
+++ b/Biz/Language/Bs/Primitives.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
+
-- | bs primitives
--
-- I would like to reduce the number of primitives in the language to some
@@ -18,134 +19,138 @@ import Protolude
import System.Directory
import System.IO
-type Prim = [(T.Text, Expr)]
-type Unary = Expr -> Eval Expr
+type Prim = [(T.Text, Expr)]
+
+type Unary = Expr -> Eval Expr
+
type Binary = Expr -> Expr -> Eval Expr
mkF :: ([Expr] -> Eval Expr) -> Expr
mkF = IFun . IFunc
primEnv :: Prim
-primEnv = [
- ("+" , mkF $ binopFold (numOp (+)) (Numb 0) )
- , ("*" , mkF $ binopFold (numOp (*)) (Numb 1) )
- , ("string-append", mkF $ binopFold (strOp (<>)) (Tape "") )
- , ("-" , mkF $ binop $ numOp (-))
- , ("<" , mkF $ binop $ numCmp (<))
- , ("<=" , mkF $ binop $ numCmp (<=))
- , (">" , mkF $ binop $ numCmp (>))
- , (">=" , mkF $ binop $ numCmp (>=))
- , ("==" , mkF $ binop $ numCmp (==))
- , ("even?" , mkF $ unop $ numBool even)
- , ("odd?" , mkF $ unop $ numBool odd)
- , ("neg?" , mkF $ unop $ numBool (< 0))
- , ("pos?" , mkF $ unop $ numBool (> 0))
- , ("eq?" , mkF $ binop eqCmd )
- , ("null?" , mkF $ unop (eqCmd Nil) )
- , ("bl-eq?" , mkF $ binop $ eqOp (==))
- , ("and" , mkF $ binopFold (eqOp (&&)) (Bool True))
- , ("or" , mkF $ binopFold (eqOp (||)) (Bool False))
- , ("not" , mkF $ unop $ notOp)
- , ("cons" , mkF $ Language.Bs.Primitives.cons)
- , ("cdr" , mkF $ Language.Bs.Primitives.cdr)
- , ("car" , mkF $ Language.Bs.Primitives.car)
- , ("quote" , mkF $ quote)
- , ("file?" , mkF $ unop fileExists)
- , ("slurp" , mkF $ unop slurp)
- , ("wslurp" , mkF $ unop wSlurp)
- , ("put" , mkF $ binop put_)
+primEnv =
+ [ ("+", mkF $ binopFold (numOp (+)) (Numb 0)),
+ ("*", mkF $ binopFold (numOp (*)) (Numb 1)),
+ ("string-append", mkF $ binopFold (strOp (<>)) (Tape "")),
+ ("-", mkF $ binop $ numOp (-)),
+ ("<", mkF $ binop $ numCmp (<)),
+ ("<=", mkF $ binop $ numCmp (<=)),
+ (">", mkF $ binop $ numCmp (>)),
+ (">=", mkF $ binop $ numCmp (>=)),
+ ("==", mkF $ binop $ numCmp (==)),
+ ("even?", mkF $ unop $ numBool even),
+ ("odd?", mkF $ unop $ numBool odd),
+ ("neg?", mkF $ unop $ numBool (< 0)),
+ ("pos?", mkF $ unop $ numBool (> 0)),
+ ("eq?", mkF $ binop eqCmd),
+ ("null?", mkF $ unop (eqCmd Nil)),
+ ("bl-eq?", mkF $ binop $ eqOp (==)),
+ ("and", mkF $ binopFold (eqOp (&&)) (Bool True)),
+ ("or", mkF $ binopFold (eqOp (||)) (Bool False)),
+ ("not", mkF $ unop $ notOp),
+ ("cons", mkF $ Language.Bs.Primitives.cons),
+ ("cdr", mkF $ Language.Bs.Primitives.cdr),
+ ("car", mkF $ Language.Bs.Primitives.car),
+ ("quote", mkF $ quote),
+ ("file?", mkF $ unop fileExists),
+ ("slurp", mkF $ unop slurp),
+ ("wslurp", mkF $ unop wSlurp),
+ ("put", mkF $ binop put_)
]
unop :: Unary -> [Expr] -> Eval Expr
-unop op [x] = op x
-unop _ args = throw $ NumArgs 1 args
+unop op [x] = op x
+unop _ args = throw $ NumArgs 1 args
binop :: Binary -> [Expr] -> Eval Expr
-binop op [x,y] = op x y
-binop _ args = throw $ NumArgs 2 args
+binop op [x, y] = op x y
+binop _ args = throw $ NumArgs 2 args
-fileExists :: Expr -> Eval Expr
+fileExists :: Expr -> Eval Expr
fileExists (Tape txt) = Bool <$> liftIO (doesFileExist $ T.unpack txt)
-fileExists val = throw $ TypeMismatch "read expects string, instead got: " val
+fileExists val = throw $ TypeMismatch "read expects string, instead got: " val
-slurp :: Expr -> Eval Expr
+slurp :: Expr -> Eval Expr
slurp (Tape txt) = liftIO $ wFileSlurp txt
-slurp val = throw $ TypeMismatch "read expects string, instead got: " val
+slurp val = throw $ TypeMismatch "read expects string, instead got: " val
wFileSlurp :: T.Text -> IO Expr
wFileSlurp fileName = withFile (T.unpack fileName) ReadMode go
- where go = readTextFile fileName
+ where
+ go = readTextFile fileName
openURL :: T.Text -> IO Expr
openURL x = do
- req <- simpleHTTP (getRequest $ T.unpack x)
+ req <- simpleHTTP (getRequest $ T.unpack x)
body <- getResponseBody req
return $ Tape $ T.pack body
wSlurp :: Expr -> Eval Expr
-wSlurp (Tape txt) = liftIO $ openURL txt
+wSlurp (Tape txt) = liftIO $ openURL txt
wSlurp val = throw $ TypeMismatch "wSlurp expects a string, instead got: " val
readTextFile :: T.Text -> Handle -> IO Expr
readTextFile fileName h = do
exists <- doesFileExist $ T.unpack fileName
if exists
- then (TIO.hGetContents h) >>= (return . Tape)
- else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName]
+ then (TIO.hGetContents h) >>= (return . Tape)
+ else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName]
put_ :: Expr -> Expr -> Eval Expr
-put_ (Tape file) (Tape msg) = liftIO $ wFilePut file msg
-put_ (Tape _) val = throw $ TypeMismatch "put expects string in the second argument (try using show), instead got: " val
-put_ val _ = throw $ TypeMismatch "put expects string, instead got: " val
+put_ (Tape file) (Tape msg) = liftIO $ wFilePut file msg
+put_ (Tape _) val = throw $ TypeMismatch "put expects string in the second argument (try using show), instead got: " val
+put_ val _ = throw $ TypeMismatch "put expects string, instead got: " val
wFilePut :: T.Text -> T.Text -> IO Expr
wFilePut fileName msg = withFile (T.unpack fileName) WriteMode go
- where go = putTextFile fileName msg
+ where
+ go = putTextFile fileName msg
putTextFile :: T.Text -> T.Text -> Handle -> IO Expr
putTextFile fileName msg h = do
canWrite <- hIsWritable h
if canWrite
- then (TIO.hPutStr h msg) >> (return $ Tape msg)
- else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName]
+ then (TIO.hPutStr h msg) >> (return $ Tape msg)
+ else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName]
binopFold :: Binary -> Expr -> [Expr] -> Eval Expr
binopFold op farg args = case args of
- []-> throw $ NumArgs 2 args
- [a,b] -> op a b
- _ -> foldM op farg args
+ [] -> throw $ NumArgs 2 args
+ [a, b] -> op a b
+ _ -> foldM op farg args
numBool :: (Integer -> Bool) -> Expr -> Eval Expr
numBool op (Numb x) = return $ Bool $ op x
-numBool _ x = throw $ TypeMismatch "numeric op " x
+numBool _ x = throw $ TypeMismatch "numeric op " x
numOp :: (Integer -> Integer -> Integer) -> Expr -> Expr -> Eval Expr
-numOp op (Numb x) (Numb y) = return $ Numb $ op x y
-numOp _ Nil (Numb y) = return $ Numb y
-numOp _ (Numb x) Nil = return $ Numb x
-numOp _ x (Numb _) = throw $ TypeMismatch "numeric op" x
-numOp _ (Numb _) y = throw $ TypeMismatch "numeric op" y
-numOp _ x _ = throw $ TypeMismatch "numeric op" x
+numOp op (Numb x) (Numb y) = return $ Numb $ op x y
+numOp _ Nil (Numb y) = return $ Numb y
+numOp _ (Numb x) Nil = return $ Numb x
+numOp _ x (Numb _) = throw $ TypeMismatch "numeric op" x
+numOp _ (Numb _) y = throw $ TypeMismatch "numeric op" y
+numOp _ x _ = throw $ TypeMismatch "numeric op" x
strOp :: (T.Text -> T.Text -> T.Text) -> Expr -> Expr -> Eval Expr
strOp op (Tape x) (Tape y) = return $ Tape $ op x y
-strOp _ Nil (Tape y) = return $ Tape y
-strOp _ (Tape x) Nil = return $ Tape x
-strOp _ x (Tape _) = throw $ TypeMismatch "string op" x
-strOp _ (Tape _) y = throw $ TypeMismatch "string op" y
-strOp _ x _ = throw $ TypeMismatch "string op" x
+strOp _ Nil (Tape y) = return $ Tape y
+strOp _ (Tape x) Nil = return $ Tape x
+strOp _ x (Tape _) = throw $ TypeMismatch "string op" x
+strOp _ (Tape _) y = throw $ TypeMismatch "string op" y
+strOp _ x _ = throw $ TypeMismatch "string op" x
eqOp :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Expr
eqOp op (Bool x) (Bool y) = return $ Bool $ op x y
-eqOp _ x (Bool _) = throw $ TypeMismatch "bool op" x
-eqOp _ (Bool _) y = throw $ TypeMismatch "bool op" y
-eqOp _ x _ = throw $ TypeMismatch "bool op" x
+eqOp _ x (Bool _) = throw $ TypeMismatch "bool op" x
+eqOp _ (Bool _) y = throw $ TypeMismatch "bool op" y
+eqOp _ x _ = throw $ TypeMismatch "bool op" x
numCmp :: (Integer -> Integer -> Bool) -> Expr -> Expr -> Eval Expr
-numCmp op (Numb x) (Numb y) = return . Bool $ op x y
-numCmp _ x (Numb _) = throw $ TypeMismatch "numeric op" x
-numCmp _ (Numb _) y = throw $ TypeMismatch "numeric op" y
-numCmp _ x _ = throw $ TypeMismatch "numeric op" x
+numCmp op (Numb x) (Numb y) = return . Bool $ op x y
+numCmp _ x (Numb _) = throw $ TypeMismatch "numeric op" x
+numCmp _ (Numb _) y = throw $ TypeMismatch "numeric op" y
+numCmp _ x _ = throw $ TypeMismatch "numeric op" x
notOp :: Expr -> Eval Expr
notOp (Bool True) = return $ Bool False
@@ -157,27 +162,27 @@ eqCmd (Atom x) (Atom y) = return . Bool $ x == y
eqCmd (Numb x) (Numb y) = return . Bool $ x == y
eqCmd (Tape x) (Tape y) = return . Bool $ x == y
eqCmd (Bool x) (Bool y) = return . Bool $ x == y
-eqCmd Nil Nil = return $ Bool True
-eqCmd _ _ = return $ Bool False
+eqCmd Nil Nil = return $ Bool True
+eqCmd _ _ = return $ Bool False
cons :: [Expr] -> Eval Expr
-cons [x,(List ys)] = return $ List $ x:ys
-cons [x,y] = return $ List [x,y]
-cons _ = throw $ ExpectedList "cons, in second argument"
+cons [x, (List ys)] = return $ List $ x : ys
+cons [x, y] = return $ List [x, y]
+cons _ = throw $ ExpectedList "cons, in second argument"
car :: [Expr] -> Eval Expr
-car [List [] ] = return Nil
-car [List (x:_)] = return x
-car [] = return Nil
-car _ = throw $ ExpectedList "car"
+car [List []] = return Nil
+car [List (x : _)] = return x
+car [] = return Nil
+car _ = throw $ ExpectedList "car"
cdr :: [Expr] -> Eval Expr
-cdr [List (_:xs)] = return $ List xs
-cdr [List []] = return Nil
-cdr [] = return Nil
-cdr _ = throw $ ExpectedList "cdr"
+cdr [List (_ : xs)] = return $ List xs
+cdr [List []] = return Nil
+cdr [] = return Nil
+cdr _ = throw $ ExpectedList "cdr"
quote :: [Expr] -> Eval Expr
-quote [List xs] = return $ List $ Atom "quote" : xs
-quote [expr] = return $ List $ Atom "quote" : [expr]
-quote args = throw $ NumArgs 1 args
+quote [List xs] = return $ List $ Atom "quote" : xs
+quote [expr] = return $ List $ Atom "quote" : [expr]
+quote args = throw $ NumArgs 1 args
diff --git a/Biz/Language/Bs/Repl.hs b/Biz/Language/Bs/Repl.hs
index 64ffaa2..24f1bcd 100644
--- a/Biz/Language/Bs/Repl.hs
+++ b/Biz/Language/Bs/Repl.hs
@@ -1,8 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
-module Language.Bs.Repl (
-mainLoop
-) where
+
+module Language.Bs.Repl
+ ( mainLoop,
+ )
+where
import Control.Monad.Trans
import Data.String
@@ -22,7 +24,8 @@ repl = do
case minput of
Nothing -> outputStrLn "bye."
Just input -> (liftIO $ process input) >> repl
- --Just input -> (liftIO $ processToAST input) >> repl
+
+--Just input -> (liftIO $ processToAST input) >> repl
process :: String -> IO ()
process str = do
diff --git a/Control/Concurrent/Go.hs b/Control/Concurrent/Go.hs
index 1bb0b86..08a1d65 100644
--- a/Control/Concurrent/Go.hs
+++ b/Control/Concurrent/Go.hs
@@ -1,45 +1,46 @@
-{- | An EDSL to make working with concurrent in-process code a bit easier
- to read.
-
-This module is expected to be imported qualified as `Go`. Inspired by
-Golang and Clojure's core.async.
-
-$example
--}
-{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | An EDSL to make working with concurrent in-process code a bit easier
+-- to read.
+--
+-- This module is expected to be imported qualified as `Go`. Inspired by
+-- Golang and Clojure's core.async.
+--
+-- \$example
module Control.Concurrent.Go
- (
- -- * Running and forking
- fork
- -- * Channels
- , Channel
- , chan
- , read
- , write
- , mult
- , tap
+ ( -- * Running and forking
+ fork,
+
+ -- * Channels
+ Channel,
+ chan,
+ read,
+ write,
+ mult,
+ tap,
)
where
-import Alpha
-import qualified Control.Concurrent as Concurrent
-import qualified Control.Concurrent.Chan.Unagi.Bounded
- as Chan
-import qualified Data.Aeson as Aeson
-import Data.Text ( Text )
-import qualified System.IO.Unsafe as Unsafe
+import Alpha
+import qualified Control.Concurrent as Concurrent
+import qualified Control.Concurrent.Chan.Unagi.Bounded as Chan
+import qualified Data.Aeson as Aeson
+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
+ where
+ len = show . Unsafe.unsafePerformIO . Chan.estimatedLength . _in
-- | Starts a background process.
fork :: IO () -> IO Concurrent.ThreadId
@@ -76,32 +77,30 @@ read = Chan.readChan . _out
write :: Channel a -> a -> IO Bool
write = Chan.tryWriteChan . _in
-{- $example
-
-A simple example from ghci:
-
->>> import qualified Control.Concurrent.Go as Go
->>> c <- Go.chan :: IO (Go.Channel Text)
->>> Go.write c "test"
->>> Go.read c
-"test"
-
-An example with tap and mult:
-
->>> c <- Go.chan :: IO (Go.Channel Text)
->>> Go.write c "hi"
->>> Go.read c
-"hi"
->>> Go.fork
->>> 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)
-ThreadId 825
->>> Go.write c "test"
-"two: t"eosnte":
- test"
-
-The text is garbled because the actions are happening concurrently and
-trying to serialize to write the output, but you get the idea.
-
--}
+-- $example
+--
+-- A simple example from ghci:
+--
+-- >>> import qualified Control.Concurrent.Go as Go
+-- >>> c <- Go.chan :: IO (Go.Channel Text)
+-- >>> Go.write c "test"
+-- >>> Go.read c
+-- "test"
+--
+-- An example with tap and mult:
+--
+-- >>> c <- Go.chan :: IO (Go.Channel Text)
+-- >>> Go.write c "hi"
+-- >>> Go.read c
+-- "hi"
+-- >>> Go.fork
+-- >>> 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)
+-- ThreadId 825
+-- >>> Go.write c "test"
+-- "two: t"eosnte":
+-- test"
+--
+-- The text is garbled because the actions are happening concurrently and
+-- trying to serialize to write the output, but you get the idea.
diff --git a/Control/Concurrent/Sema.hs b/Control/Concurrent/Sema.hs
index e804cc3..5b32bab 100644
--- a/Control/Concurrent/Sema.hs
+++ b/Control/Concurrent/Sema.hs
@@ -1,6 +1,6 @@
module Control.Concurrent.Sema
- ( mapPool
- )
+ ( mapPool,
+ )
where
import qualified Control.Concurrent.MSem as Sem
@@ -8,5 +8,5 @@ import qualified Control.Concurrent.MSem as Sem
-- | Simaphore-based throttled 'mapConcurrently'.
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
+ sima <- Sem.new n
+ mapConcurrently (Sem.with sima . f) xs
diff --git a/Hero/App.hs b/Hero/App.hs
index 7f55052..6afcbd2 100644
--- a/Hero/App.hs
+++ b/Hero/App.hs
@@ -1,46 +1,48 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+
module Hero.App where
-import Alpha
+import Alpha
import qualified Clay
-import qualified Hero.Assets as Assets
-import Hero.Look as Look
-import Hero.Look.Typography
-import Network.RemoteData
-import Data.Aeson ( ToJSON(..)
- , FromJSON(..)
- , genericToJSON
- , genericParseJSON
- , defaultOptions
- )
+import Data.Aeson
+ ( FromJSON (..),
+ ToJSON (..),
+ defaultOptions,
+ genericParseJSON,
+ genericToJSON,
+ )
import qualified Data.List as List
import qualified Data.List.Split as List
-import Data.Proxy ( Proxy(..) )
-import Data.String
-import Data.String.Quote
-import Data.Text ( Text, replace, toLower )
-import GHC.Generics ( Generic )
+import Data.Proxy (Proxy (..))
+import Data.String
+import Data.String.Quote
+import Data.Text (Text, replace, toLower)
+import GHC.Generics (Generic)
import qualified GHC.Show as Legacy
-import Miso
+import qualified Hero.Assets as Assets
+import Hero.Look as Look
+import Hero.Look.Typography
+import Miso
import qualified Miso (for_)
-import Miso.String
-import Protolude hiding (replace)
-import Servant.API ( Capture
- , URI(..)
- , safeLink
- , (:<|>)(..)
- , (:>)
- )
-import Servant.Links ( linkURI )
+import Miso.String
+import Network.RemoteData
+import Protolude hiding (replace)
+import Servant.API
+ ( (:<|>) (..),
+ (:>),
+ Capture,
+ URI (..),
+ safeLink,
+ )
+import Servant.Links (linkURI)
crossorigin_ :: MisoString -> Attribute action
crossorigin_ = textProp "crossorigin"
@@ -53,30 +55,36 @@ audioId = "audioSource"
-- overide 'a_' links, for example.
onPreventClick :: Action -> Attribute Action
onPreventClick action =
- onWithOptions Miso.defaultOptions { preventDefault = True }
- "click" emptyDecoder (\() -> action)
+ onWithOptions
+ Miso.defaultOptions {preventDefault = True}
+ "click"
+ emptyDecoder
+ (\() -> action)
-- TODO: make ComicId a hashid https://hackage.haskell.org/package/hashids-1.0.2.4/docs/Web-Hashids.html
type ComicId = String
-- | Class for turning different string types to snakeCase.
class CanSnakeCase str where
- snake :: str -> str
+ snake :: str -> str
instance CanSnakeCase Text where
- snake = Data.Text.replace " " "-" . Data.Text.toLower
+ snake = Data.Text.replace " " "-" . Data.Text.toLower
-- | Used for looking up images on S3, mostly
comicSlug :: Comic -> Text
-comicSlug Comic{..} = snake comicName <> "-" <> comicIssue
-
-data Comic = Comic
- { comicId :: ComicId
- , comicPages :: Integer
- , comicName :: Text
- , comicIssue :: Text -- ^ Ideally this would be a dynamic number-like type
- , comicDescription :: Text
- } deriving (Show, Eq, Generic)
+comicSlug Comic {..} = snake comicName <> "-" <> comicIssue
+
+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)
instance ToJSON Comic where
toJSON = genericToJSON Data.Aeson.defaultOptions
@@ -86,73 +94,93 @@ instance FromJSON Comic where
-- | Class for rendering media objects in different ways.
class IsMediaObject o where
- -- | Render a thumbnail for use in a shelf, or otherwise.
- thumbnail :: o -> View Action
- -- | Render a featured banner.
- feature :: o -> Library -> View Action
- -- | Media info view
- info :: o -> Library -> View Action
+ -- | Render a thumbnail for use in a shelf, or otherwise.
+ thumbnail :: o -> View Action
+
+ -- | Render a featured banner.
+ feature :: o -> Library -> View Action
+
+ -- | Media info view
+ info :: o -> Library -> View Action
instance IsMediaObject Comic where
- thumbnail c@Comic{..} = li_ []
- [ a_
- [ class_ "comic grow clickable"
- , id_ $ "comic-" <> ms comicId
- , onClick $ SetMediaInfo $ Just c
+ thumbnail c@Comic {..} =
+ li_
+ []
+ [ a_
+ [ class_ "comic grow clickable",
+ id_ $ "comic-" <> ms comicId,
+ onClick $ SetMediaInfo $ Just c
]
- [ img_ [ src_ $ ms $ Assets.demo <> comicSlug c <> ".png" ]
- , span_ [] [ text $ "Issue #" <> ms comicIssue ]
- , span_ [] [ text $ ms comicName ]
+ [ img_ [src_ $ ms $ Assets.demo <> comicSlug c <> ".png"],
+ span_ [] [text $ "Issue #" <> ms comicIssue],
+ span_ [] [text $ ms comicName]
]
- ]
- feature comic lib = div_ [ id_ "featured-comic" ]
- [ img_ [ id_ "featured-banner", src_ $ ms $ Assets.demo <> "feature-banner.png" ]
- , div_ [ id_ "featured-content" ]
- [ div_ [ class_ "hero-original", css wide ]
- [ span_ [ css thicc ] [ text "Herø" ]
- , span_ [ css euro ] [ text " Original" ]
- ]
- , div_ [ class_ "comic-logo" ]
- [ img_ [ src_ $ ms $ Assets.demo <> comicSlug comic <> "-logo.png" ] ]
- , div_ [ class_ "comic-action-menu" ] $ el <$> [ Watch comic, Read comic, Save comic lib ]
- , p_ [ class_ "description" ]
- [ text . ms $ comicDescription comic
- ]
+ ]
+ feature comic lib =
+ div_
+ [id_ "featured-comic"]
+ [ img_ [id_ "featured-banner", src_ $ ms $ Assets.demo <> "feature-banner.png"],
+ div_
+ [id_ "featured-content"]
+ [ div_
+ [class_ "hero-original", css wide]
+ [ span_ [css thicc] [text "Herø"],
+ span_ [css euro] [text " Original"]
+ ],
+ div_
+ [class_ "comic-logo"]
+ [img_ [src_ $ ms $ Assets.demo <> comicSlug comic <> "-logo.png"]],
+ div_ [class_ "comic-action-menu"] $ el <$> [Watch comic, Read comic, Save comic lib],
+ p_
+ [class_ "description"]
+ [ text . ms $ comicDescription comic
+ ]
]
- ]
- info c@Comic {..} lib = div_ [ class_ "media-info", css euro ]
- [ div_ [ class_ "media-info-meta" ]
- [ column [ img_ [ src_ $ ms $ Assets.demo <> "dmc-widethumb.png" ] ]
- , column
- [ span_ [ style_ title ] [ text $ ms comicName ]
- , span_ [ style_ subtitle ] [ text $ "Issue #" <> ms comicIssue ]
- , span_ [] [ text "Released: " ]
- , span_ [] [ text $ "Pages: " <> ms (show comicPages :: String) ]
- ]
- ]
- , div_ [ class_ "media-info-summary" ]
- [ p_ [ style_ $ uppercase <> bold <> Look.expanded <> "font-size" =: ".8rem" ]
- [ text "Summary" ]
- , p_ [] [ text $ ms comicDescription ]
- ]
- , div_ [ class_ "media-info-actions" ] $ el <$> [ Save c lib, Read c, Watch c ]
+ ]
+ info c@Comic {..} lib =
+ div_
+ [class_ "media-info", css euro]
+ [ div_
+ [class_ "media-info-meta"]
+ [ column [img_ [src_ $ ms $ Assets.demo <> "dmc-widethumb.png"]],
+ column
+ [ span_ [style_ title] [text $ ms comicName],
+ span_ [style_ subtitle] [text $ "Issue #" <> ms comicIssue],
+ span_ [] [text "Released: "],
+ span_ [] [text $ "Pages: " <> ms (show comicPages :: String)]
+ ]
+ ],
+ div_
+ [class_ "media-info-summary"]
+ [ p_
+ [style_ $ uppercase <> bold <> Look.expanded <> "font-size" =: ".8rem"]
+ [text "Summary"],
+ p_ [] [text $ ms comicDescription]
+ ],
+ div_ [class_ "media-info-actions"] $ el <$> [Save c lib, Read c, Watch c]
-- , row [ text "credits" ]
- ]
- where
- title = "color" =: "red" <> "font-size" =: "1.6rem" <> uppercase
- <> "line-height" =: "100%" <> Look.condensed <> bold
- subtitle = "color" =: "#fff" <> "font-size" =: "1.2rem" <> bold <> Look.condensed
-
+ ]
+ where
+ title =
+ "color" =: "red" <> "font-size" =: "1.6rem" <> uppercase
+ <> "line-height"
+ =: "100%"
+ <> Look.condensed
+ <> bold
+ subtitle = "color" =: "#fff" <> "font-size" =: "1.2rem" <> bold <> Look.condensed
type ZoomModel = Int
-- | All the buttons.
data Button
- = Watch Comic | Read Comic | Save Comic Library
- | SaveIcon Comic Library
- | ZoomIcon ZoomModel Comic Page
- | PlayPause MisoString AudioState
- | Arrow Action
+ = Watch Comic
+ | Read Comic
+ | Save Comic Library
+ | SaveIcon Comic Library
+ | ZoomIcon ZoomModel Comic Page
+ | PlayPause MisoString AudioState
+ | Arrow Action
-- | Class for defining general, widely used elements in the heroverse.
class Elemental v where el :: v -> View Action
@@ -160,84 +188,100 @@ class Elemental v where el :: v -> View Action
-- TODO: what if I just did this on all actions?
-- then I could e.g. `el $ ToggleAudio audioId audioState`
instance Elemental Button where
- el (PlayPause id model) = button_
- [ class_ "button is-large icon"
- , onClick $ ToggleAudio id
- ]
- [ i_ [ class_ $ "fa " <> icon ][]]
- where
- icon = case model of
- Paused -> "fa-play-circle"
- Playing -> "fa-pause-circle"
- el (Arrow act) = button_
- [class_ "button is-large turn-page", onClick act]
- [ img_ [src_ $ ms $ Assets.demo <> image <> ".png"]]
- where image = case act of
- PrevPage -> "prev-page"
- NextPage -> "next-page"
- _ -> "prev-page"
- el (Save c lib) =
- if c `elem` lib then -- in library
- a_ [ class_ $ "wrs-button saved", onClick $ ToggleInLibrary c ]
- [ img_ [ src_ $ ms $ Assets.icon <> "save.svg" ]
- , span_ [] [ text "saved" ]
- ]
- else -- not in library
- a_ [ class_ $ "wrs-button", onClick $ ToggleInLibrary c ]
- [ img_ [ src_ $ ms $ Assets.icon <> "save.svg" ]
- , span_ [] [ text "save" ]
- ]
- el (SaveIcon c lib) =
- if c `elem` lib then -- in library
- button_
- [ class_ "button is-large has-background-black"
- , onClick $ ToggleInLibrary c
- ]
- [ img_ [ src_ $ ms $ Assets.demo <> "library-add.png" ] ]
- else -- not in library
- button_
- [ class_ "button is-large has-background-black-bis"
- , onClick $ ToggleInLibrary c
- ]
- [ img_ [ src_ $ ms $ Assets.demo <> "library-add.png" ] ]
+ el (PlayPause id model) =
+ button_
+ [ class_ "button is-large icon",
+ onClick $ ToggleAudio id
+ ]
+ [i_ [class_ $ "fa " <> icon] []]
+ where
+ icon = case model of
+ Paused -> "fa-play-circle"
+ Playing -> "fa-pause-circle"
+ el (Arrow act) =
+ button_
+ [class_ "button is-large turn-page", onClick act]
+ [img_ [src_ $ ms $ Assets.demo <> image <> ".png"]]
+ where
+ image = case act of
+ PrevPage -> "prev-page"
+ NextPage -> "next-page"
+ _ -> "prev-page"
+ el (Save c lib) =
+ if c `elem` lib -- in library
+ then
+ a_
+ [class_ $ "wrs-button saved", onClick $ ToggleInLibrary c]
+ [ img_ [src_ $ ms $ Assets.icon <> "save.svg"],
+ span_ [] [text "saved"]
+ ]
+ else-- not in library
- el (ZoomIcon zmodel comic page) = button_
- [ id_ "zoom-button", class_ "button is-large"
- , onClick $ ToggleZoom comic page
+ a_
+ [class_ $ "wrs-button", onClick $ ToggleInLibrary c]
+ [ img_ [src_ $ ms $ Assets.icon <> "save.svg"],
+ span_ [] [text "save"]
]
- [ img_ [ src_ $ ms $ Assets.demo <> "zoom.png" ]
- , input_
- [ type_ "range", min_ "0", max_ "100", disabled_ True
- , value_ $ ms (show zmodel :: String)
- , class_ "ctrl", id_ "zoom"
- ]
- , label_
- [ class_ "ctrl", Miso.for_ "zoom" ]
- [ text $ ms $ (show zmodel :: String) ++ "%" ]
+ el (SaveIcon c lib) =
+ if c `elem` lib -- in library
+ then
+ button_
+ [ class_ "button is-large has-background-black",
+ onClick $ ToggleInLibrary c
]
+ [img_ [src_ $ ms $ Assets.demo <> "library-add.png"]]
+ else-- not in library
- el (Read c) = a_ [ class_ $ "wrs-button", onClick $ SelectExperience c ]
- [ img_ [ src_ $ ms $ Assets.icon <> "read.svg" ]
- , span_ [] [ text "read" ]
- ]
-
- el (Watch c) = a_ [ class_ $ "wrs-button", onClick $ StartWatching c ]
- [ img_ [ src_ $ ms $ Assets.icon <> "watch.svg" ]
- , span_ [] [ text "watch" ]
- ]
+ button_
+ [ class_ "button is-large has-background-black-bis",
+ onClick $ ToggleInLibrary c
+ ]
+ [img_ [src_ $ ms $ Assets.demo <> "library-add.png"]]
+ el (ZoomIcon zmodel comic page) =
+ button_
+ [ id_ "zoom-button",
+ class_ "button is-large",
+ onClick $ ToggleZoom comic page
+ ]
+ [ img_ [src_ $ ms $ Assets.demo <> "zoom.png"],
+ input_
+ [ type_ "range",
+ min_ "0",
+ max_ "100",
+ disabled_ True,
+ value_ $ ms (show zmodel :: String),
+ class_ "ctrl",
+ id_ "zoom"
+ ],
+ label_
+ [class_ "ctrl", Miso.for_ "zoom"]
+ [text $ ms $ (show zmodel :: String) ++ "%"]
+ ]
+ el (Read c) =
+ a_
+ [class_ $ "wrs-button", onClick $ SelectExperience c]
+ [ img_ [src_ $ ms $ Assets.icon <> "read.svg"],
+ span_ [] [text "read"]
+ ]
+ el (Watch c) =
+ a_
+ [class_ $ "wrs-button", onClick $ StartWatching c]
+ [ img_ [src_ $ ms $ Assets.icon <> "watch.svg"],
+ span_ [] [text "watch"]
+ ]
data AudioState = Playing | Paused
- deriving (Show, Eq)
+ deriving (Show, Eq)
type Library = [Comic]
data ComicReaderState
- = NotReading
- | Cover ComicId
- | ChooseExperience ComicId Page
- | Reading ComicReaderView ComicId Page
- | Watching ComicId
- deriving (Show, Eq)
+ = NotReading
+ | Cover ComicId
+ | ChooseExperience ComicId Page
+ | Reading ComicReaderView ComicId Page
+ | Watching ComicId
+ deriving (Show, Eq)
findComic :: ComicId -> [Comic] -> Maybe Comic
findComic id ls = List.find (\c -> comicId c == id) ls
@@ -246,36 +290,39 @@ findComic id ls = List.find (\c -> comicId c == id) ls
--
-- Try to prefix component-specific state with the component initials: 'd' for
-- discover, 'cp' for comic player.
-data Model = Model
- { uri :: URI
- , appComics :: RemoteData MisoString [Comic]
- , userLibrary :: Library
- , dMediaInfo :: Maybe Comic
- , cpState :: ComicReaderState
- , cpAudioState :: AudioState
- , zoomModel :: ZoomModel
- } deriving (Show, Eq)
+data Model
+ = Model
+ { uri :: URI,
+ appComics :: RemoteData MisoString [Comic],
+ userLibrary :: Library,
+ dMediaInfo :: Maybe Comic,
+ cpState :: ComicReaderState,
+ cpAudioState :: AudioState,
+ zoomModel :: ZoomModel
+ }
+ deriving (Show, Eq)
initModel :: URI -> Model
initModel uri_ =
- Model { uri = uri_
- , appComics = NotAsked
- , dMediaInfo = Nothing
- , userLibrary = Protolude.empty
- , cpState = detectPlayerState uri_
- , cpAudioState = Paused
- , zoomModel = 100
- }
+ Model
+ { uri = uri_,
+ appComics = NotAsked,
+ dMediaInfo = Nothing,
+ userLibrary = Protolude.empty,
+ cpState = detectPlayerState uri_,
+ cpAudioState = Paused,
+ zoomModel = 100
+ }
-- | Hacky way to initialize the 'ComicReaderState' from the URI.
detectPlayerState :: URI -> ComicReaderState
detectPlayerState u = case List.splitOn "/" $ uriPath u of
- ["", "comic", id, pg, "experience"] -> ChooseExperience id $ toPage pg
- ["", "comic", id, _, "video"] -> Watching id
- ["", "comic", id, pg, "full"] -> Reading Full id $ toPage pg
- ["", "comic", id, pg] -> Reading Spread id $ toPage pg
- ["", "comic", id] -> Cover id
- _ -> NotReading
+ ["", "comic", id, pg, "experience"] -> ChooseExperience id $ toPage pg
+ ["", "comic", id, _, "video"] -> Watching id
+ ["", "comic", id, pg, "full"] -> Reading Full id $ toPage pg
+ ["", "comic", id, pg] -> Reading Spread id $ toPage pg
+ ["", "comic", id] -> Cover id
+ _ -> NotReading
where
toPage pg = fromMaybe 1 (readMaybe pg :: Maybe Page)
@@ -283,8 +330,8 @@ type Page = Int
data Action
= NoOp
- -- comic player stuff
- | SelectExperience Comic
+ | -- comic player stuff
+ SelectExperience Comic
| StartReading Comic
| StartWatching Comic
| NextPage
@@ -294,11 +341,11 @@ data Action
| FetchComics
| SetComics (RemoteData MisoString [Comic])
| ToggleFullscreen
- -- discover stuff
- | SetMediaInfo (Maybe Comic)
+ | -- discover stuff
+ SetMediaInfo (Maybe Comic)
| ToggleInLibrary Comic
- -- app stuff
- | ScrollIntoView MisoString
+ | -- app stuff
+ ScrollIntoView MisoString
| HandleURI URI
| ChangeURI URI
| DumpModel
@@ -307,50 +354,62 @@ data Action
type Discover = "discover" :> View Action
type Home =
- View Action
+ View Action
type ComicCover =
- "comic"
+ "comic"
:> Capture "comicId" ComicId
:> View Action
type ComicReaderSpread =
- "comic"
+ "comic"
:> Capture "id" ComicId
:> Capture "page" Page
:> View Action
type ComicReaderFull =
- "comic"
+ "comic"
:> Capture "id" ComicId
:> Capture "page" Page
:> "full"
:> View Action
type ComicVideo =
- "comic"
+ "comic"
:> Capture "id" ComicId
:> Capture "page" Page
:> "video"
:> View Action
type ChooseExperience =
- "comic"
+ "comic"
:> Capture "id" ComicId
:> Capture "page" Page
:> "experience"
:> View Action
type Login =
- "login" :> View Action
-
-type ClientRoutes = Home
- :<|> ComicCover :<|> ComicReaderSpread :<|> ComicReaderFull :<|> ComicVideo
- :<|> Login :<|> Discover :<|> ChooseExperience
-
-handlers = home
- :<|> comicCover :<|> comicPlayer :<|> comicPlayer :<|> comicPlayer
- :<|> login :<|> discover :<|> comicPlayer
+ "login" :> View Action
+
+type ClientRoutes =
+ Home
+ :<|> ComicCover
+ :<|> ComicReaderSpread
+ :<|> ComicReaderFull
+ :<|> ComicVideo
+ :<|> Login
+ :<|> Discover
+ :<|> ChooseExperience
+
+handlers =
+ home
+ :<|> comicCover
+ :<|> comicPlayer
+ :<|> comicPlayer
+ :<|> comicPlayer
+ :<|> login
+ :<|> discover
+ :<|> comicPlayer
routes :: Proxy ClientRoutes
routes = Proxy
@@ -383,21 +442,23 @@ home :: Model -> View Action
home = login
discover :: Model -> View Action
-discover model@(Model { userLibrary = lib}) = template "discover"
- [ topbar
- , main_ [id_ "app-body"] $ case appComics model of
- NotAsked -> [loading]
- Loading -> [loading]
- Failure _ -> [nocomics]
- Success [] -> [nocomics]
- Success (comic:rest) ->
- [ feature comic lib
- , shelf "Recent Releases" (comic:rest)
- , maybeView (flip info lib) $ dMediaInfo model
- ]
- , appmenu
- , discoverFooter
- ]
+discover model@(Model {userLibrary = lib}) =
+ template
+ "discover"
+ [ topbar,
+ main_ [id_ "app-body"] $ case appComics model of
+ NotAsked -> [loading]
+ Loading -> [loading]
+ Failure _ -> [nocomics]
+ Success [] -> [nocomics]
+ Success (comic : rest) ->
+ [ feature comic lib,
+ shelf "Recent Releases" (comic : rest),
+ maybeView (flip info lib) $ dMediaInfo model
+ ],
+ appmenu,
+ discoverFooter
+ ]
-- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty'
maybeView :: (a -> View action) -> Maybe a -> View action
@@ -405,155 +466,173 @@ maybeView f obj = maybe (text "") f obj
mediaInfo :: Maybe Comic -> Library -> View Action
mediaInfo Nothing _ = text ""
-mediaInfo (Just comic) lib = div_ [ class_ "media-info" ] [ info comic lib ]
+mediaInfo (Just comic) lib = div_ [class_ "media-info"] [info comic lib]
appmenu :: View Action
-appmenu = aside_ [ id_ "appmenu" ] $ btn </ links
+appmenu = aside_ [id_ "appmenu"] $ btn </ links
where
- links = [ (discoverLink, "discover.svg", "discover")
- , (homeLink, "save.svg", "library")
- , (homeLink, "watch.svg", "videos")
- , (comicLink "1", "read.svg", "comics")
- , (homeLink, "listen.svg", "music")
- ]
- btn (lnk,img,label) = a_
- [ class_ "button"
- , onPreventClick $ ChangeURI $ lnk
+ links =
+ [ (discoverLink, "discover.svg", "discover"),
+ (homeLink, "save.svg", "library"),
+ (homeLink, "watch.svg", "videos"),
+ (comicLink "1", "read.svg", "comics"),
+ (homeLink, "listen.svg", "music")
+ ]
+ btn (lnk, img, label) =
+ a_
+ [ class_ "button",
+ onPreventClick $ ChangeURI $ lnk
]
- [ img_ [src_ $ ms $ Assets.icon <> img]
- , span_ [] [ text label ]
+ [ img_ [src_ $ ms $ Assets.icon <> img],
+ span_ [] [text label]
]
-- TODO: make this a loading gif of some sort... maybe the hero icon filling from white to red
loading :: View Action
-loading = div_ [ class_ "loading" ] [ text "Loading..." ]
+loading = div_ [class_ "loading"] [text "Loading..."]
nocomics :: View Action
-nocomics = div_ [ class_ "loading" ] [ text "error: no comics found" ]
+nocomics = div_ [class_ "loading"] [text "error: no comics found"]
shelf :: IsMediaObject o => MisoString -> [o] -> View Action
-shelf title comics = div_ [ class_ "shelf" ]
- [ div_ [ class_ "shelf-head" ] [ text title ]
- , ul_ [ class_ "shelf-body" ] $ thumbnail </ comics
+shelf title comics =
+ div_
+ [class_ "shelf"]
+ [ div_ [class_ "shelf-head"] [text title],
+ ul_ [class_ "shelf-body"] $ thumbnail </ comics
]
discoverFooter :: View Action
-discoverFooter = footer_
- [ id_ "app-foot"
- , class_ "is-black"
- ]
- [ div_
- [id_ "app-foot-social", css euro]
- [ div_ [class_ "row is-marginless"]
- [ smallImg "facebook.png" $ Just "https://www.facebook.com/musicmeetscomics"
- , smallImg "twitter.png" $ Just "https://twitter.com/musicmeetscomic"
- , smallImg "instagram.png" $ Just "https://www.instagram.com/musicmeetscomics/"
- , smallImg "spotify.png" $ Just "https://open.spotify.com/user/i4ntfg6ganjgxdsylinigcjlq?si=ymWsSkwsT9iaLw2LeAJNNg"
- , smallImg "youtube.png" $ Just "https://www.youtube.com/channel/UCnNPLiuJ1ueo1KTPgHDE7lA/"
- ]
- , div_ [class_ "row"] [ text "Team | Contact Us | Privacy Policy" ]
- ]
- , div_
- [ id_ "app-foot-quote", css euro ]
- [ p_ [] [text "With great power comes great responsiblity."]
- , p_ [] [text "-Stan Lee"]
+discoverFooter =
+ footer_
+ [ id_ "app-foot",
+ class_ "is-black"
]
- , div_
- [ css euro, id_ "app-foot-logo", onClick DumpModel ]
- [ a_ [ class_ "social-icon", href_ "#" ] [ img_ [ src_ $ ms $ Assets.icon <> "hero-logo.svg" ]]
- , span_ [] [ text "© Hero Records, Inc. All Rights Reserved" ]
+ [ div_
+ [id_ "app-foot-social", css euro]
+ [ div_
+ [class_ "row is-marginless"]
+ [ smallImg "facebook.png" $ Just "https://www.facebook.com/musicmeetscomics",
+ smallImg "twitter.png" $ Just "https://twitter.com/musicmeetscomic",
+ smallImg "instagram.png" $ Just "https://www.instagram.com/musicmeetscomics/",
+ smallImg "spotify.png" $ Just "https://open.spotify.com/user/i4ntfg6ganjgxdsylinigcjlq?si=ymWsSkwsT9iaLw2LeAJNNg",
+ smallImg "youtube.png" $ Just "https://www.youtube.com/channel/UCnNPLiuJ1ueo1KTPgHDE7lA/"
+ ],
+ div_ [class_ "row"] [text "Team | Contact Us | Privacy Policy"]
+ ],
+ div_
+ [id_ "app-foot-quote", css euro]
+ [ p_ [] [text "With great power comes great responsiblity."],
+ p_ [] [text "-Stan Lee"]
+ ],
+ div_
+ [css euro, id_ "app-foot-logo", onClick DumpModel]
+ [ a_ [class_ "social-icon", href_ "#"] [img_ [src_ $ ms $ Assets.icon <> "hero-logo.svg"]],
+ span_ [] [text "© Hero Records, Inc. All Rights Reserved"]
+ ]
]
- ]
where
- attrs Nothing = [ class_ "social-icon" ]
- attrs (Just lnk) = [ class_ "social-icon", href_ lnk, target_ "_blank" ]
- smallImg x lnk = a_ (attrs lnk)
- [ img_ [src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/" <> x ]]
+ attrs Nothing = [class_ "social-icon"]
+ attrs (Just lnk) = [class_ "social-icon", href_ lnk, target_ "_blank"]
+ smallImg x lnk =
+ a_
+ (attrs lnk)
+ [img_ [src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/" <> x]]
comicCover :: ComicId -> Model -> View Action
comicCover comicId_ model = comicPlayer comicId_ 1 model
data ComicReaderView = Spread | Full
- deriving (Show, Eq)
+ deriving (Show, Eq)
comicPlayer :: ComicId -> Page -> Model -> View Action
comicPlayer _ _ model = case appComics model of
- NotAsked -> loading
- Loading -> loading
- Failure _ -> nocomics
- Success comics -> case cpState model of
- NotReading -> template "comic-player" [ text "error: not reading" ]
- Cover id -> viewOr404 comics comicSpread id 1 model
- ChooseExperience id pg ->
- viewOr404 comics chooseExperiencePage id pg model
- Reading Spread id pg -> viewOr404 comics comicSpread id pg model
- Reading Full id pg -> viewOr404 comics zoomScreen id pg model
- Watching id -> viewOr404 comics comicVideo id 0 model
-
-viewOr404 :: [Comic]
- -> (Comic -> Page -> Model -> View Action)
- -> ComicId -> Page -> Model -> View Action
+ NotAsked -> loading
+ Loading -> loading
+ Failure _ -> nocomics
+ Success comics -> case cpState model of
+ NotReading -> template "comic-player" [text "error: not reading"]
+ Cover id -> viewOr404 comics comicSpread id 1 model
+ ChooseExperience id pg ->
+ viewOr404 comics chooseExperiencePage id pg model
+ Reading Spread id pg -> viewOr404 comics comicSpread id pg model
+ Reading Full id pg -> viewOr404 comics zoomScreen id pg model
+ Watching id -> viewOr404 comics comicVideo id 0 model
+
+viewOr404 ::
+ [Comic] ->
+ (Comic -> Page -> Model -> View Action) ->
+ ComicId ->
+ Page ->
+ Model ->
+ View Action
viewOr404 comics f id pg model =
- case findComic id comics of
- Just c -> f c pg model
- Nothing -> the404 model
+ case findComic id comics of
+ Just c -> f c pg model
+ Nothing -> the404 model
template :: MisoString -> [View Action] -> View Action
template id rest = div_ [id_ id, class_ "app is-black"] rest
closeButton :: View Action
-closeButton = a_ [ id_ "close-button", onClick $ ChangeURI discoverLink ]
- [ text "x" ]
+closeButton =
+ a_
+ [id_ "close-button", onClick $ ChangeURI discoverLink]
+ [text "x"]
zoomScreen :: Comic -> Page -> Model -> View Action
-zoomScreen comic page model = template "comic-player"
- [ topbar
- , main_
- [id_ "app-body"]
- [ img_
- [ src_ comicImg
- , class_ "comic-page-full"
- ]
+zoomScreen comic page model =
+ template
+ "comic-player"
+ [ topbar,
+ main_
+ [id_ "app-body"]
+ [ img_
+ [ src_ comicImg,
+ class_ "comic-page-full"
+ ]
+ ],
+ comicControls comic page model
]
- , comicControls comic page model
- ]
- where
- comicImg =
+ where
+ comicImg =
ms Assets.demo
- <> ms (comicSlug comic)
- <> "-"
- <> padLeft page
- <> ".png"
+ <> ms (comicSlug comic)
+ <> "-"
+ <> padLeft page
+ <> ".png"
comicSpread :: Comic -> Page -> Model -> View Action
-comicSpread comic page model = template "comic-player"
- [ topbar
- , main_
- [id_ "app-body"]
- [ div_
- [class_ "comic-player"]
- [ img_ [ src_ comicImgLeft, class_ "comic-page" ]
- , img_ [ src_ comicImgRight, class_ "comic-page" ]
- ]
- , closeButton
+comicSpread comic page model =
+ template
+ "comic-player"
+ [ topbar,
+ main_
+ [id_ "app-body"]
+ [ div_
+ [class_ "comic-player"]
+ [ img_ [src_ comicImgLeft, class_ "comic-page"],
+ img_ [src_ comicImgRight, class_ "comic-page"]
+ ],
+ closeButton
+ ],
+ appmenu,
+ comicControls comic page model
]
- , appmenu
- , comicControls comic page model
- ]
- where
- comicImgLeft, comicImgRight :: MisoString
- comicImgLeft =
+ where
+ comicImgLeft, comicImgRight :: MisoString
+ comicImgLeft =
ms Assets.demo
- <> ms (comicSlug comic)
- <> "-"
- <> padLeft page
- <> ".png"
- comicImgRight =
+ <> ms (comicSlug comic)
+ <> "-"
+ <> padLeft page
+ <> ".png"
+ comicImgRight =
ms Assets.demo
- <> ms (comicSlug comic)
- <> "-"
- <> (padLeft $ 1 + page)
- <> ".png"
+ <> ms (comicSlug comic)
+ <> "-"
+ <> (padLeft $ 1 + page)
+ <> ".png"
frameborder_ :: MisoString -> Attribute action
frameborder_ = textProp "frameborder"
@@ -562,125 +641,147 @@ allowfullscreen_ :: Bool -> Attribute action
allowfullscreen_ = boolProp "allowfullscreen"
comicVideo :: Comic -> Page -> Model -> View Action
-comicVideo _ _ _ = template "comic-player"
- [ topbar
- , main_
- [ id_ "app-body" ]
- [ div_ [class_ "comic-video"]
- [ iframe_
- [ src_ "//player.vimeo.com/video/325757560"
- , frameborder_ "0"
- , allowfullscreen_ True
- ]
- []
+comicVideo _ _ _ =
+ template
+ "comic-player"
+ [ topbar,
+ main_
+ [id_ "app-body"]
+ [ div_
+ [class_ "comic-video"]
+ [ iframe_
+ [ src_ "//player.vimeo.com/video/325757560",
+ frameborder_ "0",
+ allowfullscreen_ True
+ ]
+ []
+ ]
]
- ]
]
padLeft :: Int -> MisoString
-padLeft n | n < 10 = ms $ ("0" <> Legacy.show n)
- | otherwise = ms $ Legacy.show n
+padLeft n
+ | n < 10 = ms $ ("0" <> Legacy.show n)
+ | otherwise = ms $ Legacy.show n
comicControls :: Comic -> Page -> Model -> View Action
-comicControls comic page model = footer_
- [ id_ "app-foot", class_ "comic-controls" ]
- [ div_
- [ class_ "comic-nav-audio"
- , css $ flexCenter ]
- [ audio_
- [id_ audioId, loop_ True, crossorigin_ "anonymous"]
- [source_ [src_ $ ms $ Assets.demo <> "stars-instrumental.mp3"]]
- , el $ PlayPause audioId $ cpAudioState model
- , span_
- [ css $ euro <> thicc <> smol <> wide ]
- [ text "Experiencing: Original" ]
- ]
- , div_
- [ class_ "comic-controls-pages", css euro ]
- [ el $ Arrow $ PrevPage
- , span_ [] [ text $ leftPage <> "-" <> rightPage <> " of " <> totalpages ]
- , el $ Arrow $ NextPage
+comicControls comic page model =
+ footer_
+ [id_ "app-foot", class_ "comic-controls"]
+ [ div_
+ [ class_ "comic-nav-audio",
+ css $ flexCenter
+ ]
+ [ audio_
+ [id_ audioId, loop_ True, crossorigin_ "anonymous"]
+ [source_ [src_ $ ms $ Assets.demo <> "stars-instrumental.mp3"]],
+ el $ PlayPause audioId $ cpAudioState model,
+ span_
+ [css $ euro <> thicc <> smol <> wide]
+ [text "Experiencing: Original"]
+ ],
+ div_
+ [class_ "comic-controls-pages", css euro]
+ [ el $ Arrow $ PrevPage,
+ span_ [] [text $ leftPage <> "-" <> rightPage <> " of " <> totalpages],
+ el $ Arrow $ NextPage
+ ],
+ div_
+ [class_ "comic-controls-share"]
+ [ el $ SaveIcon comic $ userLibrary model,
+ el $ ZoomIcon (zoomModel model) comic page,
+ button_
+ [class_ "button icon is-large", onClick ToggleFullscreen]
+ [i_ [class_ "fa fa-expand"] []]
+ ]
]
- , div_ [class_ "comic-controls-share"]
- [ el $ SaveIcon comic $ userLibrary model
- , el $ ZoomIcon (zoomModel model) comic page
- , button_
- [class_ "button icon is-large", onClick ToggleFullscreen]
- [i_ [ class_ "fa fa-expand" ] []]
- ]
- ]
where
- leftPage = ms . Legacy.show $ page
- rightPage = ms . Legacy.show $ 1 + page
+ leftPage = ms . Legacy.show $ page
+ rightPage = ms . Legacy.show $ 1 + page
totalpages = ms . Legacy.show $ comicPages comic
login :: Model -> View Action
-login _ = template "login"
- [ div_ [ id_ "login-inner" ]
- [ img_ [ class_ fadeIn
- , src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/hero-large.png"
- ]
- , hr_ [class_ fadeIn]
- , form_ [class_ fadeIn]
- [ ctrl [class_ "input", type_ "email", placeholder_ "Email"]
- , ctrl [class_ "input", type_ "password", placeholder_ "Password"]
- , div_ [class_ "action", css euro]
- [ div_ [class_ "checkbox remember-me"]
- [ input_ [type_ "checkbox"]
- , label_ [Miso.for_ "checkbox"] [text "Remember Me"]
- ]
- , div_ [class_ "button is-black", onClick $ ChangeURI discoverLink]
- [ text "Login" ]
- ]
- ]
- , hr_ [class_ fadeIn]
- , p_ [ class_ $ "help " <> fadeIn ]
- [ a_ [href_ "#"][text "Forgot your username or password?"]
- , a_ [href_ "#"][text "Don't have an account? Sign Up"]
- ]
- , img_ [ id_ "hero-logo"
- , class_ "blur-out"
- , src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/success-her-image.png"
- ]
- ]
+login _ =
+ template
+ "login"
+ [ div_
+ [id_ "login-inner"]
+ [ img_
+ [ class_ fadeIn,
+ src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/hero-large.png"
+ ],
+ hr_ [class_ fadeIn],
+ form_
+ [class_ fadeIn]
+ [ ctrl [class_ "input", type_ "email", placeholder_ "Email"],
+ ctrl [class_ "input", type_ "password", placeholder_ "Password"],
+ div_
+ [class_ "action", css euro]
+ [ div_
+ [class_ "checkbox remember-me"]
+ [ input_ [type_ "checkbox"],
+ label_ [Miso.for_ "checkbox"] [text "Remember Me"]
+ ],
+ div_
+ [class_ "button is-black", onClick $ ChangeURI discoverLink]
+ [text "Login"]
+ ]
+ ],
+ hr_ [class_ fadeIn],
+ p_
+ [class_ $ "help " <> fadeIn]
+ [ a_ [href_ "#"] [text "Forgot your username or password?"],
+ a_ [href_ "#"] [text "Don't have an account? Sign Up"]
+ ],
+ img_
+ [ id_ "hero-logo",
+ class_ "blur-out",
+ src_ $ ms $ Assets.cdnEdge <> "/old-assets/images/icons/success-her-image.png"
+ ]
+ ]
]
where
fadeIn = "animated fadeIn delay-2s"
- ctrl x = div_ [class_ "control"] [ input_ x ]
+ ctrl x = div_ [class_ "control"] [input_ x]
chooseExperiencePage :: Comic -> Page -> Model -> View Action
-chooseExperiencePage comic page model = template "choose-experience"
- [ topbar
- , main_ [ id_ "app-body" ]
- [ h2_ [] [ text "Choose Your Musical Experience" ]
- , p_ [] [ text experienceBlurb ]
- , ul_ [] $ li comic </ experiences
- ]
- , appmenu
- , comicControls comic page model
+chooseExperiencePage comic page model =
+ template
+ "choose-experience"
+ [ topbar,
+ main_
+ [id_ "app-body"]
+ [ h2_ [] [text "Choose Your Musical Experience"],
+ p_ [] [text experienceBlurb],
+ ul_ [] $ li comic </ experiences
+ ],
+ appmenu,
+ comicControls comic page model
]
where
- li c (name, artist, track) = li_
- [ onClick $ StartReading c ]
- [ div_ []
- [ img_ [ src_ $ ms $ Assets.demo <> name <> ".png" ]
- , span_ [] [ text $ ms name ]
- ]
- , span_ [ css $ thicc ] [ text $ ms artist ]
- , span_ [] [ text $ ms track ]
+ li c (name, artist, track) =
+ li_
+ [onClick $ StartReading c]
+ [ div_
+ []
+ [ img_ [src_ $ ms $ Assets.demo <> name <> ".png"],
+ span_ [] [text $ ms name]
+ ],
+ span_ [css $ thicc] [text $ ms artist],
+ span_ [] [text $ ms track]
]
experiences :: [(Text, Text, Text)]
experiences =
- [ ("comedic", "RxGF", "Soft Reveal")
- , ("dark", "Logan Henderson", "Speak of the Devil")
- , ("original", "Mehcad Brooks", "Stars")
- , ("energetic", "Skela", "What's wrong with me")
- , ("dramatic", "Josh Jacobson", "Sideline")
- ]
-
+ [ ("comedic", "RxGF", "Soft Reveal"),
+ ("dark", "Logan Henderson", "Speak of the Devil"),
+ ("original", "Mehcad Brooks", "Stars"),
+ ("energetic", "Skela", "What's wrong with me"),
+ ("dramatic", "Josh Jacobson", "Sideline")
+ ]
experienceBlurb :: MisoString
-experienceBlurb = [s|
+experienceBlurb =
+ [s|
As you enter the world of Hero, you will find that music and visual art have a
symbiotic relationship that can only be experienced, not described. Here, choose
the tonality of the experience you wish to adventure on, whether it's a comedic,
@@ -689,33 +790,36 @@ with the original curated music for this piece of visual art.
|]
topbar :: View Action
-topbar = header_
- [id_ "app-head", class_ "is-black", css euro]
- [ a_
- [class_ "button is-medium is-black", onClick $ ChangeURI homeLink]
- [img_ [src_ $ ms $ Assets.icon <> "hero-logo.svg"]]
- , div_
- [id_ "app-head-right"]
- [ button_ [class_ "button icon is-medium is-black"]
- [i_ [class_ "fas fa-search" ] []]
- , button_ [ class_ "button is-medium is-black is-size-7"
- , css $ euro <> wide <> thicc
- ]
- [text "News"]
- , span_ [ class_ "icon is-large" ]
- [ i_ [ class_ "fas fa-user" ] []
+topbar =
+ header_
+ [id_ "app-head", class_ "is-black", css euro]
+ [ a_
+ [class_ "button is-medium is-black", onClick $ ChangeURI homeLink]
+ [img_ [src_ $ ms $ Assets.icon <> "hero-logo.svg"]],
+ div_
+ [id_ "app-head-right"]
+ [ button_
+ [class_ "button icon is-medium is-black"]
+ [i_ [class_ "fas fa-search"] []],
+ button_
+ [ class_ "button is-medium is-black is-size-7",
+ css $ euro <> wide <> thicc
+ ]
+ [text "News"],
+ span_
+ [class_ "icon is-large"]
+ [ i_ [class_ "fas fa-user"] []
+ ]
]
]
- ]
row :: [View Action] -> View Action
-row = div_ [ css $ Clay.display Clay.flex <> Clay.flexDirection Clay.row ]
+row = div_ [css $ Clay.display Clay.flex <> Clay.flexDirection Clay.row]
column :: [View Action] -> View Action
-column = div_ [ css $ Clay.display Clay.flex <> Clay.flexDirection Clay.column ]
+column = div_ [css $ Clay.display Clay.flex <> Clay.flexDirection Clay.column]
-- | Links
-
comicLink :: ComicId -> URI
comicLink comicId_ = linkURI $ safeLink routes comicProxy $ comicId_
@@ -745,4 +849,4 @@ the404 _ = template "404" [p_ [] [text "Not found"]]
chooseExperienceLink :: ComicId -> Page -> URI
chooseExperienceLink id page =
- linkURI $ safeLink routes chooseExperienceProxy id page
+ linkURI $ safeLink routes chooseExperienceProxy id page
diff --git a/Hero/Assets.hs b/Hero/Assets.hs
index 06386b8..2e2d72c 100644
--- a/Hero/Assets.hs
+++ b/Hero/Assets.hs
@@ -1,9 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
+
-- | A module to wrap the CDN and provide convient helper functions to assets.
module Hero.Assets where
-import Protolude
+import Protolude
cdnEdge :: Text
cdnEdge = "https://heroverse.sfo2.cdn.digitaloceanspaces.com"
diff --git a/Hero/Client.hs b/Hero/Client.hs
index 9a8fa02..0472d48 100644
--- a/Hero/Client.hs
+++ b/Hero/Client.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
+
-- | Hero app frontend
--
-- : exe mmc.js
@@ -17,52 +18,55 @@
-- : dep ghcjs-base
module Hero.Client where
-import Hero.App ( Action(..)
- , Comic(..)
- , ComicReaderState(..)
- , ComicReaderView(..)
- , Model(..)
- , AudioState(..)
- , audioId
- , chooseExperienceLink
- , comicPlayerSpreadLink
- , comicPlayerFullLink
- , comicVideoLink
- , handlers
- , initModel
- , the404
- , routes
- )
-import qualified Network.RemoteData as Network
-import Data.Aeson ( eitherDecodeStrict )
+import Data.Aeson (eitherDecodeStrict)
import qualified Data.Set as Set
import qualified GHC.Show as Legacy
-import JavaScript.Web.XMLHttpRequest ( Request(..)
- , Method(GET)
- , RequestData(NoData)
- , contents
- , xhrByteString
- )
-import Miso
-import Miso.Effect.DOM (scrollIntoView)
+import Hero.App
+ ( Action (..),
+ AudioState (..),
+ Comic (..),
+ ComicReaderState (..),
+ ComicReaderView (..),
+ Model (..),
+ audioId,
+ chooseExperienceLink,
+ comicPlayerFullLink,
+ comicPlayerSpreadLink,
+ comicVideoLink,
+ handlers,
+ initModel,
+ routes,
+ the404,
+ )
+import JavaScript.Web.XMLHttpRequest
+ ( Method (GET),
+ Request (..),
+ RequestData (NoData),
+ contents,
+ xhrByteString,
+ )
+import Miso
+import Miso.Effect.DOM (scrollIntoView)
import qualified Miso.FFI.Audio as Audio
import qualified Miso.FFI.Document as Document
import qualified Miso.FFI.Fullscreen as Fullscreen
-import Miso.String
-import Protolude
+import Miso.String
+import qualified Network.RemoteData as Network
+import Protolude
-- | Entry point for a miso application
main :: IO ()
-main = miso $ \currentURI -> App { model = initModel currentURI, .. }
+main = miso $ \currentURI -> App {model = initModel currentURI, ..}
where
- update = move
- view = see
- subs = [ uriSub HandleURI
- , keyboardSub keynav
- ]
- events = defaultEvents
+ update = move
+ view = see
+ subs =
+ [ uriSub HandleURI,
+ keyboardSub keynav
+ ]
+ events = defaultEvents
initialAction = FetchComics
- mountPoint = Nothing
+ mountPoint = Nothing
(∈) :: Ord a => a -> Set a -> Bool
(∈) = Set.member
@@ -70,17 +74,17 @@ main = miso $ \currentURI -> App { model = initModel currentURI, .. }
-- | Keyboard navigation - maps keys to actions.
keynav :: Set Int -> Action
keynav ks
- | 37 ∈ ks = PrevPage -- ^ left arrow
- | 39 ∈ ks = NextPage -- ^ right arrow
- | 191 ∈ ks = DumpModel -- ^ ?
- | 32 ∈ ks = ToggleAudio audioId -- ^ SPC
- | otherwise = NoOp
+ | 37 ∈ ks = PrevPage -- left arrow
+ | 39 ∈ ks = NextPage -- right arrow
+ | 191 ∈ ks = DumpModel -- ?
+ | 32 ∈ ks = ToggleAudio audioId -- SPC
+ | otherwise = NoOp
see :: Model -> View Action
see model =
- case runRoute routes handlers uri model of
- Left _ -> the404 model
- Right v -> v
+ case runRoute routes handlers uri model of
+ Left _ -> the404 model
+ Right v -> v
-- | Console-logging
foreign import javascript unsafe "console.log($1);"
@@ -88,101 +92,104 @@ foreign import javascript unsafe "console.log($1);"
-- | Updates model, optionally introduces side effects
move :: Action -> Model -> Effect Action Model
-move NoOp model = noEff model
+move NoOp model = noEff model
move DumpModel model = model <# do
- say $ ms $ Legacy.show model
- pure NoOp
-move (SelectExperience comic) model = model { cpState = ChooseExperience (comicId comic) 1 }
- <# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1
-move (StartReading comic) model = model { cpState = Reading Spread (comicId comic) 1 }
- <# do pure $ ChangeURI $ comicPlayerSpreadLink (comicId comic) 1
-move (StartWatching comic) model = model { cpState = Watching (comicId comic) }
- <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1
+ say $ ms $ Legacy.show model
+ pure NoOp
+move (SelectExperience comic) model = model {cpState = ChooseExperience (comicId comic) 1}
+ <# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1
+move (StartReading comic) model = model {cpState = Reading Spread (comicId comic) 1}
+ <# do pure $ ChangeURI $ comicPlayerSpreadLink (comicId comic) 1
+move (StartWatching comic) model = model {cpState = Watching (comicId comic)}
+ <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1
move NextPage model = case cpState model of
- Reading Spread id pg ->
- model { cpState = Reading Spread id (pg+2) } <# do
- pure $ ChangeURI $ comicPlayerSpreadLink id (pg+2)
- Reading Full id pg ->
- model { cpState = Reading Full id (pg+1) } <# do
- pure $ ChangeURI $ comicPlayerFullLink id (pg+1)
- Cover id ->
- model { cpState = Reading Spread id 1 } <# do
- pure $ ChangeURI $ comicPlayerSpreadLink id 1
- _ -> noEff model
+ Reading Spread id pg ->
+ model {cpState = Reading Spread id (pg + 2)} <# do
+ pure $ ChangeURI $ comicPlayerSpreadLink id (pg + 2)
+ Reading Full id pg ->
+ model {cpState = Reading Full id (pg + 1)} <# do
+ pure $ ChangeURI $ comicPlayerFullLink id (pg + 1)
+ Cover id ->
+ model {cpState = Reading Spread id 1} <# do
+ pure $ ChangeURI $ comicPlayerSpreadLink id 1
+ _ -> noEff model
move PrevPage model = case cpState model of
- Reading Spread id pg ->
- model { cpState = Reading Spread id (pg-2) } <# do
- pure $ ChangeURI $ comicPlayerSpreadLink id (pg-2)
- Reading Full id pg ->
- model { cpState = Reading Full id (pg-1) } <# do
- pure $ ChangeURI $ comicPlayerFullLink id (pg-1)
- Cover _ -> noEff model
- _ -> noEff model
-move (ToggleZoom c pg) m = m { cpState = newState } <# do pure act
- where
- 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 comicPlayerSpreadLink)
- Reading Spread _ _ -> (reading Full, goto comicPlayerFullLink)
- x -> (x, NoOp)
-move (ToggleInLibrary c) model = model { userLibrary = newLib } <# pure NoOp
- where
- newLib | c `elem` (userLibrary model) =
- Protolude.filter (/= c) $ userLibrary model
- | otherwise = c : (userLibrary model)
-move (HandleURI u) model = model { uri = u } <# pure NoOp
+ Reading Spread id pg ->
+ model {cpState = Reading Spread id (pg -2)} <# do
+ pure $ ChangeURI $ comicPlayerSpreadLink id (pg -2)
+ Reading Full id pg ->
+ model {cpState = Reading Full id (pg -1)} <# do
+ pure $ ChangeURI $ comicPlayerFullLink id (pg -1)
+ Cover _ -> noEff model
+ _ -> noEff model
+move (ToggleZoom c pg) m = m {cpState = newState} <# do pure act
+ where
+ 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 comicPlayerSpreadLink)
+ Reading Spread _ _ -> (reading Full, goto comicPlayerFullLink)
+ x -> (x, NoOp)
+move (ToggleInLibrary c) model = model {userLibrary = newLib} <# pure NoOp
+ where
+ newLib
+ | c `elem` (userLibrary model) =
+ Protolude.filter (/= c) $ userLibrary model
+ | otherwise = c : (userLibrary model)
+move (HandleURI u) model = model {uri = u} <# pure NoOp
move (ChangeURI u) model = model <# do
pushURI u
pure NoOp
-move FetchComics model = model <# (SetComics <$> fetchComics)
-move (SetComics cs) model = noEff model { appComics = cs }
-move (ToggleAudio i ) model = model { cpAudioState = newState } <# do
+move FetchComics model = model <# (SetComics <$> fetchComics)
+move (SetComics cs) model = noEff model {appComics = cs}
+move (ToggleAudio i) model = model {cpAudioState = newState} <# do
el <- Document.getElementById i
toggle el
pure NoOp
- where
- (newState, toggle) = case cpAudioState model of
- Playing -> (Paused, Audio.pause)
- Paused -> (Playing, Audio.play)
-move ToggleFullscreen model = model { 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 model 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) model = model { dMediaInfo = x } <# do
- case x of
- Just Comic {comicId = id} ->
- pure $ ScrollIntoView $ "comic-" <> ms id
- Nothing ->
- pure NoOp
+ (newState, toggle) = case cpAudioState model of
+ Playing -> (Paused, Audio.pause)
+ Paused -> (Playing, Audio.play)
+move ToggleFullscreen model = model {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 model 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) model = model {dMediaInfo = x} <# do
+ case x of
+ Just Comic {comicId = id} ->
+ pure $ ScrollIntoView $ "comic-" <> ms id
+ Nothing ->
+ pure NoOp
move (ScrollIntoView id) model = model <# do
- say $ ms $ Legacy.show id
- scrollIntoView id
- pure NoOp
+ say $ ms $ Legacy.show id
+ scrollIntoView id
+ pure NoOp
fetchComics :: IO (Network.RemoteData MisoString [Comic])
fetchComics = do
mjson <- contents <$> xhrByteString req
case mjson of
- Nothing ->
+ Nothing ->
pure $ Network.Failure "Could not fetch comics from server."
- Just json -> pure $ Network.fromEither
- $ either (Left . ms) pure
- $ eitherDecodeStrict json
- where
- req = Request
- { reqMethod = GET
- , reqURI = "/api/comic" -- FIXME: can we replace this hardcoding?
- , reqLogin = Nothing
- , reqHeaders = []
- , reqWithCredentials = False
- , reqData = NoData
- }
+ Just json ->
+ pure $ Network.fromEither
+ $ either (Left . ms) pure
+ $ eitherDecodeStrict json
+ where
+ req =
+ Request
+ { reqMethod = GET,
+ reqURI = "/api/comic", -- FIXME: can we replace this hardcoding?
+ reqLogin = Nothing,
+ reqHeaders = [],
+ reqWithCredentials = False,
+ reqData = NoData
+ }
diff --git a/Hero/Database.hs b/Hero/Database.hs
index 5726f3c..0166c6f 100644
--- a/Hero/Database.hs
+++ b/Hero/Database.hs
@@ -2,20 +2,21 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
+
module Hero.Database
- ( ComicDB
- , getComics
- , load
- , dummy
+ ( ComicDB,
+ getComics,
+ load,
+ dummy,
)
where
-import Hero.App
-import Data.Map ( Map )
-import qualified Data.Map as Map
-import Dhall
-import Protolude
-import Servant ( Handler )
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Dhall
+import Hero.App
+import Protolude
+import Servant (Handler)
type ComicDB = (Map ComicId Comic)
@@ -25,14 +26,17 @@ load :: IO ComicDB
load = listToComicDB <$> input auto "./comic-database.dhall"
dummy :: IO ComicDB
-dummy = return $ listToComicDB
- [ Comic { comicId = "ComicId"
- , comicPages = 10
- , comicName = "Dummy comic"
- , comicIssue = "dummy issue"
- , comicDescription = "Lorem ipsum"
+dummy =
+ return $
+ listToComicDB
+ [ Comic
+ { comicId = "ComicId",
+ comicPages = 10,
+ comicName = "Dummy comic",
+ comicIssue = "dummy issue",
+ comicDescription = "Lorem ipsum"
}
- ]
+ ]
listToComicDB :: [Comic] -> ComicDB
listToComicDB ls = Map.fromList $ (,) <$> comicId <*> identity <$> ls
diff --git a/Hero/Look.hs b/Hero/Look.hs
index 109ea76..662b223 100644
--- a/Hero/Look.hs
+++ b/Hero/Look.hs
@@ -1,6 +1,6 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Styles
--
@@ -8,17 +8,17 @@
-- http://fvisser.nl/clay/
module Hero.Look where
-import Clay
+import Clay
import qualified Clay.Flexbox as Flexbox
import qualified Clay.Media as Media
import qualified Clay.Render as Clay
import qualified Clay.Stylesheet as Stylesheet
-import Hero.Look.Typography as Typo
import qualified Data.Map as Map
import qualified Data.Text.Lazy as L
-import Miso (Attribute, (=:), style_)
-import Miso.String (MisoString, toMisoString)
-import Protolude hiding ((**), (&), rem)
+import Hero.Look.Typography as Typo
+import Miso ((=:), Attribute, style_)
+import Miso.String (MisoString, toMisoString)
+import Protolude hiding ((&), (**), rem)
main :: Css
main = do
@@ -28,41 +28,43 @@ main = do
".fixed" ? position fixed
".clickable" ? clickable
".row" ? do
- display flex
- alignItems center
- justifyContent spaceBetween
+ display flex
+ alignItems center
+ justifyContent spaceBetween
a <> a # hover <> a # visited ? do
- color white
- textDecoration none
+ color white
+ textDecoration none
".loading" ? do
- display flex
- justifyContent center
- alignItems center
- height $ vh 100
- width $ vw 100
+ display flex
+ justifyContent center
+ alignItems center
+ height $ vh 100
+ width $ vw 100
-- animations
".grow" ? do
- transition "all" (sec 0.2) easeInOut (sec 0.2)
- ":hover" & transform (scale 1.1 1.1)
+ transition "all" (sec 0.2) easeInOut (sec 0.2)
+ ":hover" & transform (scale 1.1 1.1)
".blur-out" ? do
- position absolute
- animation
- "blur"
- (sec 1)
- easeInOut
- (sec 1)
- (iterationCount 1)
- normal
- forwards
- keyframes "blur" [ (0, Clay.filter $ blur (px 0))
- , (50, Clay.filter $ blur (px 0))
- , (100, Clay.filter $ blur (px 10))
- ]
+ position absolute
+ animation
+ "blur"
+ (sec 1)
+ easeInOut
+ (sec 1)
+ (iterationCount 1)
+ normal
+ forwards
+ keyframes
+ "blur"
+ [ (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
- overflowX hidden
- width (vw 100)
+ background nite
+ mobile $ do
+ overflowX hidden
+ width (vw 100)
-- general app wrapper stuf
".app" ? do
display flex
@@ -73,386 +75,376 @@ main = do
"#hero-logo" ? zIndex (-1)
"#app-head" <> "#app-body" <> "#app-foot" ? flexGrow 1
"#app-head" <> "#app-foot" ? do
- display flex
- alignItems center
- flexShrink 0
- justifyContent spaceBetween
- padding 0 (rem 2) 0 (rem 2)
- width (pct 100)
- height (px navbarHeight)
- background nite
- position fixed
- zIndex 999
+ display flex
+ alignItems center
+ flexShrink 0
+ justifyContent spaceBetween
+ padding 0 (rem 2) 0 (rem 2)
+ width (pct 100)
+ height (px navbarHeight)
+ background nite
+ position fixed
+ zIndex 999
"#app-head" ? do
- alignSelf flexStart
- borderBottom solid (px 3) grai
- wide
- top (px 0)
- mobile $ noBorder <> width (vw 100)
+ alignSelf flexStart
+ borderBottom solid (px 3) grai
+ wide
+ top (px 0)
+ mobile $ noBorder <> width (vw 100)
"#app-body" ? do
- display flex
- 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
+ display flex
+ 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
"#app-head-right" ? do
- display flex
- justifyContent spaceBetween
- textTransform Clay.uppercase
- thicc
- alignItems center
- width (px 200)
+ display flex
+ justifyContent spaceBetween
+ textTransform Clay.uppercase
+ thicc
+ alignItems center
+ width (px 200)
"#app-foot" ? do
- alignSelf flexEnd
- bottom (px 0)
- mobile $ remove
+ alignSelf flexEnd
+ bottom (px 0)
+ mobile $ remove
"#app-foot-social" ? do
- display flex
- flexDirection column
- alignSelf flexStart
- ".social-icon" ? padding 0 (px 20) (px 10) 0
+ display flex
+ flexDirection column
+ alignSelf flexStart
+ ".social-icon" ? padding 0 (px 20) (px 10) 0
"#app-foot-logo" ? do
- display flex
- flexDirection column
- alignItems flexEnd
+ display flex
+ flexDirection column
+ alignItems flexEnd
"#app-foot-quote" ? do
- textTransform Clay.uppercase
- textAlign center
- -- hide app-foot-quote when it gets crowded
- query Clay.all [Media.maxDeviceWidth (px 800)] $
- hide
-
+ textTransform Clay.uppercase
+ textAlign center
+ -- hide app-foot-quote when it gets crowded
+ query Clay.all [Media.maxDeviceWidth (px 800)] $
+ hide
-- login
"#login" ? do
- -- TODO: next 3 lines can be DRYed up, methinks
- display flex
- justifyContent center
- alignItems center
- alignSelf center
- height (vh 100)
+ -- TODO: next 3 lines can be DRYed up, methinks
+ display flex
+ justifyContent center
+ alignItems center
+ alignSelf center
+ height (vh 100)
"#login-inner" ? do
- display flex
- justifyContent center
- alignItems center
- flexDirection column
- zIndex 1
- height (vh 100)
- width (px 400)
- mobile $ width (vw 90)
+ display flex
+ justifyContent center
+ alignItems center
+ flexDirection column
+ zIndex 1
+ height (vh 100)
+ width (px 400)
+ mobile $ width (vw 90)
"#login" ** ".help" ** a ? do
- color white
- display flex
- alignItems center
- flexDirection column
+ color white
+ display flex
+ alignItems center
+ flexDirection column
"#login" ** form <> "#login" ** hr ? do
- width (pct 100)
+ width (pct 100)
"#login" ** hr ? border solid (px 1) grai
"#login" ** ".button" ? do
- marginTop (px 10)
- display inlineBlock
- border solid (px 2) white
+ marginTop (px 10)
+ display inlineBlock
+ border solid (px 2) white
"#login" ** ".action" ? do
- display flex
- justifyContent spaceBetween
- alignItems baseline
-
+ display flex
+ justifyContent spaceBetween
+ alignItems baseline
-- choose your experience
"#choose-experience" ** "#app-body" ? do
- euro <> wide
- flexCenter
- width (pct 100)
- 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
- p ? do
- thicc <> coat 0.8 <> textAlign center
- maxWidth (px 900)
- marginAll (rem 1)
- mobile $ coat 0.6
- ul ? do
- display flex
- flexDirection row
- flexWrap Flexbox.wrap
- justifyContent spaceAround
- li ? do
- width (px 111)
- position relative
- display flex
- flexDirection column
- textAlign center
- mobile $ coat 0.6
- coat 0.8 <> clickable
- divv <? do
- position relative
- flexCenter
- flexDirection column
- span <? do
- position absolute
- width (pct 100)
- smol <> thicc
-
-
-
+ euro <> wide
+ flexCenter
+ width (pct 100)
+ 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
+ p ? do
+ thicc <> coat 0.8 <> textAlign center
+ maxWidth (px 900)
+ marginAll (rem 1)
+ mobile $ coat 0.6
+ ul ? do
+ display flex
+ flexDirection row
+ flexWrap Flexbox.wrap
+ justifyContent spaceAround
+ li ? do
+ width (px 111)
+ position relative
+ display flex
+ flexDirection column
+ textAlign center
+ mobile $ coat 0.6
+ coat 0.8 <> clickable
+ divv <? do
+ position relative
+ flexCenter
+ flexDirection column
+ span <? do
+ position absolute
+ width (pct 100)
+ smol <> thicc
-- comic player
".comic-player" ? marginAll auto
".comic-page" <> ".comic-page-full" ? do
- width auto
- marginAll auto
- transform (scale 1 1)
+ width auto
+ marginAll auto
+ transform (scale 1 1)
".comic-page" ? height (vh 90)
let ccb = ".comic-controls" ** button
ccb <> ccb # hover ? do
- background nite
- borderColor nite
- color white
+ background nite
+ borderColor nite
+ color white
".comic-controls-pages" ? do
- justifyContent center
- alignItems center
- display flex
+ justifyContent center
+ alignItems center
+ display flex
".comic-video" |> iframe ? do
- position absolute
- height (pct 93)
- width (pct 100)
+ position absolute
+ height (pct 93)
+ width (pct 100)
"#close-button" ? do
- euro <> wide
- position fixed
- cursor pointer
- let z = rem 1.8
- fontSize z
- lineHeight z
- let m = 24 :: Double
- top $ px $ navbarHeight + m
- left $ px $ m
- zIndex 999
-
+ euro <> wide
+ position fixed
+ cursor pointer
+ let z = rem 1.8
+ fontSize z
+ lineHeight z
+ let m = 24 :: Double
+ top $ px $ navbarHeight + m
+ left $ px $ m
+ zIndex 999
-- zoom button and slider
"#zoom-button" ? do
- position relative
- let sliderY = 75
- let sliderYY = 250
- euro <> wide
- input ? do
- transform $ Clay.rotate (deg (-90))
- margin 0 0 (px sliderYY) 0
- position absolute
- height $ px sliderY
- width $ px 200
- hide
- label ? do
- coat 0.9
- marginBottom $ px $ 2*sliderYY
- position absolute
- hide
- ":hover" & ".ctrl" ? visibility visible
-
+ position relative
+ let sliderY = 75
+ let sliderYY = 250
+ euro <> wide
+ input ? do
+ transform $ Clay.rotate (deg (-90))
+ margin 0 0 (px sliderYY) 0
+ position absolute
+ height $ px sliderY
+ width $ px 200
+ hide
+ label ? do
+ coat 0.9
+ marginBottom $ px $ 2 * sliderYY
+ position absolute
+ hide
+ ":hover" & ".ctrl" ? visibility visible
-- discover
"#discover" ? do
- alignItems flexStart
- flexDirection column
+ alignItems flexStart
+ flexDirection column
".media-info" ? do
- padding (rem 2) 0 (rem 2) (rem 2)
- margin (rem 2) 0 (rem 2) (rem 2)
- borderTop solid (px 1) white
- borderBottom solid (px 1) white
- flexDirection row
- display flex
- alignItems center
- justifyContent spaceBetween
- mobile $ do
- margin (rem 2) 0 (rem 2) 0
- padding 0 0 0 (rem 0)
- noBorder
- width (vw 100)
- flexDirection column
+ padding (rem 2) 0 (rem 2) (rem 2)
+ margin (rem 2) 0 (rem 2) (rem 2)
+ borderTop solid (px 1) white
+ borderBottom solid (px 1) white
+ flexDirection row
+ display flex
+ alignItems center
+ justifyContent spaceBetween
+ mobile $ do
+ margin (rem 2) 0 (rem 2) 0
+ padding 0 0 0 (rem 0)
+ noBorder
+ width (vw 100)
+ flexDirection column
".media-info-meta" ? do
- Flexbox.flex 2 1 (px 0)
- display flex
- flexDirection row
- divv # lastChild <? paddingLeft (rem 1)
- mobile $ do
- width (vw 90) -- this line can be commented if you want to center the meta
- img ? width (px 150)
- order (-1)
- Flexbox.flex 1 1 (auto)
+ Flexbox.flex 2 1 (px 0)
+ display flex
+ flexDirection row
+ divv # lastChild <? paddingLeft (rem 1)
+ mobile $ do
+ width (vw 90) -- this line can be commented if you want to center the meta
+ img ? width (px 150)
+ order (-1)
+ Flexbox.flex 1 1 (auto)
".media-info-summary" ? do
- Flexbox.flex 2 1 (px 0)
- paddingRight (rem 3)
- mobile $ do
- marginAll (rem 1)
- padding 0 0 0 (rem 0)
+ Flexbox.flex 2 1 (px 0)
+ paddingRight (rem 3)
+ mobile $ do
+ marginAll (rem 1)
+ padding 0 0 0 (rem 0)
".media-info-actions" ? do
- Flexbox.flex 1 1 (px 132)
- maxWidth (px 132)
- display flex
- flexDirection column
- justifyContent spaceAround
- mobile $ do
- maxWidth (vw 100)
- flexDirection row
- order (1)
- flexBasis auto -- initial
- height (px 50)
-
+ Flexbox.flex 1 1 (px 132)
+ maxWidth (px 132)
+ display flex
+ flexDirection column
+ justifyContent spaceAround
+ mobile $ do
+ maxWidth (vw 100)
+ flexDirection row
+ order (1)
+ flexBasis auto -- initial
+ height (px 50)
-- appmenu
"#appmenu" ? do
- euro <> wide
- fontVariant smallCaps
- position fixed
- height (pct 100)
+ euro <> wide
+ fontVariant smallCaps
+ position fixed
+ height (pct 100)
+ display flex
+ justifyContent center
+ zIndex 99
+ alignContent center
+ alignItems center
+ flexDirection column
+ minWidth appmenuWidth
+ a ? do
display flex
+ flexDirection column
+ color white
+ background nite
+ borderColor nite
+ a |> img ? do
+ width (px 22)
+ height (px 22)
+ desktop $ a |> span ? remove
+ mobile $ do
+ order 2
+ flexDirection row
+ position fixed
+ bottom (px 0)
+ width (vw 100)
+ height (px 74)
+ background nite
justifyContent center
- zIndex 99
- alignContent center
alignItems center
- flexDirection column
- minWidth appmenuWidth
- a ? do
- display flex
- flexDirection column
- color white
- background nite
- borderColor nite
- a |> img ? do
- width (px 22)
- height (px 22)
- desktop $ a |> span ? remove
- mobile $ do
- order 2
- flexDirection row
- position fixed
- bottom (px 0)
- width (vw 100)
- height (px 74)
- background nite
- justifyContent center
- alignItems center
- a |> span ? fontSize (rem 0.5)
-
- button ? margin (rem 0.5) 0 (rem 0.5) 0
-
+ a |> span ? fontSize (rem 0.5)
+ button ? margin (rem 0.5) 0 (rem 0.5) 0
-- feature
"#featured-comic" ? do
- display flex
- flexDirection column
- justifyContent center
- Typo.euro
- height (px 411)
- mobile $ do
- padding (px 0) 0 0 0
- margin 0 0 (px 50) 0
- after & do
- display block
- position relative
- background $ linearGradient (straight sideTop)
- [ (setA 0 nite, (pct 0))
- , (nite, (pct 100)) ]
- let h = 149
- marginTop (px (-h))
- -- without +1, the gradient is offset by 1 px in chrome
- height (px (h+1))
- content blank
- ".hero-original" ? do
- textTransform Clay.uppercase
- fontSize (rem 1.2)
- ".description" ? do
- width (px 400)
- mobile $ remove
- "#featured-banner" ? do
+ display flex
+ flexDirection column
+ justifyContent center
+ Typo.euro
+ height (px 411)
+ mobile $ do
+ padding (px 0) 0 0 0
+ margin 0 0 (px 50) 0
+ after & do
+ display block
position relative
- minHeight (px 411)
- minWidth (px 1214)
- mobile $ marginLeft (px (-310))
+ background $
+ linearGradient
+ (straight sideTop)
+ [ (setA 0 nite, (pct 0)),
+ (nite, (pct 100))
+ ]
+ let h = 149
+ marginTop (px (- h))
+ -- without +1, the gradient is offset by 1 px in chrome
+ height (px (h + 1))
+ content blank
+ ".hero-original" ? do
+ textTransform Clay.uppercase
+ fontSize (rem 1.2)
+ ".description" ? do
+ width (px 400)
+ mobile $ remove
+ "#featured-banner" ? do
+ position relative
+ minHeight (px 411)
+ minWidth (px 1214)
+ 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
- marginTop (px 200)
- alignItems center
- display flex
- flexDirection column
- padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5)
- width (vw 100)
-
-
+ position absolute
+ width (pct 100)
+ zIndex 9
+ top (px 200) -- b/c Firefox & WebKit autocalc "top" differently
+ mobile $ do
+ marginTop (px 200)
+ alignItems center
+ display flex
+ flexDirection column
+ padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5)
+ width (vw 100)
-- buttons
- "a.wrs-button" ? do -- the "watch/read/save" button
- flexCenter
- height (px 36)
- width (px 132)
- border solid (px 2) white
- rounded
- color white
- margin 0 (px 15) (rem 1) 0
- fontSize (rem 0.8)
- fontVariant smallCaps
- euro <> thicc <> wide
- mobile $ do
- height (px 26)
- width (px 100)
- margin 0 (px 5) 0 (px 5)
- fontSize (rem 0.6)
- let alive = backgroundColor hero <> borderColor hero <> color white
- ":hover" & alive
- ".saved" & alive
- img ? do
- marginRight (px 7)
- height (px 15)
- mobile $ height (px 10)
-
+ "a.wrs-button" ? do
+ -- the "watch/read/save" button
+ flexCenter
+ height (px 36)
+ width (px 132)
+ border solid (px 2) white
+ rounded
+ color white
+ margin 0 (px 15) (rem 1) 0
+ fontSize (rem 0.8)
+ fontVariant smallCaps
+ euro <> thicc <> wide
+ mobile $ do
+ height (px 26)
+ width (px 100)
+ margin 0 (px 5) 0 (px 5)
+ fontSize (rem 0.6)
+ let alive = backgroundColor hero <> borderColor hero <> color white
+ ":hover" & alive
+ ".saved" & alive
+ img ? do
+ marginRight (px 7)
+ height (px 15)
+ mobile $ height (px 10)
--
".comic-action-menu" ? display flex <> justifyContent (JustifyContentValue "left")
-
-- shelving
".shelf" ? do
+ display flex
+ flexDirection column
+ justifyContent flexStart
+ alignItems flexStart
+ mobile $ do
+ padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5)
+ width (vw 100)
+ ".comic" ? do
display flex
flexDirection column
- justifyContent flexStart
- alignItems flexStart
- mobile $ do
- padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5)
- width (vw 100)
- ".comic" ? do
- display flex
- flexDirection column
- justifyContent center
- textAlign center
- euro
- maxWidth (px 110)
- img ? do
- marginBottom (rem 0.5)
- minHeight (px 170)
- minWidth (px 110)
+ justifyContent center
+ textAlign center
+ euro
+ maxWidth (px 110)
+ img ? do
+ marginBottom (rem 0.5)
+ minHeight (px 170)
+ minWidth (px 110)
".shelf-head" ? do
- width (pct 100)
- margin (rem 1.5) 0 (rem 1.5) 0
- borderBottom solid (px 1) white
- padding (rem 0.5) 0 0.5 0
- euro <> thicc
+ width (pct 100)
+ margin (rem 1.5) 0 (rem 1.5) 0
+ borderBottom solid (px 1) white
+ padding (rem 0.5) 0 0.5 0
+ euro <> thicc
".shelf-body" ? do
- display flex
- flexDirection row
- justifyContent spaceBetween
- width (vw 93)
- alignItems baseline
- li ? padding 0 (rem 0.5) 0 (rem 0.5)
- overflowY visible
- star ? overflowY visible
- overflowX scroll
- flexWrap Flexbox.nowrap
- li <? do
- margin 0 (rem 1) (rem 1) 0
- Flexbox.flex 0 0 auto
+ display flex
+ flexDirection row
+ justifyContent spaceBetween
+ width (vw 93)
+ alignItems baseline
+ li ? padding 0 (rem 0.5) 0 (rem 0.5)
+ overflowY visible
+ star ? overflowY visible
+ overflowX scroll
+ flexWrap Flexbox.nowrap
+ li <? do
+ margin 0 (rem 1) (rem 1) 0
+ Flexbox.flex 0 0 auto
navbarHeight :: Double
navbarHeight = 74
@@ -484,11 +476,11 @@ appmenuWidth = (px 67)
flexCenter :: Css
flexCenter = do
- display flex
- justifyContent center
- justifyItems center
- alignContent center
- alignItems center
+ display flex
+ justifyContent center
+ justifyItems center
+ alignContent center
+ alignItems center
blank :: Content
blank = stringContent ""
@@ -511,10 +503,10 @@ clickable = cursor pointer
-- heroic colors ---------------------------------------------------------------
hero :: Color
-hero = rgb 241 32 32 -- #f12020
+hero = rgb 241 32 32 -- #f12020
nite :: Color
-nite = rgb 10 10 10 -- #0a0a0a
+nite = rgb 10 10 10 -- #0a0a0a
grai :: Color
grai = rgb 221 221 221 -- #dddddd
@@ -528,11 +520,11 @@ grai = rgb 221 221 221 -- #dddddd
-- hacky, but works.
css :: Clay.Css -> Attribute action
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)
+ where
+ f :: L.Text -> [(MisoString, MisoString)]
+ f t = L.splitOn ";" t
+ <&> L.splitOn ":"
+ <&> \(x : y) -> (toMisoString x, toMisoString $ L.intercalate ":" y)
inlineCss :: Css -> MisoString
inlineCss = toMisoString . render
@@ -558,10 +550,17 @@ uppercase = "text-transform" =: "uppercase"
-- upstream this to Clay
---------------------------------------------------------------------------------
-
newtype JustifyItemsValue = JustifyItemsValue Value
- deriving (Val, Other, Inherit, Center, FlexEnd
- , FlexStart, SpaceAround, SpaceBetween)
+ deriving
+ ( Val,
+ Other,
+ Inherit,
+ Center,
+ FlexEnd,
+ FlexStart,
+ SpaceAround,
+ SpaceBetween
+ )
justifyItems :: JustifyItemsValue -> Css
justifyItems = Stylesheet.key "justify-items"
diff --git a/Hero/Look/Typography.hs b/Hero/Look/Typography.hs
index 4d4f976..6358ef3 100644
--- a/Hero/Look/Typography.hs
+++ b/Hero/Look/Typography.hs
@@ -1,13 +1,14 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module Hero.Look.Typography where
-import Alpha
-import Clay
-import Clay.Stylesheet ( key )
-import qualified Hero.Assets as Assets
-import Data.Semigroup ( (<>) )
+import Alpha
+import Clay
+import Clay.Stylesheet (key)
+import Data.Semigroup ((<>))
+import qualified Hero.Assets as Assets
main :: Css
main = fonts
@@ -15,25 +16,28 @@ main = fonts
-- font modifiers
euro, slim, wide, thicc, thinn, norm, lean, smol, lower, upper :: Css
-
euro = fontFamily ["Eurostile"] [sansSerif]
-- | stretch
slim = fontStretch condensed
+
wide = fontStretch expanded
-- | weight
thicc = fontWeight bold
+
thinn = fontWeight normal
-- | style
norm = fontStyle normal
+
lean = fontStyle italic
-- | "smallcaps" is already taken by Clay
smol = fontVariant smallCaps
lower = textTransform lowercase
+
upper = textTransform uppercase
-- | font sizing
@@ -48,21 +52,21 @@ fontRoot = Assets.cdnEdge <> "/old-assets/fonts/eurostile/Eurostile"
-- | font faces
fonts :: Css
fonts =
- mconcat
- $ mkEuro
- </ [ ("-Reg.otf" , OpenType, fontWeight normal <> fontStyle normal)
- , ("LTStd-Bold.otf" , OpenType, thicc <> norm)
- , ("LTStd-Cn.otf" , OpenType, slim <> norm)
- , ("LTStd-Ex2.otf" , OpenType, wide <> norm)
- , ("LTStd-BoldCn.otf" , OpenType, slim <> thicc)
- , ("LTStd-BoldEx2.otf", OpenType, wide <> thicc)
- ]
- where
- mkEuro :: (Text, FontFaceFormat, Css) -> Css
- mkEuro (sufx, fmt, extra) = fontFace $ do
- fontFamily ["Eurostile"] []
- fontFaceSrc [FontFaceSrcUrl (fontRoot <> sufx) $ Just fmt]
- extra
+ mconcat $
+ mkEuro
+ </ [ ("-Reg.otf", OpenType, fontWeight normal <> fontStyle normal),
+ ("LTStd-Bold.otf", OpenType, thicc <> norm),
+ ("LTStd-Cn.otf", OpenType, slim <> norm),
+ ("LTStd-Ex2.otf", OpenType, wide <> norm),
+ ("LTStd-BoldCn.otf", OpenType, slim <> thicc),
+ ("LTStd-BoldEx2.otf", OpenType, wide <> thicc)
+ ]
+ where
+ mkEuro :: (Text, FontFaceFormat, Css) -> Css
+ mkEuro (sufx, fmt, extra) = fontFace $ do
+ fontFamily ["Eurostile"] []
+ fontFaceSrc [FontFaceSrcUrl (fontRoot <> sufx) $ Just fmt]
+ extra
-- TODO: add the below to Clay.Font upstream
diff --git a/Hero/Server.hs b/Hero/Server.hs
index 730aada..450bd0d 100644
--- a/Hero/Server.hs
+++ b/Hero/Server.hs
@@ -1,15 +1,16 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
-- | Hero web app
--
-- : exe mmc
@@ -40,56 +41,59 @@
module Hero.Server where
import qualified Clay
-import Hero.App
-import qualified Hero.Assets as Assets
+import Data.Aeson
+import Data.Proxy
+import Data.Text (Text)
+import qualified Data.Text.Lazy as Lazy
+import qualified Data.Text.Lazy.Encoding as Lazy
+import GHC.Generics
+import Hero.App
+import qualified Hero.Assets as Assets
import qualified Hero.Database as Database
-import qualified Hero.Look as Look
-import qualified Hero.Look.Typography
- as Typography
-import Data.Aeson
-import Data.Proxy
-import Data.Text ( Text )
-import qualified Data.Text.Lazy as Lazy
-import qualified Data.Text.Lazy.Encoding as Lazy
-import GHC.Generics
-import qualified Lucid as L
-import Lucid.Base
-import Miso
-import Miso.String
-import Network.HTTP.Media ( (//)
- , (/:)
- )
-import Network.HTTP.Types hiding ( Header )
-import Network.Wai
-import Network.Wai.Application.Static
-import qualified Network.Wai.Handler.Warp as Warp
-import Protolude
-import Servant
-import qualified System.Envy as Envy
-import qualified System.Exit as Exit
-import qualified System.IO as IO
-
+import qualified Hero.Look as Look
+import qualified Hero.Look.Typography as Typography
+import qualified Lucid as L
+import Lucid.Base
+import Miso
+import Miso.String
+import Network.HTTP.Media
+ ( (//),
+ (/:),
+ )
+import Network.HTTP.Types hiding (Header)
+import Network.Wai
+import Network.Wai.Application.Static
+import qualified Network.Wai.Handler.Warp as Warp
+import Protolude
+import Servant
+import qualified System.Envy as Envy
+import qualified System.Exit as Exit
+import qualified System.IO as IO
main :: IO ()
main = bracket startup shutdown $ uncurry Warp.run
- where
- say = IO.hPutStrLn IO.stderr
- startup = Envy.decodeEnv >>= \case
- Left e -> Exit.die e
- Right c -> do
- db <- Database.dummy
- say $ "hero"
- say $ "port: " ++ (show $ heroPort c)
- say $ "client: " ++ heroClient c
- let waiapp = app db c
- return (heroPort c, waiapp)
- shutdown :: a -> IO a
- shutdown = pure . identity
-
-data Config = Config
- { heroPort :: Warp.Port -- ^ HERO_PORT
- , heroClient :: FilePath -- ^ HERO_CLIENT
- } deriving (Generic, Show)
+ where
+ say = IO.hPutStrLn IO.stderr
+ startup = Envy.decodeEnv >>= \case
+ Left e -> Exit.die e
+ Right c -> do
+ db <- Database.dummy
+ say $ "hero"
+ say $ "port: " ++ (show $ heroPort c)
+ say $ "client: " ++ heroClient c
+ let waiapp = app db c
+ return (heroPort c, waiapp)
+ shutdown :: a -> IO a
+ shutdown = pure . identity
+
+data Config
+ = Config
+ { -- | HERO_PORT
+ heroPort :: Warp.Port,
+ -- | HERO_CLIENT
+ heroClient :: FilePath
+ }
+ deriving (Generic, Show)
instance Envy.DefConfig Config where
defConfig = Config 3000 "_bild/Hero.Client/static"
@@ -97,17 +101,18 @@ instance Envy.DefConfig Config where
instance Envy.FromEnv Config
app :: Database.ComicDB -> Config -> Application
-app db cfg = serve
- (Proxy @AllRoutes)
- ( static
- :<|> cssHandlers
- :<|> jsonHandlers db
- :<|> serverHandlers
- :<|> pure heroManifest
- :<|> Tagged handle404
- )
- where static = serveDirectoryWith $ defaultWebAppSettings $ heroClient cfg
-
+app db cfg =
+ serve
+ (Proxy @AllRoutes)
+ ( static
+ :<|> cssHandlers
+ :<|> jsonHandlers db
+ :<|> serverHandlers
+ :<|> pure heroManifest
+ :<|> Tagged handle404
+ )
+ where
+ static = serveDirectoryWith $ defaultWebAppSettings $ heroClient cfg
-- | HtmlPage for setting HTML doctype and header
newtype HtmlPage a = HtmlPage a
@@ -120,9 +125,10 @@ type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic]
type CssRoute = "css" :> "main.css" :> Get '[CSS] Text
-newtype CSS = CSS
- { unCSS :: Text
- }
+newtype CSS
+ = CSS
+ { unCSS :: Text
+ }
instance Accept CSS where
contentType _ = "text" // "css" /: ("charset", "utf-8")
@@ -134,38 +140,37 @@ cssHandlers :: Server CssRoute
cssHandlers =
return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main
-type AllRoutes
- = ("static" :> Raw)
- :<|>
- CssRoute
- :<|>
- JsonApi
- :<|>
- ServerRoutes
- :<|>
- ("manifest.json" :> Get '[JSON] Manifest)
- :<|>
- Raw
-
-data Manifest = Manifest
- { name :: Text
- , short_name :: Text
- , start_url :: Text
- , display :: Text
- , theme_color :: Text
- , description :: Text
- } deriving (Show, Eq, Generic)
+type AllRoutes =
+ ("static" :> Raw)
+ :<|> CssRoute
+ :<|> JsonApi
+ :<|> ServerRoutes
+ :<|> ("manifest.json" :> Get '[JSON] Manifest)
+ :<|> Raw
+
+data Manifest
+ = Manifest
+ { name :: Text,
+ short_name :: Text,
+ start_url :: Text,
+ display :: Text,
+ theme_color :: Text,
+ description :: Text
+ }
+ deriving (Show, Eq, Generic)
instance ToJSON Manifest
heroManifest :: Manifest
-heroManifest = Manifest { name = "Hero"
- , short_name = "Hero"
- , start_url = "."
- , display = "standalone"
- , theme_color = "#0a0a0a"
- , description = "Comics for all"
- }
+heroManifest =
+ Manifest
+ { name = "Hero",
+ short_name = "Hero",
+ start_url = ".",
+ display = "standalone",
+ theme_color = "#0a0a0a",
+ description = "Comics for all"
+ }
handle404 :: Application
handle404 _ respond =
@@ -186,44 +191,42 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where
L.title_ "Hero [alpha]"
L.link_ [L.rel_ "manifest", L.href_ "/manifest.json"]
L.link_ [L.rel_ "icon", L.type_ ""]
-
-- icons
L.link_
- [ L.rel_ "apple-touch-icon"
- , L.sizes_ "180x180"
- , L.href_
- $ Assets.cdnEdge
- <> "/old-assets/images/favicons/apple-touch-icon.png"
+ [ L.rel_ "apple-touch-icon",
+ L.sizes_ "180x180",
+ L.href_ $
+ Assets.cdnEdge
+ <> "/old-assets/images/favicons/apple-touch-icon.png"
]
L.link_
- [ L.rel_ "icon"
- , L.type_ "image/png"
- , L.sizes_ "32x32"
- , L.href_
- $ Assets.cdnEdge
- <> "/old-assets/images/favicons/favicon-32x32.png"
+ [ L.rel_ "icon",
+ L.type_ "image/png",
+ L.sizes_ "32x32",
+ L.href_ $
+ Assets.cdnEdge
+ <> "/old-assets/images/favicons/favicon-32x32.png"
]
L.link_
- [ L.rel_ "icon"
- , L.type_ "image/png"
- , L.sizes_ "16x16"
- , L.href_
- $ Assets.cdnEdge
- <> "/old-assets/images/favicons/favicon-16x16.png"
+ [ L.rel_ "icon",
+ L.type_ "image/png",
+ L.sizes_ "16x16",
+ L.href_ $
+ Assets.cdnEdge
+ <> "/old-assets/images/favicons/favicon-16x16.png"
]
L.link_
- [ L.rel_ "manifest"
- , L.href_
- $ Assets.cdnEdge
- <> "/old-assets/images/favicons/manifest.json"
+ [ L.rel_ "manifest",
+ L.href_ $
+ Assets.cdnEdge
+ <> "/old-assets/images/favicons/manifest.json"
]
L.link_
- [ L.rel_ "mask-icon"
- , L.href_
- $ Assets.cdnEdge
- <> "/old-assets/images/favicons/safari-pinned-tab.svg"
+ [ L.rel_ "mask-icon",
+ L.href_ $
+ Assets.cdnEdge
+ <> "/old-assets/images/favicons/safari-pinned-tab.svg"
]
-
L.meta_ [L.charset_ "utf-8"]
L.meta_ [L.name_ "theme-color", L.content_ "#000"]
L.meta_ [L.httpEquiv_ "X-UA-Compatible", L.content_ "IE=edge"]
@@ -236,16 +239,18 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where
jsRef "/static/mmc.js"
jsRef "/static/usersnap.js"
L.body_ (L.toHtml x)
- where
- jsRef href = L.with
- (L.script_ mempty)
- [ makeAttribute "src" href
- , makeAttribute "async" mempty
- , makeAttribute "defer" mempty
- ]
- cssRef href = L.with
- (L.link_ mempty)
- [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]
+ where
+ jsRef href =
+ L.with
+ (L.script_ mempty)
+ [ makeAttribute "src" href,
+ makeAttribute "async" mempty,
+ makeAttribute "defer" mempty
+ ]
+ cssRef href =
+ L.with
+ (L.link_ mempty)
+ [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]
fontAwesomeRef :: MisoString
fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css"
diff --git a/Miso/FFI/Audio.hs b/Miso/FFI/Audio.hs
index e21ab57..b34960b 100644
--- a/Miso/FFI/Audio.hs
+++ b/Miso/FFI/Audio.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE NoImplicitPrelude #-}
+
module Miso.FFI.Audio where
import GHCJS.Types
diff --git a/Miso/FFI/Document.hs b/Miso/FFI/Document.hs
index f3a7bef..b4fe44f 100644
--- a/Miso/FFI/Document.hs
+++ b/Miso/FFI/Document.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE NoImplicitPrelude #-}
+
module Miso.FFI.Document where
import GHCJS.Types
diff --git a/Miso/FFI/Fullscreen.hs b/Miso/FFI/Fullscreen.hs
index db2e37e..4e70da6 100644
--- a/Miso/FFI/Fullscreen.hs
+++ b/Miso/FFI/Fullscreen.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE NoImplicitPrelude #-}
+
module Miso.FFI.Fullscreen where
import GHCJS.Types
diff --git a/Network/RemoteData.hs b/Network/RemoteData.hs
index 2fe6557..4114f02 100644
--- a/Network/RemoteData.hs
+++ b/Network/RemoteData.hs
@@ -1,30 +1,29 @@
-- | A port of Kris Jenkins' RemoteData Elm module
-- <https://github.com/krisajenkins/remotedata>.
---
module Network.RemoteData where
data RemoteData a b
- = NotAsked
- | Loading
- | Failure a
- | Success b
- deriving (Eq, Show)
+ = NotAsked
+ | Loading
+ | Failure a
+ | Success b
+ deriving (Eq, Show)
-- TODO figure out Http.Error
-- type WebData a = RemoteData Http.Error a
instance Functor (RemoteData a) where
- fmap _ NotAsked = NotAsked
- fmap _ Loading = Loading
- fmap _ (Failure a) = Failure a
- fmap f (Success a) = Success (f a)
+ fmap _ NotAsked = NotAsked
+ fmap _ Loading = Loading
+ fmap _ (Failure a) = Failure a
+ fmap f (Success a) = Success (f a)
instance Applicative (RemoteData e) where
- pure = Success
- NotAsked <*> _ = NotAsked
- Loading <*> _ = Loading
- Failure a <*> _ = Failure a
- Success a <*> b = fmap a b
+ pure = Success
+ NotAsked <*> _ = NotAsked
+ Loading <*> _ = Loading
+ Failure a <*> _ = Failure a
+ Success a <*> b = fmap a b
fromEither :: Either a b -> RemoteData a b
fromEither (Left a) = Failure a
diff --git a/Que/Server.hs b/Que/Server.hs
index 841cbfa..b0f3fbd 100644
--- a/Que/Server.hs
+++ b/Que/Server.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
-- | Interprocess communication
--
@@ -22,68 +22,82 @@
-- : dep unagi-chan
-- : dep unordered-containers
module Que.Server
- ( main
+ ( main,
)
where
-import Alpha hiding ( Text
- , get
- , gets
- , modify
- , poll
- )
-import qualified Control.Concurrent.Go as Go
-import qualified Control.Concurrent.STM as STM
-import qualified Control.Exception as Exception
-import Control.Monad.Reader ( MonadTrans )
+import Alpha hiding
+ ( Text,
+ get,
+ gets,
+ modify,
+ poll,
+ )
+import qualified Control.Concurrent.Go as Go
+import qualified Control.Concurrent.STM as STM
+import qualified Control.Exception as Exception
+import Control.Monad.Reader (MonadTrans)
import qualified Data.ByteString.Builder.Extra as Builder
-import qualified Data.ByteString.Lazy as BSL
-import Data.HashMap.Lazy ( HashMap )
-import qualified Data.HashMap.Lazy as HashMap
-import qualified Data.Text.Encoding as Encoding
-import Data.Text.Lazy ( Text
- , fromStrict
- )
-import qualified Data.Text.Lazy.IO as Text
-import qualified Network.HTTP.Types.Status as Http
-import qualified Network.Wai as Wai
-import qualified Network.Wai.Handler.Warp as Warp
-import Network.Wai.Middleware.RequestLogger
- ( logStdout )
-import qualified System.Envy as Envy
-import qualified System.Exit as Exit
-import qualified Web.Scotty.Trans as Scotty
+import qualified Data.ByteString.Lazy as BSL
+import Data.HashMap.Lazy (HashMap)
+import qualified Data.HashMap.Lazy as HashMap
+import qualified Data.Text.Encoding as Encoding
+import Data.Text.Lazy
+ ( Text,
+ fromStrict,
+ )
+import qualified Data.Text.Lazy.IO as Text
+import qualified Network.HTTP.Types.Status as Http
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+import Network.Wai.Middleware.RequestLogger
+ ( logStdout,
+ )
+import qualified System.Envy as Envy
+import qualified System.Exit as Exit
+import qualified Web.Scotty.Trans as Scotty
main :: IO ()
main = Exception.bracket startup shutdown <| uncurry Warp.run
- where
- startup = Envy.decodeEnv >>= \case
- Left e -> Exit.die e
- Right c -> do
- sync <- STM.newTVarIO initialAppState
- let runActionToIO m = runReaderT (runApp m) sync
- waiapp <- Scotty.scottyAppT runActionToIO routes
- putText <| "port:" <> (show <| quePort c)
- return (quePort c, waiapp)
- shutdown :: a -> IO a
- shutdown = pure . identity
-
-newtype App a = App
- { runApp :: ReaderT (STM.TVar AppState) IO a
- }
- deriving (Applicative, Functor, Monad, MonadIO, MonadReader
- (STM.TVar AppState))
-
-data AppState = AppState
- { ques :: HashMap Namespace Quebase
- }
+ where
+ startup = Envy.decodeEnv >>= \case
+ Left e -> Exit.die e
+ Right c -> do
+ sync <- STM.newTVarIO initialAppState
+ let runActionToIO m = runReaderT (runApp m) sync
+ waiapp <- Scotty.scottyAppT runActionToIO routes
+ putText <| "port:" <> (show <| quePort c)
+ return (quePort c, waiapp)
+ shutdown :: a -> IO a
+ shutdown = pure . identity
+
+newtype App a
+ = App
+ { runApp :: ReaderT (STM.TVar AppState) IO a
+ }
+ deriving
+ ( Applicative,
+ Functor,
+ Monad,
+ MonadIO,
+ MonadReader
+ (STM.TVar AppState)
+ )
+
+data AppState
+ = AppState
+ { ques :: HashMap Namespace Quebase
+ }
initialAppState :: AppState
-initialAppState = AppState { ques = mempty }
+initialAppState = AppState {ques = mempty}
-data Config = Config
- { quePort :: Warp.Port -- ^ QUE_PORT
- } deriving (Generic, Show)
+data Config
+ = Config
+ { -- | QUE_PORT
+ quePort :: Warp.Port
+ }
+ deriving (Generic, Show)
instance Envy.DefConfig Config where
defConfig = Config 3000
@@ -93,17 +107,15 @@ instance Envy.FromEnv Config
routes :: Scotty.ScottyT Text App ()
routes = do
Scotty.middleware logStdout
-
- let quepath = "^\\/([[:alnum:]_]+)\\/([[:alnum:]._/]*)$"
+ let quepath = "^\\/([[:alnum:]_]+)\\/([[:alnum:]._/]*)$"
let namespace = "^\\/([[:alnum:]_]+)\\/?$" -- matches '/ns' and '/ns/' but not '/ns/path'
- -- | GET /index.html
+ -- GET /index.html
Scotty.get (Scotty.literal "/index.html") <| Scotty.redirect "/_/index"
Scotty.get (Scotty.literal "/") <| Scotty.redirect "/_/index"
-
- -- | GET /_/dash
+ -- GET /_/dash
Scotty.get (Scotty.literal "/_/dash") <| do
- authkey <- fromMaybe "" </ Scotty.header "Authorization"
+ authkey <- fromMaybe "" </ Scotty.header "Authorization"
adminkey <- liftIO <| lchomp </ Text.readFile "/run/keys/que-admin"
if authkey == adminkey
then do
@@ -112,14 +124,11 @@ routes = do
else do
Scotty.status Http.methodNotAllowed405
Scotty.text "not allowed"
-
-
- -- | Namespace management
+ -- Namespace management
Scotty.matchAny (Scotty.regex namespace) <| do
Scotty.status Http.notImplemented501
Scotty.text "namespace management coming soon"
-
- -- | GET que
+ -- GET que
--
-- Receive a value from a que. Blocks until a value is received,
-- then returns. If 'poll=true', then stream data from the Que to the
@@ -127,20 +136,19 @@ routes = do
Scotty.get (Scotty.regex quepath) <| do
(ns, qp) <- extract
app . modify <| upsertNamespace ns
- q <- app <| que ns qp
+ q <- app <| que ns qp
poll <- Scotty.param "poll" !: (pure . const False)
guardNs ns ["pub", "_"]
case poll of
True -> Scotty.stream $ streamQue q
- _ -> do
+ _ -> do
r <- liftIO <| Go.read q
Scotty.html <| fromStrict <| Encoding.decodeUtf8 r
-
- -- | POST que
+ -- POST que
--
-- Put a value on a que. Returns immediately.
Scotty.post (Scotty.regex quepath) <| do
- authkey <- fromMaybe "" </ Scotty.header "Authorization"
+ authkey <- fromMaybe "" </ Scotty.header "Authorization"
adminkey <- liftIO <| lchomp </ Text.readFile "/run/keys/que-admin"
(ns, qp) <- extract
-- Only allow my IP or localhost to publish to '_' namespace
@@ -151,9 +159,9 @@ routes = do
guardNs ns ["pub", "_"]
-- passed all auth checks
app . modify <| upsertNamespace ns
- q <- app <| que ns qp
+ q <- app <| que ns qp
qdata <- Scotty.body
- _ <- liftIO <| Go.write q <| BSL.toStrict qdata
+ _ <- liftIO <| Go.write q <| BSL.toStrict qdata
return ()
-- | Given `guardNs ns whitelist`, if `ns` is not in the `whitelist`
@@ -168,21 +176,23 @@ guardNs ns whitelist = when (not <| ns `elem` whitelist) <| do
Scotty.finish
-- | recover from a scotty-thrown exception.
-(!:)
- :: Scotty.ActionT Text App a -- ^ action that might throw
- -> (Text -> Scotty.ActionT Text App a) -- ^ a function providing a default response instead
- -> Scotty.ActionT Text App a
+(!:) ::
+ -- | action that might throw
+ Scotty.ActionT Text App a ->
+ -- | a function providing a default response instead
+ (Text -> Scotty.ActionT Text App a) ->
+ Scotty.ActionT Text App a
(!:) = Scotty.rescue
-- | Forever write the data from 'Que' to 'Wai.StreamingBody'.
streamQue :: Que -> Wai.StreamingBody
streamQue q write _ = Go.mult q >>= loop
- where
- loop c =
- Go.tap c
- >>= (write . Builder.byteStringInsert)
- >> (write <| Builder.byteStringInsert "\n")
- >> loop c
+ where
+ loop c =
+ Go.tap c
+ >>= (write . Builder.byteStringInsert)
+ >> (write <| Builder.byteStringInsert "\n")
+ >> loop c
-- | Gets the thing from the Hashmap. Call's 'error' if key doesn't exist.
grab :: (Eq k, Hashable k) => k -> HashMap k v -> v
@@ -190,20 +200,21 @@ grab = flip (HashMap.!)
-- | Inserts the namespace in 'AppState' if it doesn't exist.
upsertNamespace :: Namespace -> AppState -> AppState
-upsertNamespace ns as = if HashMap.member ns (ques as)
- then as
- else as { ques = HashMap.insert ns mempty (ques as) }
+upsertNamespace ns as =
+ if HashMap.member ns (ques as)
+ then as
+ else as {ques = HashMap.insert ns mempty (ques as)}
-- | Inserts the que at the proper 'Namespace' and 'Quepath'.
insertQue :: Namespace -> Quepath -> Que -> AppState -> AppState
-insertQue ns qp q as = as { ques = newQues }
- where
- newQues = HashMap.insert ns newQbase (ques as)
- newQbase = HashMap.insert qp q <| grab ns <| ques as
+insertQue ns qp q as = as {ques = newQues}
+ where
+ newQues = HashMap.insert ns newQbase (ques as)
+ newQbase = HashMap.insert qp q <| grab ns <| ques as
extract :: Scotty.ActionT Text App (Namespace, Quepath)
extract = do
- ns <- Scotty.param "1"
+ ns <- Scotty.param "1"
path <- Scotty.param "2"
return (ns, path)
@@ -220,17 +231,26 @@ gets f = ask >>= liftIO . STM.readTVarIO >>= return . f
modify :: (AppState -> AppState) -> App ()
modify f = ask >>= liftIO . atomically . flip STM.modifyTVar' f
-type Namespace = Text -- ^ housing for a set of que paths
-type Que = Go.Channel Message -- ^ a que is just a channel of bytes
-type Quepath = Text -- ^ any path can serve as an identifier for a que
-type Message = ByteString -- ^ any opaque data
-type Quebase = HashMap Quepath Que -- ^ a collection of ques
+-- | housing for a set of que paths
+type Namespace = Text
+
+-- | a que is just a channel of bytes
+type Que = Go.Channel Message
+
+-- | any path can serve as an identifier for a que
+type Quepath = Text
+
+-- | any opaque data
+type Message = ByteString
+
+-- | a collection of ques
+type Quebase = HashMap Quepath Que
-- | Lookup or create a que
que :: Namespace -> Quepath -> App Que
que ns qp = do
_ques <- gets ques
- let qbase = grab ns _ques
+ let qbase = grab ns _ques
queExists = HashMap.member qp qbase
if queExists
then return <| grab qp qbase
diff --git a/Que/Website.hs b/Que/Website.hs
index e75f2bd..cfb860c 100644
--- a/Que/Website.hs
+++ b/Que/Website.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE LambdaCase #-}
-- | spawns a few processes that serve the que.run website
--
@@ -13,39 +13,41 @@
-- : dep protolude
-- : dep req
module Que.Website
- ( main
+ ( main,
)
where
-import Alpha
-import qualified Control.Concurrent.Async as Async
-import qualified Data.ByteString.Char8 as BS
-import qualified Data.Ini.Config as Config
-import qualified Data.Text as Text
-import Data.Text.Encoding ( encodeUtf8 )
-import qualified Data.Text.IO as Text
-import Network.HTTP.Req
-import qualified System.Directory as Directory
-import System.Environment as Environment
-import qualified System.Exit as Exit
-import System.FilePath ( (</>) )
-import qualified System.Process as Process
+import Alpha
+import qualified Control.Concurrent.Async as Async
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Ini.Config as Config
+import qualified Data.Text as Text
+import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text.IO as Text
+import Network.HTTP.Req
+import qualified System.Directory as Directory
+import System.Environment as Environment
+import qualified System.Exit as Exit
+import System.FilePath ((</>))
+import qualified System.Process as Process
main :: IO ()
main = do
(src, ns) <- Environment.getArgs >>= \case
- [src] -> return (src, "_") -- default to _ ns which is special
+ [src] -> return (src, "_") -- default to _ ns which is special
[src, ns] -> return (src, Text.pack ns)
- _ -> Exit.die "usage: que-website <srcdir> [namespace]"
+ _ -> Exit.die "usage: que-website <srcdir> [namespace]"
mKey <- getKey ns
putText $ "serving " <> Text.pack src <> " at " <> ns
- run mKey ns $ Sources { index = src </> "index.md"
- , client = src </> "client.py"
- , quescripts = src </> "quescripts.md"
- , style = src </> "style.css"
- , apidocs = src </> "apidocs.md"
- , tutorial = src </> "tutorial.md"
- }
+ run mKey ns $
+ Sources
+ { index = src </> "index.md",
+ client = src </> "client.py",
+ quescripts = src </> "quescripts.md",
+ style = src </> "style.css",
+ apidocs = src </> "apidocs.md",
+ tutorial = src </> "tutorial.md"
+ }
getKey :: Namespace -> IO (Maybe Key)
getKey ns = do
@@ -63,64 +65,71 @@ getKey ns = do
errorParsingConf :: error
errorParsingConf = panic "could not parse ~/.config/que.conf"
-data Sources = Sources
- { index :: FilePath
- , quescripts :: FilePath
- , client :: FilePath
- , style :: FilePath
- , tutorial :: FilePath
- , apidocs :: FilePath
- }
+data Sources
+ = Sources
+ { index :: FilePath,
+ quescripts :: FilePath,
+ client :: FilePath,
+ style :: FilePath,
+ tutorial :: FilePath,
+ apidocs :: FilePath
+ }
type Namespace = Text
+
type Key = Text
auth :: Namespace -> Config.IniParser (Maybe Key)
auth "pub" = pure Nothing
-auth ns = Config.sectionMb ns <| Config.field "key"
+auth ns = Config.sectionMb ns <| Config.field "key"
run :: Maybe Key -> Text -> Sources -> IO ()
run key ns Sources {..} = Async.runConcurrently actions >> return ()
- where
- actions = traverse
- Async.Concurrently
- [ forever <| toHtml index >>= serve key ns "index"
- , forever <| toHtml quescripts >>= serve key ns "quescripts"
- , forever <| BS.readFile client >>= serve key ns "client"
- , forever <| toHtml tutorial >>= serve key ns "tutorial"
- , forever <| toHtml apidocs >>= serve key ns "apidocs"
- ]
- toHtml :: FilePath -> IO ByteString
- toHtml md =
- BS.pack
- <$> Process.readProcess
- "pandoc"
- [ "--include-in-header"
- , style
- , "-i"
- , md
- , "--from"
- , "markdown"
- , "--to"
- , "html"
- ]
- []
+ where
+ actions =
+ traverse
+ Async.Concurrently
+ [ forever <| toHtml index >>= serve key ns "index",
+ forever <| toHtml quescripts >>= serve key ns "quescripts",
+ forever <| BS.readFile client >>= serve key ns "client",
+ forever <| toHtml tutorial >>= serve key ns "tutorial",
+ forever <| toHtml apidocs >>= serve key ns "apidocs"
+ ]
+ toHtml :: FilePath -> IO ByteString
+ toHtml md =
+ BS.pack
+ <$> Process.readProcess
+ "pandoc"
+ [ "--include-in-header",
+ style,
+ "-i",
+ md,
+ "--from",
+ "markdown",
+ "--to",
+ "html"
+ ]
+ []
serve :: Maybe Key -> Namespace -> Text -> ByteString -> IO ()
serve Nothing "pub" path content = runReq defaultHttpConfig $ do
- _ <- req POST
- (http "que.run" /: "pub" /: path)
- (ReqBodyBs content)
- ignoreResponse
- mempty
+ _ <-
+ req
+ POST
+ (http "que.run" /: "pub" /: path)
+ (ReqBodyBs content)
+ ignoreResponse
+ mempty
liftIO $ return ()
-serve Nothing p _ _ = panic <| "no auth key provided for ns: " <> p
+serve Nothing p _ _ = panic <| "no auth key provided for ns: " <> p
serve (Just key) ns path content = runReq defaultHttpConfig $ do
let options =
header "Authorization" (encodeUtf8 key) <> responseTimeout maxBound
- _ <- req POST
- (http "que.run" /: ns /: path)
- (ReqBodyBs content)
- ignoreResponse
- options
+ _ <-
+ req
+ POST
+ (http "que.run" /: ns /: path)
+ (ReqBodyBs content)
+ ignoreResponse
+ options
liftIO $ return ()
diff --git a/System/Random/Shuffle.hs b/System/Random/Shuffle.hs
index 02cd3e0..774e7b4 100644
--- a/System/Random/Shuffle.hs
+++ b/System/Random/Shuffle.hs
@@ -1,122 +1,118 @@
-{- |
-Module : System.Random.Shuffle
-Copyright : (c) 2009 Oleg Kiselyov, Manlio Perillo
-License : BSD3 (see LICENSE file)
-
-<http://okmij.org/ftp/Haskell/perfect-shuffle.txt>
-
-
-Example:
-
- import System.Random (newStdGen)
- import System.Random.Shuffle (shuffle')
-
- main = do
- rng <- newStdGen
- let xs = [1,2,3,4,5]
- print $ shuffle' xs (length xs) rng
--}
{-# OPTIONS_GHC -funbox-strict-fields #-}
+-- |
+-- Module : System.Random.Shuffle
+-- Copyright : (c) 2009 Oleg Kiselyov, Manlio Perillo
+-- License : BSD3 (see LICENSE file)
+--
+-- <http://okmij.org/ftp/Haskell/perfect-shuffle.txt>
+--
+--
+-- Example:
+--
+-- import System.Random (newStdGen)
+-- import System.Random.Shuffle (shuffle')
+--
+-- main = do
+-- rng <- newStdGen
+-- let xs = [1,2,3,4,5]
+-- print $ shuffle' xs (length xs) rng
module System.Random.Shuffle
- ( shuffle
- , shuffle'
- , shuffleM
+ ( shuffle,
+ shuffle',
+ shuffleM,
)
where
-import Data.Function ( fix )
-import System.Random ( RandomGen
- , randomR
- )
-import Control.Monad ( liftM
- , liftM2
- )
-import Control.Monad.Random ( MonadRandom
- , getRandomR
- )
-
+import Control.Monad
+ ( liftM,
+ liftM2,
+ )
+import Control.Monad.Random
+ ( MonadRandom,
+ getRandomR,
+ )
+import Data.Function (fix)
+import System.Random
+ ( RandomGen,
+ randomR,
+ )
-- | A complete binary tree, of leaves and internal nodes.
-- Internal node: Node card l r
-- where card is the number of leaves under the node.
-- Invariant: card >=2. All internal tree nodes are always full.
-data Tree a = Leaf !a
- | Node !Int !(Tree a) !(Tree a)
- deriving Show
-
+data Tree a
+ = Leaf !a
+ | Node !Int !(Tree a) !(Tree a)
+ deriving (Show)
-- | Convert a sequence (e1...en) to a complete binary tree
buildTree :: [a] -> Tree a
buildTree = (fix growLevel) . (map Leaf)
- where
- growLevel _ [node] = node
- growLevel self l = self $ inner l
-
- inner [] = []
- inner [e ] = [e]
- inner (e1 : e2 : es) = e1 `seq` e2 `seq` (join e1 e2) : inner es
-
- join l@(Leaf _ ) r@(Leaf _ ) = Node 2 l r
- join l@(Node ct _ _ ) r@(Leaf _ ) = Node (ct + 1) l r
- join l@(Leaf _ ) r@(Node ct _ _) = Node (ct + 1) l r
- join l@(Node ctl _ _) r@(Node ctr _ _) = Node (ctl + ctr) l r
-
-
--- |Given a sequence (e1,...en) to shuffle, and a sequence
--- (r1,...r[n-1]) of numbers such that r[i] is an independent sample
--- from a uniform random distribution [0..n-i], compute the
--- corresponding permutation of the input sequence.
+ where
+ growLevel _ [node] = node
+ growLevel self l = self $ inner l
+ inner [] = []
+ inner [e] = [e]
+ inner (e1 : e2 : es) = e1 `seq` e2 `seq` (join e1 e2) : inner es
+ join l@(Leaf _) r@(Leaf _) = Node 2 l r
+ join l@(Node ct _ _) r@(Leaf _) = Node (ct + 1) l r
+ join l@(Leaf _) r@(Node ct _ _) = Node (ct + 1) l r
+ join l@(Node ctl _ _) r@(Node ctr _ _) = Node (ctl + ctr) l r
+
+-- | Given a sequence (e1,...en) to shuffle, and a sequence
+-- (r1,...r[n-1]) of numbers such that r[i] is an independent sample
+-- from a uniform random distribution [0..n-i], compute the
+-- corresponding permutation of the input sequence.
shuffle :: [a] -> [Int] -> [a]
shuffle elements = shuffleTree (buildTree elements)
- where
- shuffleTree (Leaf e) [] = [e]
- shuffleTree tree (r : rs) =
- let (b, rest) = extractTree r tree in b : (shuffleTree rest rs)
- shuffleTree _ _ = error "[shuffle] called with lists of different lengths"
-
- -- Extracts the n-th element from the tree and returns
- -- that element, paired with a tree with the element
- -- deleted.
- -- The function maintains the invariant of the completeness
- -- of the tree: all internal nodes are always full.
- extractTree 0 (Node _ (Leaf e) r ) = (e, r)
- extractTree 1 (Node 2 (Leaf l) (Leaf r)) = (r, Leaf l)
- extractTree n (Node c (Leaf l) r) =
- let (e, r') = extractTree (n - 1) r in (e, Node (c - 1) (Leaf l) r')
-
- extractTree n (Node n' l (Leaf e)) | n + 1 == n' = (e, l)
-
- extractTree n (Node c l@(Node cl _ _) r)
- | n < cl
- = let (e, l') = extractTree n l in (e, Node (c - 1) l' r)
- | otherwise
- = let (e, r') = extractTree (n - cl) r in (e, Node (c - 1) l r')
- extractTree _ _ = error "[extractTree] impossible"
-
--- |Given a sequence (e1,...en) to shuffle, its length, and a random
--- generator, compute the corresponding permutation of the input
--- sequence.
+ where
+ shuffleTree (Leaf e) [] = [e]
+ shuffleTree tree (r : rs) =
+ let (b, rest) = extractTree r tree in b : (shuffleTree rest rs)
+ shuffleTree _ _ = error "[shuffle] called with lists of different lengths"
+ -- Extracts the n-th element from the tree and returns
+ -- that element, paired with a tree with the element
+ -- deleted.
+ -- The function maintains the invariant of the completeness
+ -- of the tree: all internal nodes are always full.
+ extractTree 0 (Node _ (Leaf e) r) = (e, r)
+ extractTree 1 (Node 2 (Leaf l) (Leaf r)) = (r, Leaf l)
+ extractTree n (Node c (Leaf l) r) =
+ let (e, r') = extractTree (n - 1) r in (e, Node (c - 1) (Leaf l) r')
+ extractTree n (Node n' l (Leaf e)) | n + 1 == n' = (e, l)
+ extractTree n (Node c l@(Node cl _ _) r)
+ | n < cl =
+ let (e, l') = extractTree n l in (e, Node (c - 1) l' r)
+ | otherwise =
+ let (e, r') = extractTree (n - cl) r in (e, Node (c - 1) l r')
+ extractTree _ _ = error "[extractTree] impossible"
+
+-- | Given a sequence (e1,...en) to shuffle, its length, and a random
+-- generator, compute the corresponding permutation of the input
+-- sequence.
shuffle' :: RandomGen gen => [a] -> Int -> gen -> [a]
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 = fst . unzip . rseq' (n - 1)
- where
- rseq' :: RandomGen gen => Int -> gen -> [(Int, gen)]
- rseq' 0 _ = []
- rseq' i gen = (j, gen) : rseq' (i - 1) gen'
- where (j, gen') = randomR (0, i) gen
-
--- |shuffle' wrapped in a random monad
+ 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 = fst . unzip . rseq' (n - 1)
+ where
+ rseq' :: RandomGen gen => Int -> gen -> [(Int, gen)]
+ rseq' 0 _ = []
+ rseq' i gen = (j, gen) : rseq' (i - 1) gen'
+ where
+ (j, gen') = randomR (0, i) gen
+
+-- | shuffle' wrapped in a random monad
shuffleM :: (MonadRandom m) => [a] -> m [a]
shuffleM elements
| null elements = return []
- | otherwise = liftM (shuffle elements) (rseqM (length elements - 1))
- where
- rseqM :: (MonadRandom m) => Int -> m [Int]
- rseqM 0 = return []
- rseqM i = liftM2 (:) (getRandomR (0, i)) (rseqM (i - 1))
+ | otherwise = liftM (shuffle elements) (rseqM (length elements - 1))
+ where
+ rseqM :: (MonadRandom m) => Int -> m [Int]
+ rseqM 0 = return []
+ rseqM i = liftM2 (:) (getRandomR (0, i)) (rseqM (i - 1))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 06:33:05 +0000