beforre maor rewrite
This commit is contained in:
parent
077d911714
commit
9551a3f25d
6 changed files with 85 additions and 169 deletions
|
|
@ -5,31 +5,41 @@ version: 0.1.0.0
|
|||
executable client
|
||||
main-is: Main.hs
|
||||
build-depends:
|
||||
base ^>=4.12.0.0,
|
||||
base,
|
||||
Shpadoinkle,
|
||||
Shpadoinkle-backend-snabbdom,
|
||||
Shpadoinkle-html,
|
||||
Shpadoinkle-router,
|
||||
text,
|
||||
servant,
|
||||
servant-client-js,
|
||||
aeson,
|
||||
containers,
|
||||
deepseq
|
||||
|
||||
default-extensions:
|
||||
CPP,
|
||||
DataKinds,
|
||||
DeriveAnyClass,
|
||||
DeriveGeneric,
|
||||
DerivingStrategies,
|
||||
DuplicateRecordFields,
|
||||
FlexibleInstances,
|
||||
GeneralizedNewtypeDeriving,
|
||||
LambdaCase,
|
||||
MultiParamTypeClasses,
|
||||
OverloadedLabels,
|
||||
OverloadedLists,
|
||||
OverloadedStrings,
|
||||
RecordWildCards,
|
||||
RecursiveDo,
|
||||
ScopedTypeVariables,
|
||||
StandaloneDeriving,
|
||||
TemplateHaskell,
|
||||
DeriveAnyClass,
|
||||
DataKinds,
|
||||
TypeApplications,
|
||||
TypeOperators,
|
||||
RecordWildCards
|
||||
TypeSynonymInstances
|
||||
|
||||
|
||||
|
||||
hs-source-dirs: src, shared-src
|
||||
default-language: Haskell2010
|
||||
|
|
@ -56,6 +66,7 @@ executable client
|
|||
|
||||
other-modules:
|
||||
InProgressPoll
|
||||
Client
|
||||
API
|
||||
Poll
|
||||
Ballot
|
||||
|
|
|
|||
|
|
@ -1,125 +0,0 @@
|
|||
let
|
||||
f =
|
||||
build-or-shell:
|
||||
{ chan ? "5272327b81ed355bbed5659b8d303cf2979b6953"
|
||||
, compiler ? "ghc865"
|
||||
, withHoogle ? false
|
||||
, doHoogle ? false
|
||||
, doHaddock ? false
|
||||
, enableLibraryProfiling ? false
|
||||
, enableExecutableProfiling ? false
|
||||
, strictDeps ? false
|
||||
, isJS ? false
|
||||
, system ? builtins.currentSystem
|
||||
, optimize ? true
|
||||
, shpadoinkle-path ? null
|
||||
}:
|
||||
let
|
||||
|
||||
|
||||
# It's a shpadoinkle day
|
||||
shpadoinkle = if shpadoinkle-path != null then shpadoinkle-path else builtins.fetchGit {
|
||||
url = https://gitlab.com/platonic/shpadoinkle.git;
|
||||
ref = "master";
|
||||
rev = "a107da66dca476ed5b5ee68981bc235d46107574";
|
||||
};
|
||||
|
||||
|
||||
# Get some utilities
|
||||
inherit (import (shpadoinkle + "/nix/util.nix") { inherit compiler isJS pkgs; }) compilerjs doCannibalize;
|
||||
|
||||
|
||||
# Build faster by doing less
|
||||
chill = p: (pkgs.haskell.lib.overrideCabal p {
|
||||
inherit enableLibraryProfiling enableExecutableProfiling;
|
||||
}).overrideAttrs (_: {
|
||||
inherit doHoogle doHaddock strictDeps;
|
||||
});
|
||||
|
||||
|
||||
# Overlay containing Shpadoinkle packages, and needed alterations for those packages
|
||||
# as well as optimizations from Reflex Platform
|
||||
shpadoinkle-overlay =
|
||||
import (shpadoinkle + "/nix/overlay.nix") { inherit compiler chan isJS enableLibraryProfiling enableExecutableProfiling; };
|
||||
|
||||
|
||||
# Haskell specific overlay (for you to extend)
|
||||
haskell-overlay = hself: hsuper: {
|
||||
"happy" = pkgs.haskell.lib.dontCheck hsuper.happy;
|
||||
};
|
||||
|
||||
|
||||
# Top level overlay (for you to extend)
|
||||
client-app-overlay = self: super: {
|
||||
haskell = super.haskell //
|
||||
{ packages = super.haskell.packages //
|
||||
{ ${compilerjs} = super.haskell.packages.${compilerjs}.override (old: {
|
||||
overrides = super.lib.composeExtensions (old.overrides or (_: _: {})) haskell-overlay;
|
||||
});
|
||||
};
|
||||
};
|
||||
};
|
||||
|
||||
|
||||
# Complete package set with overlays applied
|
||||
pkgs = import
|
||||
(builtins.fetchTarball {
|
||||
url = "https://github.com/NixOS/nixpkgs/archive/${chan}.tar.gz";
|
||||
}) {
|
||||
inherit system;
|
||||
overlays = [
|
||||
shpadoinkle-overlay
|
||||
client-app-overlay
|
||||
];
|
||||
};
|
||||
|
||||
|
||||
ghcTools = with pkgs.haskell.packages.${compiler};
|
||||
[ cabal-install
|
||||
ghcid
|
||||
] ++ (if isJS then [] else [ stylish-haskell ]);
|
||||
|
||||
|
||||
# We can name him George
|
||||
client =
|
||||
with builtins;
|
||||
let
|
||||
l = pkgs.lib;
|
||||
source = ../.;
|
||||
in
|
||||
pkgs.haskell.packages.${compilerjs}.callCabal2nix "client"
|
||||
(filterSource
|
||||
(path: type:
|
||||
let
|
||||
relative = replaceStrings [(toString source + "/")] [""] path;
|
||||
in
|
||||
(l.hasPrefix "src" relative || l.hasPrefix "shared-src" relative) && type == "directory"
|
||||
|| l.hasSuffix ".hs" path
|
||||
|| l.hasSuffix ".cabal" path
|
||||
)
|
||||
source
|
||||
)
|
||||
{};
|
||||
|
||||
|
||||
in with pkgs; with lib;
|
||||
|
||||
{ build =
|
||||
(if isJS && optimize then doCannibalize else x: x) (chill client);
|
||||
|
||||
shell =
|
||||
pkgs.haskell.packages.${compilerjs}.shellFor {
|
||||
inherit withHoogle;
|
||||
packages = _: [ client ];
|
||||
COMPILER = compilerjs;
|
||||
buildInputs = ghcTools;
|
||||
shellHook = ''
|
||||
${lolcat}/bin/lolcat ${../figlet}
|
||||
cat ${../intro}
|
||||
'';
|
||||
};
|
||||
}.${build-or-shell};
|
||||
in
|
||||
{ build = f "build";
|
||||
shell = f "shell";
|
||||
}
|
||||
|
|
@ -6,7 +6,7 @@ import qualified Data.List.NonEmpty as LN
|
|||
import qualified Poll as P
|
||||
|
||||
data InProgressPoll = InProgressPoll
|
||||
{ title :: T.Text,
|
||||
{ title :: Maybe T.Text,
|
||||
question :: T.Text,
|
||||
options :: [T.Text]
|
||||
} deriving (Generic, Eq, Show, DS.NFData)
|
||||
|
|
@ -17,7 +17,7 @@ modQuestion newQuestion poll = poll {question = newQuestion}
|
|||
nonEmpty "" = Nothing
|
||||
nonEmpty xs = Just xs
|
||||
|
||||
toCreatePollInfo :: InProgressPoll -> Maybe P.CreatePollInfo
|
||||
toCreatePollInfo InProgressPoll{..} = case (not . T.null $ question, LN.nonEmpty =<< mapM nonEmpty options) of
|
||||
(True, Just options') -> Just $ P.CreatePollInfo (nonEmpty title) question options'
|
||||
_ -> Nothing
|
||||
-- toCreatePollInfo :: InProgressPoll -> Maybe P.CreatePollInfo
|
||||
-- toCreatePollInfo InProgressPoll{..} = case (not . T.null $ question, LN.nonEmpty =<< mapM nonEmpty options) of
|
||||
-- (True, Just options') -> Just $ P.CreatePollInfo (nonEmpty title) question options'
|
||||
-- _ -> Nothing
|
||||
|
|
|
|||
|
|
@ -12,71 +12,97 @@ import qualified Data.Text as T
|
|||
import Shpadoinkle.Html
|
||||
import qualified Shpadoinkle.Html as SHtml
|
||||
import Shpadoinkle.Run (live, runJSorWarp, simple, fullPageJSM)
|
||||
import qualified Shpadoinkle.Router as ShR
|
||||
import qualified Data.List as L
|
||||
import qualified Routes as R
|
||||
|
||||
headHtml = head_ [link' [rel "stylesheet", type' "text/css", href "https://unpkg.com/papercss@1.8.3/dist/paper.css"]]
|
||||
|
||||
withLabel name inputProps = div_ [label'', input'']
|
||||
where
|
||||
label'' = label [for' name] [text name]
|
||||
input'' = input' $ for' name : inputProps
|
||||
|
||||
view :: Functor m => Model -> Html m Model
|
||||
view model = html_ [headHtml,
|
||||
SHtml.body []
|
||||
[ input'
|
||||
[value . IP.title . creatingPoll $ model,
|
||||
onInput (\x model -> model {creatingPoll = IP.modTitle x (creatingPoll model)})
|
||||
],
|
||||
input'
|
||||
[value . IP.question . creatingPoll $ model,
|
||||
onInput (\x model -> model {creatingPoll = IP.modQuestion x (creatingPoll model)})
|
||||
],
|
||||
body []
|
||||
[ liftedTitle,
|
||||
question,
|
||||
liftedOptions
|
||||
]]
|
||||
where
|
||||
liftedOptions :: Functor m => Html m Model
|
||||
question = withLabel "question"
|
||||
[
|
||||
value . IP.question . creatingPoll $ model,
|
||||
onInput (\x model -> model {creatingPoll = IP.modQuestion x (creatingPoll model)})
|
||||
]
|
||||
|
||||
liftedTitle :: Functor m => Html m Model
|
||||
liftedTitle = Sh.liftC modifyModelTitle (IP.title . creatingPoll) . titleHtml . IP.title . creatingPoll $ model
|
||||
|
||||
liftedOptions :: Functor m => Html m Model
|
||||
liftedOptions = Sh.liftC modifyModelOptions (IP.options . creatingPoll) optionsHtml'
|
||||
|
||||
optionsHtml' :: Html m [T.Text]
|
||||
optionsHtml' = (optionsHtml . IP.options . creatingPoll $ model)
|
||||
optionsHtml' :: Functor m => Html m [T.Text]
|
||||
optionsHtml' = optionsHtml . IP.options . creatingPoll $ model
|
||||
|
||||
modifyModelOptions :: [T.Text] -> Model -> Model
|
||||
modifyModelOptions newOptions model = model {creatingPoll = (creatingPoll model) {IP.options = newOptions}}
|
||||
|
||||
optionsHtml :: [T.Text] -> Html m [T.Text]
|
||||
optionsHtml options = SHtml.div [id' "options"] [inputFields, addOptionButton]
|
||||
modifyModelTitle :: Maybe T.Text -> Model -> Model
|
||||
modifyModelTitle newTitle model = model {creatingPoll = (creatingPoll model) {IP.title = newTitle}}
|
||||
|
||||
titleHtml :: Functor m => Maybe T.Text -> Html m (Maybe T.Text)
|
||||
titleHtml Nothing = button [onClick (const $ Just T.empty)] ["add title"]
|
||||
titleHtml (Just title) = div_ [titleInput, addTitleButton]
|
||||
where
|
||||
inputFields = SHtml.div [id' "optionInputs"] $ zipWith (\x y -> input' $ doubleton x y) optionsMods values
|
||||
titleInput = withLabel "title"
|
||||
[value title,
|
||||
onInput (const . Just)
|
||||
]
|
||||
|
||||
addOptionButton = button [id' "addOption", onClick (\xs -> T.empty : xs)] ["add option"]
|
||||
addTitleButton = button [onClick (const Nothing), removeButtonClass] ["remove"]
|
||||
|
||||
optionsMods :: [(T.Text, Prop m [T.Text])]
|
||||
optionsMods = map (onInput . toOnInput) . mods $ options
|
||||
removeButtonClass = className "btn-danger paper-btn btn-small"
|
||||
|
||||
values :: [(T.Text, Prop m [T.Text])]
|
||||
values = map value options
|
||||
optionsHtml :: Functor m => [T.Text] -> Html m [T.Text]
|
||||
optionsHtml = div_ . (addOptionButton :) . zipWith toOptionHtml [0..]
|
||||
where
|
||||
addOptionButton :: Html m [T.Text]
|
||||
addOptionButton = button [onClick (T.empty :)] ["add option"]
|
||||
|
||||
toOnInput fn a _ = fn a
|
||||
toOptionHtml :: Functor m => Int -> T.Text -> Html m [T.Text]
|
||||
toOptionHtml loc option = Sh.liftC (modifyOption loc) (Just . (!! loc)) (optionHtml option)
|
||||
|
||||
doubleton x y = [x, y]
|
||||
modifyOption :: Int -> Maybe T.Text -> [T.Text] -> [T.Text]
|
||||
modifyOption loc newOption options = (mods options !! loc) newOption
|
||||
|
||||
mods :: [a] -> [(a -> [a])]
|
||||
optionHtml :: T.Text -> Html m (Maybe T.Text)
|
||||
optionHtml optionText = div_ [input' [onInput (const . Just), value optionText],
|
||||
button [onClick (const Nothing), removeButtonClass] ["remove"]]
|
||||
|
||||
mods :: [a] -> [Maybe a -> [a]]
|
||||
mods xs = zipWith toModFn (L.inits xs) (init $ L.tails xs)
|
||||
where
|
||||
toModFn :: [a] -> [a] -> a -> [a]
|
||||
toModFn xs (y:ys) newY = xs ++ newY : ys
|
||||
|
||||
toModFn :: [a] -> [a] -> Maybe a -> [a]
|
||||
toModFn xs (y:ys) (Just newY) = xs ++ newY : ys
|
||||
toModFn xs (y:ys) Nothing = xs ++ ys
|
||||
|
||||
app :: JSM ()
|
||||
app = fullPageJSM runSnabbdom (Model startingPoll) view stage
|
||||
app = ShR.fullPageSPA runSnabbdom dummyStart view stage dummyStart R.routes
|
||||
|
||||
dummyStart = const . pure $ Create startingPoll
|
||||
|
||||
startingPoll :: IP.InProgressPoll
|
||||
startingPoll =
|
||||
IP.InProgressPoll
|
||||
{ title = "title goes here",
|
||||
question = "question goes here",
|
||||
{ title = Nothing,
|
||||
question = "",
|
||||
options = ["option1", "option2"]
|
||||
}
|
||||
|
||||
data Model = Model
|
||||
{ creatingPoll :: IP.InProgressPoll
|
||||
}
|
||||
|
||||
data Model = Create { creatingPoll :: IP.InProgressPoll }
|
||||
deriving (Generic, Eq, Show, DS.NFData)
|
||||
|
||||
dev :: IO ()
|
||||
|
|
|
|||
|
|
@ -43,14 +43,17 @@ executable server
|
|||
acid-state,
|
||||
safecopy,
|
||||
containers,
|
||||
blaze-html,
|
||||
http-types,
|
||||
lucid,
|
||||
miso,
|
||||
servant-lucid,
|
||||
servant-blaze,
|
||||
-- miso,
|
||||
bytestring,
|
||||
hashable,
|
||||
mtl,
|
||||
network-uri,
|
||||
postgresql-simple,
|
||||
-- postgresql-simple,
|
||||
servant,
|
||||
deepseq,
|
||||
servant-lucid,
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-#LANGUAGE TemplateHaskell#-}
|
||||
module Database where
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue