summaryrefslogtreecommitdiff
path: root/com
diff options
context:
space:
mode:
Diffstat (limited to 'com')
-rw-r--r--com/influencedbybooks/aero.hs6
-rw-r--r--com/influencedbybooks/apex.hs15
-rw-r--r--com/influencedbybooks/core.hs2
-rw-r--r--com/influencedbybooks/default.nix32
-rw-r--r--com/influencedbybooks/influencers.hs4
-rw-r--r--com/influencedbybooks/keep.hs6
-rw-r--r--com/influencedbybooks/look.hs2
-rw-r--r--com/influencedbybooks/move.hs4
-rwxr-xr-xcom/simatime/bild.scm24
-rw-r--r--com/simatime/buildHaskellApp.nix79
-rwxr-xr-xcom/simatime/caplinks.scm45
-rw-r--r--com/simatime/shell.scm34
-rw-r--r--com/simatime/string.scm24
13 files changed, 203 insertions, 74 deletions
diff --git a/com/influencedbybooks/aero.hs b/com/influencedbybooks/aero.hs
index 92d071d..63066c5 100644
--- a/com/influencedbybooks/aero.hs
+++ b/com/influencedbybooks/aero.hs
@@ -3,11 +3,11 @@
{-# LANGUAGE NoImplicitPrelude #-}
-- | Front-end
-module Com.InfluencedByBooks.Aero where
+module Com.Influencedbybooks.Aero where
import Com.Simatime.Alpha
-import Com.InfluencedByBooks.Move (move)
-import Com.InfluencedByBooks.Core (Action(..), see, init)
+import Com.Influencedbybooks.Move (move)
+import Com.Influencedbybooks.Core (Action(..), see, init)
import Miso (App(..), defaultEvents, miso)
main :: IO ()
diff --git a/com/influencedbybooks/apex.hs b/com/influencedbybooks/apex.hs
index fd4766b..32e6403 100644
--- a/com/influencedbybooks/apex.hs
+++ b/com/influencedbybooks/apex.hs
@@ -8,25 +8,24 @@
{-# LANGUAGE TypeOperators #-}
-- | Server
-module Com.InfluencedByBooks.Apex where
+module Com.Influencedbybooks.Apex where
-import Com.Simatime Alpha
-import Com.InfluencedByBooks.Core
-import qualified Com.InfluencedByBooks.Keep as Keep
-import qualified Com.InfluencedByBooks.Look as Look
+import Com.Simatime.Alpha
+import Com.Influencedbybooks.Core
+import qualified Com.Influencedbybooks.Keep as Keep
+import qualified Com.Influencedbybooks.Look as Look
import qualified Clay
import qualified Data.Text.Lazy as Lazy
import qualified Data.Text.Lazy.Encoding as Lazy
import Data.Maybe (fromMaybe)
import Data.Acid (AcidState)
import qualified Data.Acid.Abstract as Acid
-import GitHash (giHash, tGitInfoCwd)
import qualified Lucid as L
import Lucid.Base
import Miso
import Network.HTTP.Media ((//), (/:))
import Network.HTTP.Types
-import Network.RemoteData
+import Com.Simatime.Network
import Network.Wai
import Network.Wai.Application.Static
import Network.Wai.Handler.Warp
@@ -60,10 +59,8 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where
cssRef "/css/main.css"
L.body_ $ do
page
- L.p_ gitCommit
where
page = L.toHtml x
- gitCommit = L.toHtml $ giHash $$tGitInfoCwd
jsRef href = L.with (L.script_ mempty)
[ makeAttribute "src" href
, makeAttribute "type" "text/javascript"
diff --git a/com/influencedbybooks/core.hs b/com/influencedbybooks/core.hs
index 9bd2353..2a616f3 100644
--- a/com/influencedbybooks/core.hs
+++ b/com/influencedbybooks/core.hs
@@ -5,7 +5,7 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Main app logic
-module Com.InfluencedByBooks.Core where
+module Com.Influencedbybooks.Core where
import Com.Simatime.Alpha
import Data.Aeson hiding (Success)
diff --git a/com/influencedbybooks/default.nix b/com/influencedbybooks/default.nix
deleted file mode 100644
index f2ff1ec..0000000
--- a/com/influencedbybooks/default.nix
+++ /dev/null
@@ -1,32 +0,0 @@
-# TODO: translate this back to regular nix?
-{
- name = "ibb";
- deps = {
- both = [
- "clay"
- "miso"
- "protolude"
- "servant"
- "text"
- ];
- apex = [
- "MonadRandom"
- "acid-state"
- "blaze-html"
- "blaze-markup"
- "bytestring"
- "githash"
- "ixset"
- "random"
- "safecopy"
- "scotty"
- "servant-server"
- "text"
- ];
- aero = [
- "aeson"
- "containers"
- "ghcjs-base"
- ];
- };
-}
diff --git a/com/influencedbybooks/influencers.hs b/com/influencedbybooks/influencers.hs
index 2583770..c0cb143 100644
--- a/com/influencedbybooks/influencers.hs
+++ b/com/influencedbybooks/influencers.hs
@@ -2,9 +2,9 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
-module Com.InfluencedByBooks.Influencers where
+module Com.Influencedbybooks.Influencers where
-import Com.InfluencedByBooks.Core
+import Com.Influencedbybooks.Core
allPeople :: [Person]
allPeople =
diff --git a/com/influencedbybooks/keep.hs b/com/influencedbybooks/keep.hs
index 0bc527a..2b7ff3a 100644
--- a/com/influencedbybooks/keep.hs
+++ b/com/influencedbybooks/keep.hs
@@ -10,9 +10,9 @@
-- `Biz.Keep`. I could wrap all the safecopy stuff in my own template haskell
-- like `$(keep ''MyType)`.
--
-module Com.InfluencedByBooks.Keep where
+module Com.Influencedbybooks.Keep where
-import Com.InfluencedByBooks.Core (Person(..), Book(..))
+import Com.Influencedbybooks.Core (Person(..), Book(..))
import Control.Monad.State (get, put)
import Control.Monad.Reader (ask)
import Data.Acid (Update, makeAcidic)
@@ -24,7 +24,7 @@ import Data.SafeCopy
import Data.Text (Text)
import qualified Data.Text as Text
-import qualified Com.InfluencedByBooks.Influencers as Influencers
+import qualified Com.Influencedbybooks.Influencers as Influencers
-- * Keep
diff --git a/com/influencedbybooks/look.hs b/com/influencedbybooks/look.hs
index d61fc11..68ae81f 100644
--- a/com/influencedbybooks/look.hs
+++ b/com/influencedbybooks/look.hs
@@ -2,7 +2,7 @@
{-# LANGUAGE NoImplicitPrelude #-}
-- | The look and feel of Ibb
-module Com.InfluencedByBooks.Look where
+module Com.Influencedbybooks.Look where
import Com.Simatime.Alpha
import Clay
diff --git a/com/influencedbybooks/move.hs b/com/influencedbybooks/move.hs
index 2c0ee37..63af430 100644
--- a/com/influencedbybooks/move.hs
+++ b/com/influencedbybooks/move.hs
@@ -2,7 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
-- | App update logic
-module Com.InfluencedByBooks.Move (
+module Com.Influencedbybooks.Move (
move
-- * Server interactions
, fetchPeople
@@ -10,7 +10,7 @@ module Com.InfluencedByBooks.Move (
import Alpha
import Data.Aeson
-import Com.InfluencedByBooks.Core as Core
+import Com.Influencedbybooks.Core as Core
import JavaScript.Web.XMLHttpRequest (Request(..), Method(GET), RequestData(NoData), contents, xhrByteString)
import Miso
import Miso.String
diff --git a/com/simatime/bild.scm b/com/simatime/bild.scm
index 604a545..44f6c74 100755
--- a/com/simatime/bild.scm
+++ b/com/simatime/bild.scm
@@ -122,6 +122,9 @@ exec guile -e "(@ (com simatime bild) main)" -s "$0" "$@"
(define-module (com simatime bild)
#:use-module ((ice-9 popen) #:prefix popen/)
#:use-module ((ice-9 format) #:select (format))
+ #:use-module ((ice-9 rdelim) #:prefix rdelim/)
+ #:use-module ((com simatime shell) #:prefix sh/)
+ #:use-module ((com simatime string) #:prefix string/)
#:export (ns?
ns->path
path->ns
@@ -156,24 +159,3 @@ exec guile -e "(@ (com simatime bild) main)" -s "$0" "$@"
((symbol? path) (to-ns (symbol->string path)))
((string? path) (to-ns path))
(else (error "path should be a string or symbol")))))
-
-
-;;
-;; general funs, to be moved to a core lib
-;;
-
-(define (string/replace s match replacement)
- (string-fold
- (lambda (a b)
- (let ((next-char (if (eq? a match)
- replacement
- a)))
- (string-concatenate (list b (string next-char)))))
- ""
- s))
-
-(define (sh/exec cmd)
- (let* ((port (popen/open-input-pipe cmd))
- (ret (read port)))
- (popen/close-pipe port)
- ret))
diff --git a/com/simatime/buildHaskellApp.nix b/com/simatime/buildHaskellApp.nix
new file mode 100644
index 0000000..d9cb211
--- /dev/null
+++ b/com/simatime/buildHaskellApp.nix
@@ -0,0 +1,79 @@
+/*
+
+A function for building a Haskell Miso app.
+
+*/
+
+nixpkgs:
+
+{
+ # the namespace. We can't figure this out with Nix code, but when we port to
+ # guix/scheme we should be able to
+ name
+, apex # compiled with ghc
+, aero # compiled with ghcjs
+ # deps get passed to GHC
+, deps
+
+}:
+
+with nixpkgs;
+
+let
+ nsToPath = ns:
+ builtins.toString (builtins.replaceStrings ["."] ["/"] ns);
+
+ depsToPackageSet = packageSet: deps:
+ map (s: builtins.getAttr s packageSet) deps;
+
+ ghc844_ = pkgs.haskell.packages.ghc844.override (oldAttrs: {
+ overrides = with pkgs.haskell.lib; self: super: {
+ clay = dontCheck super.clay;
+ };
+ });
+
+ ghc = ghc844_.ghcWithPackages (hp: depsToPackageSet hp
+ (deps.both ++ deps.apex));
+
+ ghcjs_ = pkgs.haskell.packages.ghcjs.override (oldAttrs: {
+ overrides = with pkgs.haskell.lib; self: super: {
+ clay = dontCheck super.clay;
+ http-types = dontCheck super.http-types;
+ tasty-quickcheck = dontCheck super.tasty-quickcheck;
+ scientific = dontCheck super.scientific; # takes forever
+ servant = dontCheck super.servant;
+ comonad = dontCheck super.comonad;
+ QuickCheck = dontCheck super.QuickCheck;
+ };
+ });
+
+ ghcjs = ghcjs_.ghcWithPackages (hp:
+ depsToPackageSet hp (deps.both ++ deps.aero));
+
+in stdenv.mkDerivation {
+ name = name;
+ version = "0";
+ src = ../../.; # this is the git root
+ nativeBuildInputs = [
+ ghc ghcjs guile bash
+ ];
+ strictDeps = true;
+ buildPhase = ''
+ echo ":: build"
+ . .envrc
+ guile -e '(com simatime caplinks)' -s ./com/simatime/caplinks.scm .
+ mkdir -p _bild/${nsToPath apex}
+ mkdir -p _bild/${nsToPath aero}
+ ${ghc}/bin/ghc -i. --make ${nsToPath apex}.hs -main-is ${apex} \
+ -o _bild/${nsToPath apex}
+ ${ghcjs}/bin/ghcjs -i. --make ${nsToPath aero}.hs -main-is ${aero} \
+ -o _bild/${nsToPath aero}
+ '';
+ installPhase = ''
+ echo ":: install"
+ mkdir -p $out
+ pwd && ls -al .
+ cp -r ./${nsToPath apex}* $out/${apex}
+ cp -r ./${nsToPath aero}* $out/${aero}
+ '';
+}
diff --git a/com/simatime/caplinks.scm b/com/simatime/caplinks.scm
new file mode 100755
index 0000000..21f0b88
--- /dev/null
+++ b/com/simatime/caplinks.scm
@@ -0,0 +1,45 @@
+
+(define-module (com simatime caplinks)
+ #:use-module ((ice-9 popen) #:prefix popen/)
+ #:use-module ((com simatime string) #:prefix string/)
+ #:use-module ((com simatime shell) #:prefix sh/)
+ #:export (main get-all-nodes make-symlink))
+
+;; given a root directory, walk the tree and get a list of all the files. Then,
+;; for each file, symlink a capitalized version
+(define (main args)
+ (let* ((root (cadr args))
+ (files (get-all-nodes root)))
+ (for-each (lambda (file)
+ (display file)
+ (move-file file (capitalize-file file)))
+ files)
+ (display root) (newline)
+ (display "done moving files") (newline)
+ (newline)))
+
+(define (get-all-nodes root)
+ (filter (lambda (s) (not (equal? "" s)))
+ (string-split (sh/stream
+ (format #f "find ~a -name '*.hs*'" root))
+ #\newline)))
+
+(define (capitalize-file file)
+ (string-join (map string/capitalize (string-split file #\/))
+ "/"))
+
+(define (butlast ls)
+ (let ((len (length ls)))
+ (list-head ls (- len 1))))
+
+(define (dir-for f)
+ (string-join
+ (butlast (string-split f #\/))
+ "/"))
+
+(define (move-file here there)
+ (display (format #f "~a -> ~a" here there))
+ (newline)
+ ;; make the directory tree for the link, if it doesn't already exist
+ (system (format #f "mkdir -p ~a" (dir-for there)))
+ (system (format #f "mv ~a ~a" here there)))
diff --git a/com/simatime/shell.scm b/com/simatime/shell.scm
new file mode 100644
index 0000000..7c6bb5c
--- /dev/null
+++ b/com/simatime/shell.scm
@@ -0,0 +1,34 @@
+(define-module (com simatime shell)
+ #:use-module ((ice-9 popen) #:prefix popen/)
+ #:use-module ((ice-9 rdelim) #:prefix rdelim/)
+ #:use-module ((ice-9 ftw) #:prefix ftw/)
+ #:export (exec
+ stream
+ pwd
+ ls
+ cd))
+
+(define (exec cmd)
+ (let* ((port (popen/open-input-pipe cmd))
+ (ret (read port)))
+ (popen/close-pipe port)
+ ret))
+
+(define (stream cmd)
+ (let* ((port (popen/open-input-pipe cmd))
+ (_ (setvbuf port 'none))
+ (ret (rdelim/read-string port)))
+ (flush-all-ports)
+ (popen/close-pipe port)
+ ret))
+
+(define (pwd)
+ (regexp-substitute/global
+ #f "/home/ben" (getcwd) 'pre "~" 'post))
+
+(define (ls)
+ (ftw/scandir (getcwd)))
+
+(define (cd path)
+ (chdir path)
+ (ls))
diff --git a/com/simatime/string.scm b/com/simatime/string.scm
new file mode 100644
index 0000000..01c5a70
--- /dev/null
+++ b/com/simatime/string.scm
@@ -0,0 +1,24 @@
+(define-module (com simatime string)
+ #:export (replace to-string str capitalize))
+
+(define (replace s match repl)
+ (let ((f (lambda (a b)
+ (let ((next-char (if (eq? a match) repl a)))
+ (string-concatenate (list b (string next-char)))))))
+ (string-fold f "" s)))
+
+(define (to-string x)
+ (format #f "~a" x))
+
+(define str
+ (case-lambda
+ (() "")
+ ((x) (to-string x))
+ ((x . rest) (string-concatenate (map str (cons x rest))))))
+
+(define (capitalize s)
+ (let ((s (to-string s)))
+ (if (< (string-length s) 2)
+ (string-upcase s)
+ (str (string-upcase (substring s 0 1))
+ (substring s 1 )))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 06:27:53 +0000