mirror of https://github.com/voidlizard/hbs2
Squashed 'miscellaneous/suckless-conf/' content from commit ff6f1a2e0
git-subtree-dir: miscellaneous/suckless-conf git-subtree-split: ff6f1a2e053005a52af5c7375fb66e8bb89bce2d
This commit is contained in:
voidlizard
commit
e1cbd3eb64
|
|
@ -0,0 +1,78 @@
|
||||||
|
|
||||||
|
|
||||||
|
fixme-comments "--"
|
||||||
|
|
||||||
|
fixme-prefix FIXME: bugs issues
|
||||||
|
fixme-prefix TODO: bugs issues
|
||||||
|
fixme-prefix REVIEW: review
|
||||||
|
fixme-prefix PR: pr
|
||||||
|
|
||||||
|
fixme-files **/*.hs docs/devlog.md
|
||||||
|
|
||||||
|
fixme-files docs/pep*.txt
|
||||||
|
fixme-files docs/drafts/**/*.txt
|
||||||
|
fixme-files docs/pr/**/*.txt
|
||||||
|
fixme-files docs/todo/**/*.txt
|
||||||
|
|
||||||
|
fixme-files-ignore .direnv/** dist-newstyle/**
|
||||||
|
|
||||||
|
fixme-id-show-len 10
|
||||||
|
|
||||||
|
|
||||||
|
fixme-attribs assigned workflow resolution cat scope
|
||||||
|
|
||||||
|
fixme-value-set workflow new backlog wip test fixed done
|
||||||
|
|
||||||
|
fixme-value-set cat bug feat refactor
|
||||||
|
|
||||||
|
fixme-value-set scope mvp-0 mvp-1 backlog
|
||||||
|
|
||||||
|
|
||||||
|
[ fixme-report all json
|
||||||
|
(render builtin:microstache report-wip.tpl)
|
||||||
|
(post builtin:columns | 10 8 8 10 12 _)
|
||||||
|
; (query ~workflow:backlog)
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
[ fixme-report open json
|
||||||
|
(render builtin:microstache report-wip.tpl)
|
||||||
|
(post builtin:columns | 10 8 8 10 12 _)
|
||||||
|
(query ~workflow:backlog)
|
||||||
|
(query ~workflow:done)
|
||||||
|
(query ~workflow:test)
|
||||||
|
]
|
||||||
|
|
||||||
|
[ fixme-report backlog json
|
||||||
|
(render builtin:microstache report-wip.tpl)
|
||||||
|
(post builtin:columns | 10 8 8 10 12 _)
|
||||||
|
(query workflow:backlog)
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
[ fixme-report wip json
|
||||||
|
(render builtin:microstache report-wip.tpl)
|
||||||
|
(post builtin:columns | 10 8 8 10 12 _)
|
||||||
|
(query ?workflow:test)
|
||||||
|
(query ?workflow:wip)
|
||||||
|
(query ?workflow:fixed)
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
[ fixme-report review json
|
||||||
|
(render builtin:microstache report-wip.tpl)
|
||||||
|
(post builtin:columns | 10 8 8 10 12 _)
|
||||||
|
(query tag:REVIEW:)
|
||||||
|
]
|
||||||
|
|
||||||
|
[ fixme-report wip-json json
|
||||||
|
]
|
||||||
|
|
||||||
|
fixme-log-macro backlog (fixme-set "workflow" "backlog" "$1")
|
||||||
|
fixme-log-macro test (fixme-set "workflow" "test" "$1")
|
||||||
|
fixme-log-macro wip (fixme-set "workflow" "wip" "$1")
|
||||||
|
fixme-log-macro done (fixme-set "workflow" "done" "$1")
|
||||||
|
fixme-log-macro assign (fixme-set "assigned" "$1" "$2")
|
||||||
|
|
||||||
|
fixme-log-macro scope (fixme-set "scope" "$1" "$2")
|
||||||
|
|
||||||
|
|
@ -0,0 +1,5 @@
|
||||||
|
|
||||||
|
;; This is a log file. All fixmies status updates go here
|
||||||
|
|
||||||
|
fixme-set "workflow" "done" "9QfPgLHLSw"
|
||||||
|
(fixme-set "assigned" "voidlizard" "9XmyXek1Y6")
|
||||||
|
|
@ -0,0 +1,3 @@
|
||||||
|
{{#items}}
|
||||||
|
{{&id}}|{{&tag}}|{{&scope}}|[{{&workflow}}]|{{&assigned}}|{{&title}}
|
||||||
|
{{/items}}
|
||||||
|
|
@ -0,0 +1,3 @@
|
||||||
|
dist-newstyle/
|
||||||
|
.direnv/
|
||||||
|
.fixme/state.db
|
||||||
|
|
@ -0,0 +1,7 @@
|
||||||
|
# Revision history for suckless-conf
|
||||||
|
|
||||||
|
## 0.1.0.0 -- YYYY-mm-dd
|
||||||
|
|
||||||
|
* Test
|
||||||
|
|
||||||
|
* First version. Released on an unsuspecting world.
|
||||||
|
|
@ -0,0 +1,30 @@
|
||||||
|
Copyright (c) 2023, Dmitry Zuikov
|
||||||
|
|
||||||
|
All rights reserved.
|
||||||
|
|
||||||
|
Redistribution and use in source and binary forms, with or without
|
||||||
|
modification, are permitted provided that the following conditions are met:
|
||||||
|
|
||||||
|
* Redistributions of source code must retain the above copyright
|
||||||
|
notice, this list of conditions and the following disclaimer.
|
||||||
|
|
||||||
|
* Redistributions in binary form must reproduce the above
|
||||||
|
copyright notice, this list of conditions and the following
|
||||||
|
disclaimer in the documentation and/or other materials provided
|
||||||
|
with the distribution.
|
||||||
|
|
||||||
|
* Neither the name of Dmitry Zuikov nor the names of other
|
||||||
|
contributors may be used to endorse or promote products derived
|
||||||
|
from this software without specific prior written permission.
|
||||||
|
|
||||||
|
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||||
|
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||||
|
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||||
|
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||||
|
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||||
|
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||||
|
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||||
|
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||||
|
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||||
|
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||||
|
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||||
|
|
@ -0,0 +1,77 @@
|
||||||
|
## 2023-07-12
|
||||||
|
|
||||||
|
PR: key-value-utilities
|
||||||
|
branch: key-value-utilities
|
||||||
|
commit: cb4ee37f455b8e001fd5688106b2da1b31885dc4
|
||||||
|
Добавлены утилиты для работы с ключами и значениями.
|
||||||
|
|
||||||
|
## 2023-02-09
|
||||||
|
|
||||||
|
TODO: implement-regression-tests
|
||||||
|
|
||||||
|
54377068aac95cbfd8c69177a101c434feecff41
|
||||||
|
|
||||||
|
|
||||||
|
## 2023-02-07
|
||||||
|
|
||||||
|
Для fixme нам нужны конфиги. Стандартые конфиги это, в основном, треш,
|
||||||
|
поэтому будем делать новые. Как всегда.
|
||||||
|
|
||||||
|
Конфиги будут sexp, при этом, будут уметь притворяться не sexp.
|
||||||
|
|
||||||
|
поэтому:
|
||||||
|
|
||||||
|
```
|
||||||
|
atom term* eol
|
||||||
|
```
|
||||||
|
|
||||||
|
единичная инструкция.
|
||||||
|
|
||||||
|
эквивалентна
|
||||||
|
|
||||||
|
```
|
||||||
|
( atom term* )
|
||||||
|
```
|
||||||
|
|
||||||
|
выражение конфига:
|
||||||
|
|
||||||
|
```
|
||||||
|
|
||||||
|
(atom term* )
|
||||||
|
|
||||||
|
```
|
||||||
|
|
||||||
|
### term
|
||||||
|
|
||||||
|
```
|
||||||
|
term ::= string | number | atom | bool
|
||||||
|
```
|
||||||
|
|
||||||
|
Про bool это не точно.
|
||||||
|
|
||||||
|
|
||||||
|
### Пример конфига:
|
||||||
|
|
||||||
|
```
|
||||||
|
fixme-comments // # ; --
|
||||||
|
|
||||||
|
; FIXME могут быть в блоках комментариев,
|
||||||
|
; а могут и нет.
|
||||||
|
|
||||||
|
fixme-prefix FIXME: bug issue
|
||||||
|
|
||||||
|
; комментарий. ^^^^^ ^^^^^^^^^^^^^^^^^^^^^^
|
||||||
|
; Префикс Категории для префикса
|
||||||
|
|
||||||
|
|
||||||
|
```
|
||||||
|
|
||||||
|
Как биндить термы на целевой язык? В нашем случае Haskell.
|
||||||
|
|
||||||
|
|
||||||
|
FIXME: хорошо бы тут сразу поддержать wisp.
|
||||||
|
Но что бы его поддержать, надо его понять.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,130 @@
|
||||||
|
{
|
||||||
|
"nodes": {
|
||||||
|
"flake-utils": {
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1644229661,
|
||||||
|
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
|
||||||
|
"owner": "numtide",
|
||||||
|
"repo": "flake-utils",
|
||||||
|
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "numtide",
|
||||||
|
"repo": "flake-utils",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"flake-utils_2": {
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1644229661,
|
||||||
|
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
|
||||||
|
"owner": "numtide",
|
||||||
|
"repo": "flake-utils",
|
||||||
|
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "numtide",
|
||||||
|
"repo": "flake-utils",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"fuzzy": {
|
||||||
|
"inputs": {
|
||||||
|
"haskell-flake-utils": "haskell-flake-utils",
|
||||||
|
"nixpkgs": "nixpkgs"
|
||||||
|
},
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1727197542,
|
||||||
|
"narHash": "sha256-BF9Xd2fa8L5Xju9NTaoUjmzUEJfrRMMKULYQieBjbKo=",
|
||||||
|
"ref": "refs/heads/master",
|
||||||
|
"rev": "a834b152e29d632c816eefe117036e5d9330bd03",
|
||||||
|
"revCount": 43,
|
||||||
|
"type": "git",
|
||||||
|
"url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"type": "git",
|
||||||
|
"url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"haskell-flake-utils": {
|
||||||
|
"inputs": {
|
||||||
|
"flake-utils": "flake-utils"
|
||||||
|
},
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1707809372,
|
||||||
|
"narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
|
||||||
|
"owner": "ivanovs-4",
|
||||||
|
"repo": "haskell-flake-utils",
|
||||||
|
"rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "ivanovs-4",
|
||||||
|
"repo": "haskell-flake-utils",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"haskell-flake-utils_2": {
|
||||||
|
"inputs": {
|
||||||
|
"flake-utils": "flake-utils_2"
|
||||||
|
},
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1707809372,
|
||||||
|
"narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=",
|
||||||
|
"owner": "ivanovs-4",
|
||||||
|
"repo": "haskell-flake-utils",
|
||||||
|
"rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "ivanovs-4",
|
||||||
|
"repo": "haskell-flake-utils",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"nixpkgs": {
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1727089097,
|
||||||
|
"narHash": "sha256-ZMHMThPsthhUREwDebXw7GX45bJnBCVbfnH1g5iuSPc=",
|
||||||
|
"owner": "NixOS",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"rev": "568bfef547c14ca438c56a0bece08b8bb2b71a9c",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "NixOS",
|
||||||
|
"ref": "nixpkgs-unstable",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"nixpkgs_2": {
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1727089097,
|
||||||
|
"narHash": "sha256-ZMHMThPsthhUREwDebXw7GX45bJnBCVbfnH1g5iuSPc=",
|
||||||
|
"owner": "NixOS",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"rev": "568bfef547c14ca438c56a0bece08b8bb2b71a9c",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "NixOS",
|
||||||
|
"ref": "nixpkgs-unstable",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"root": {
|
||||||
|
"inputs": {
|
||||||
|
"fuzzy": "fuzzy",
|
||||||
|
"haskell-flake-utils": "haskell-flake-utils_2",
|
||||||
|
"nixpkgs": "nixpkgs_2"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"root": "root",
|
||||||
|
"version": 7
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,69 @@
|
||||||
|
{
|
||||||
|
description = "suckless-cong: sexp based configs";
|
||||||
|
|
||||||
|
inputs = {
|
||||||
|
nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable";
|
||||||
|
haskell-flake-utils.url = "github:ivanovs-4/haskell-flake-utils";
|
||||||
|
|
||||||
|
fuzzy.url =
|
||||||
|
# "git+http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?ref=sexp-parser&rev=bd3a38904864d5cc333974e7b029412607b46871";
|
||||||
|
"git+http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA";
|
||||||
|
|
||||||
|
};
|
||||||
|
|
||||||
|
outputs = { self, fuzzy, nixpkgs, haskell-flake-utils, ... }@inputs:
|
||||||
|
|
||||||
|
|
||||||
|
haskell-flake-utils.lib.simpleCabal2flake {
|
||||||
|
|
||||||
|
inherit self nixpkgs;
|
||||||
|
# systems = [ "x86_64-linux" ];
|
||||||
|
|
||||||
|
# wtf = import fetcher-flake.out.outPath;
|
||||||
|
# project-b = import fuzzy.out.outPath;
|
||||||
|
|
||||||
|
name = "suckless-conf";
|
||||||
|
|
||||||
|
## Optional parameters follow
|
||||||
|
|
||||||
|
# nixpkgs config
|
||||||
|
# config = { };
|
||||||
|
|
||||||
|
# Add another haskell flakes as requirements
|
||||||
|
# haskellFlakes = [ inputs.another-simple-haskell-flake ];
|
||||||
|
|
||||||
|
# Use this to load other flakes overlays to supplement nixpkgs
|
||||||
|
# preOverlays = [ ];
|
||||||
|
|
||||||
|
# Pass either a function or a file
|
||||||
|
# preOverlay = ./overlay.nix;
|
||||||
|
|
||||||
|
# Override haskell packages
|
||||||
|
# hpPreOverrides = { pkgs }: new: old:
|
||||||
|
# with pkgs.haskell.lib; with haskell-flake-utils.lib;
|
||||||
|
# tunePackages pkgs old {
|
||||||
|
# some-haskellPackages-package = [ dontHaddock ];
|
||||||
|
# } // {
|
||||||
|
# some-cabal-pkg = ((jailbreakUnbreak pkgs) (dontCheck (old.callCabal2nix "some-cabal-pkg" inputs.some-cabal-pkg {})));
|
||||||
|
# };
|
||||||
|
|
||||||
|
# Arguments for callCabal2nix
|
||||||
|
# cabal2nixArgs = {pkgs}: {
|
||||||
|
# };
|
||||||
|
|
||||||
|
# Maps to the devShell output. Pass in a shell.nix file or function
|
||||||
|
|
||||||
|
haskellFlakes = with inputs; [
|
||||||
|
fuzzy
|
||||||
|
];
|
||||||
|
|
||||||
|
# Additional build intputs of the default shell
|
||||||
|
shellExtBuildInputs = {pkgs}: with pkgs; [
|
||||||
|
haskellPackages.haskell-language-server
|
||||||
|
];
|
||||||
|
|
||||||
|
# Wether to build hoogle in the default shell
|
||||||
|
# shellWithHoogle = true;
|
||||||
|
|
||||||
|
};
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,12 @@
|
||||||
|
module Data.Config.Suckless
|
||||||
|
( module Data.Config.Suckless.Syntax
|
||||||
|
, module Data.Config.Suckless.Parse
|
||||||
|
, module Data.Config.Suckless.KeyValue
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Data.Config.Suckless.Syntax
|
||||||
|
import Data.Config.Suckless.Parse
|
||||||
|
import Data.Config.Suckless.KeyValue
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,111 @@
|
||||||
|
{-# Language PatternSynonyms #-}
|
||||||
|
{-# Language UndecidableInstances #-}
|
||||||
|
{-# Language AllowAmbiguousTypes #-}
|
||||||
|
module Data.Config.Suckless.KeyValue where
|
||||||
|
|
||||||
|
import Data.Config.Suckless.Syntax
|
||||||
|
|
||||||
|
import Data.String (IsString(..))
|
||||||
|
import Data.Set qualified as Set
|
||||||
|
import Data.Set (Set)
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Scientific
|
||||||
|
import Data.Aeson
|
||||||
|
import Prettyprinter
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import Control.Monad.Identity
|
||||||
|
import Safe
|
||||||
|
|
||||||
|
import Debug.Trace
|
||||||
|
|
||||||
|
class HasCfgKey a b where
|
||||||
|
-- type family CfgValue a :: Type
|
||||||
|
key :: Id
|
||||||
|
|
||||||
|
class Monad m => HasCfgValue a b m where
|
||||||
|
cfgValue :: m b
|
||||||
|
|
||||||
|
class Monad m => HasConf m where
|
||||||
|
getConf :: m [Syntax C]
|
||||||
|
|
||||||
|
pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c]
|
||||||
|
pattern Key n ns <- SymbolVal n : ns
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} (Monad m) => HasConf (ReaderT [Syntax C] m) where
|
||||||
|
getConf = ask
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Integer)) => HasCfgValue a (Maybe Integer) m where
|
||||||
|
cfgValue = lastMay . val <$> getConf
|
||||||
|
where
|
||||||
|
val syn = [ e
|
||||||
|
| ListVal (Key s [LitIntVal e]) <- syn, s == key @a @(Maybe Integer)
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Int)) => HasCfgValue a (Maybe Int) m where
|
||||||
|
cfgValue = lastMay . val <$> getConf @m
|
||||||
|
where
|
||||||
|
val syn = [ fromIntegral e
|
||||||
|
| ListVal (Key s [LitIntVal e]) <- syn, s == key @a @(Maybe Int)
|
||||||
|
]
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Scientific)) => HasCfgValue a (Maybe Scientific) m where
|
||||||
|
cfgValue = lastMay . val <$> getConf
|
||||||
|
where
|
||||||
|
val syn = [ e
|
||||||
|
| ListVal (Key s [LitScientificVal e]) <- syn, s == key @a @(Maybe Scientific)
|
||||||
|
]
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Bool)) => HasCfgValue a (Maybe Bool) m where
|
||||||
|
cfgValue = lastMay . val <$> getConf
|
||||||
|
where
|
||||||
|
val syn = [ e
|
||||||
|
| ListVal (Key s [LitBoolVal e]) <- syn, s == key @a @(Maybe Bool)
|
||||||
|
]
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Maybe Value)) => HasCfgValue a (Maybe Value) m where
|
||||||
|
cfgValue = lastMay . val <$> getConf
|
||||||
|
where
|
||||||
|
val syn = [ toJSON v
|
||||||
|
| ListVal (Key s [v@ListVal{}]) <- syn, s == key @a @(Maybe Value)
|
||||||
|
]
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} (HasConf m, IsString b, HasCfgKey a (Maybe b)) => HasCfgValue a (Maybe b) m where
|
||||||
|
cfgValue = lastMay . val <$> getConf
|
||||||
|
where
|
||||||
|
val syn = [ fromString (show $ pretty e)
|
||||||
|
| ListVal (Key s [LitStrVal e]) <- syn, s == key @a @(Maybe b)
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Integer)) => HasCfgValue a (Set Integer) m where
|
||||||
|
cfgValue = Set.fromList . val <$> getConf
|
||||||
|
where
|
||||||
|
val syn = [ e
|
||||||
|
| ListVal (Key s [LitIntVal e]) <- syn, s == key @a @(Set Integer)
|
||||||
|
]
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Scientific)) => HasCfgValue a (Set Scientific) m where
|
||||||
|
cfgValue = Set.fromList . val <$> getConf
|
||||||
|
where
|
||||||
|
val syn = [ e
|
||||||
|
| ListVal (Key s [LitScientificVal e]) <- syn, s == key @a @(Set Scientific)
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a (Set Value)) => HasCfgValue a (Set Value) m where
|
||||||
|
cfgValue = Set.fromList . val <$> getConf
|
||||||
|
where
|
||||||
|
val syn = [ toJSON v
|
||||||
|
| ListVal (Key s [v@ListVal{}]) <- syn, s == key @a @(Set Value)
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Set b)) => HasCfgValue a (Set b) m where
|
||||||
|
cfgValue = Set.fromList . val <$> getConf
|
||||||
|
where
|
||||||
|
val syn = [ fromString (show $ pretty e)
|
||||||
|
| ListVal (Key s [LitStrVal e]) <- syn, s == key @a @(Set b)
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,8 @@
|
||||||
|
module Data.Config.Suckless.Parse
|
||||||
|
( module Data.Config.Suckless.Parse.Fuzzy
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Config.Suckless.Parse.Fuzzy
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,40 @@
|
||||||
|
module Data.Config.Suckless.Parse.Fuzzy
|
||||||
|
( ParseSExp(..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Config.Suckless.Syntax
|
||||||
|
import Data.Text.Fuzzy.SExp qualified as P
|
||||||
|
import Data.Text.Fuzzy.SExp (C0(..),SExpParseError,ForMicroSexp(..))
|
||||||
|
|
||||||
|
import Data.Functor
|
||||||
|
import Data.Text as Text
|
||||||
|
import Control.Monad.Except
|
||||||
|
import Control.Monad.Identity
|
||||||
|
|
||||||
|
class ParseSExp what where
|
||||||
|
parseTop :: what -> Either SExpParseError [Syntax C]
|
||||||
|
parseSyntax :: what -> Either SExpParseError (Syntax C)
|
||||||
|
|
||||||
|
instance ParseSExp Text where
|
||||||
|
parseTop what = runIdentity (runExceptT (P.parseTop what)) <&> fmap toSyntax
|
||||||
|
parseSyntax txt = runIdentity (runExceptT (P.parseSexp txt)) <&> toSyntax
|
||||||
|
|
||||||
|
instance ParseSExp String where
|
||||||
|
parseTop what = runIdentity (runExceptT (P.parseTop (Text.pack what))) <&> fmap toSyntax
|
||||||
|
parseSyntax txt = runIdentity (runExceptT (P.parseSexp (Text.pack txt))) <&> toSyntax
|
||||||
|
|
||||||
|
toSyntax :: P.MicroSexp C0 -> Syntax C
|
||||||
|
toSyntax = \case
|
||||||
|
P.List_ co a -> List (toContext co) (fmap toSyntax a)
|
||||||
|
P.Symbol_ co a -> Symbol (toContext co) (Id a)
|
||||||
|
P.String_ co a -> Literal (toContext co) (LitStr a)
|
||||||
|
P.Boolean_ co a -> Literal (toContext co) (LitBool a)
|
||||||
|
P.Number_ co v -> case v of
|
||||||
|
P.NumInteger n -> Literal (toContext co) (LitInt n)
|
||||||
|
P.NumDouble n -> Literal (toContext co) (LitScientific (realToFrac n))
|
||||||
|
|
||||||
|
toContext :: C0 -> Context C
|
||||||
|
toContext (C0 what) = SimpleContext (fromIntegral <$> what)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,50 @@
|
||||||
|
{-# Language UndecidableInstances #-}
|
||||||
|
{-# Language PatternSynonyms #-}
|
||||||
|
module Data.Config.Suckless.Script
|
||||||
|
( module Exported
|
||||||
|
, module Data.Config.Suckless.Script
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Config.Suckless as Exported
|
||||||
|
import Data.Config.Suckless.Script.Internal as Exported
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
|
import Prettyprinter
|
||||||
|
import Prettyprinter.Render.Terminal
|
||||||
|
import Data.List qualified as List
|
||||||
|
import Data.Text qualified as Text
|
||||||
|
import UnliftIO
|
||||||
|
|
||||||
|
|
||||||
|
{- HLINT ignore "Functor law" -}
|
||||||
|
|
||||||
|
helpList :: MonadUnliftIO m => Bool -> Maybe String -> RunM c m ()
|
||||||
|
helpList hasDoc p = do
|
||||||
|
|
||||||
|
let match = maybe (const True) (Text.isPrefixOf . Text.pack) p
|
||||||
|
|
||||||
|
d <- ask >>= readTVarIO
|
||||||
|
let ks = [k | Id k <- List.sort (HM.keys d)
|
||||||
|
, match k
|
||||||
|
, not hasDoc || docDefined (HM.lookup (Id k) d)
|
||||||
|
]
|
||||||
|
|
||||||
|
display_ $ vcat (fmap pretty ks)
|
||||||
|
|
||||||
|
where
|
||||||
|
docDefined (Just (Bind (Just w) _)) = True
|
||||||
|
docDefined _ = False
|
||||||
|
|
||||||
|
helpEntry :: MonadUnliftIO m => Id -> RunM c m ()
|
||||||
|
helpEntry what = do
|
||||||
|
man <- ask >>= readTVarIO
|
||||||
|
<&> HM.lookup what
|
||||||
|
<&> maybe mzero bindMan
|
||||||
|
|
||||||
|
liftIO $ hPutDoc stdout (pretty man)
|
||||||
|
|
||||||
|
pattern HelpEntryBound :: forall {c}. Id -> [Syntax c]
|
||||||
|
pattern HelpEntryBound what <- [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )]
|
||||||
|
|
||||||
|
|
@ -0,0 +1,85 @@
|
||||||
|
{-# Language MultiWayIf #-}
|
||||||
|
module Data.Config.Suckless.Script.File where
|
||||||
|
|
||||||
|
import Data.Config.Suckless
|
||||||
|
import Data.Config.Suckless.Script.Internal
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
import Control.Monad.Trans.Class
|
||||||
|
import Control.Monad.Trans.Cont
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Either
|
||||||
|
import Data.Foldable
|
||||||
|
import System.Directory
|
||||||
|
import System.FilePath
|
||||||
|
import System.FilePattern
|
||||||
|
import Data.HashSet qualified as HS
|
||||||
|
|
||||||
|
import Lens.Micro.Platform
|
||||||
|
import UnliftIO
|
||||||
|
import Control.Concurrent.STM qualified as STM
|
||||||
|
import Streaming.Prelude qualified as S
|
||||||
|
|
||||||
|
-- FIXME: skip-symlink
|
||||||
|
glob :: forall m . MonadIO m
|
||||||
|
=> [FilePattern] -- ^ search patterns
|
||||||
|
-> [FilePattern] -- ^ ignore patterns
|
||||||
|
-> FilePath -- ^ directory
|
||||||
|
-> (FilePath -> m Bool) -- ^ file action
|
||||||
|
-> m ()
|
||||||
|
|
||||||
|
glob pat ignore dir action = do
|
||||||
|
q <- newTQueueIO
|
||||||
|
void $ liftIO (async $ go q dir >> atomically (writeTQueue q Nothing))
|
||||||
|
fix $ \next -> do
|
||||||
|
atomically (readTQueue q) >>= \case
|
||||||
|
Nothing -> pure ()
|
||||||
|
Just x -> do
|
||||||
|
r <- action x
|
||||||
|
when r next
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
matches p f = or [ i ?== f | i <- p ]
|
||||||
|
skip p = or [ i ?== p | i <- ignore ]
|
||||||
|
|
||||||
|
go q f = do
|
||||||
|
|
||||||
|
isD <- doesDirectoryExist f
|
||||||
|
|
||||||
|
if not isD then do
|
||||||
|
isF <- doesFileExist f
|
||||||
|
when (isF && matches pat f && not (skip f)) do
|
||||||
|
atomically $ writeTQueue q (Just f)
|
||||||
|
else do
|
||||||
|
co' <- (try @_ @IOError $ listDirectory f)
|
||||||
|
<&> fromRight mempty
|
||||||
|
|
||||||
|
forConcurrently_ co' $ \x -> do
|
||||||
|
let p = normalise (f </> x)
|
||||||
|
unless (skip p) (go q p)
|
||||||
|
|
||||||
|
entries :: forall c m . ( IsContext c
|
||||||
|
, Exception (BadFormException c)
|
||||||
|
, MonadUnliftIO m)
|
||||||
|
=> MakeDictM c m ()
|
||||||
|
entries = do
|
||||||
|
entry $ bindMatch "glob" $ \syn -> do
|
||||||
|
|
||||||
|
(p,i,d) <- case syn of
|
||||||
|
[] -> pure (["*"], [], ".")
|
||||||
|
|
||||||
|
[StringLike d, StringLike i, StringLike e] -> do
|
||||||
|
pure ([i], [e], d)
|
||||||
|
|
||||||
|
[StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e)] -> do
|
||||||
|
pure (i, e, d)
|
||||||
|
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
r <- S.toList_ $ glob p i d $ \fn -> do
|
||||||
|
S.yield (mkStr @c fn) -- do
|
||||||
|
pure True
|
||||||
|
|
||||||
|
pure (mkList r)
|
||||||
|
|
||||||
|
|
@ -0,0 +1,969 @@
|
||||||
|
{-# Language AllowAmbiguousTypes #-}
|
||||||
|
{-# Language UndecidableInstances #-}
|
||||||
|
{-# Language PatternSynonyms #-}
|
||||||
|
{-# Language ViewPatterns #-}
|
||||||
|
module Data.Config.Suckless.Script.Internal
|
||||||
|
( module Data.Config.Suckless.Script.Internal
|
||||||
|
, module Export
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Config.Suckless
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Control.Monad
|
||||||
|
import Control.Monad.Identity
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import Control.Monad.Writer
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.ByteString.Char8 qualified as BS8
|
||||||
|
import Data.Data
|
||||||
|
import Data.Function as Export
|
||||||
|
import Data.Functor as Export
|
||||||
|
import Data.Hashable
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
|
import Data.Kind
|
||||||
|
import Data.List (isPrefixOf)
|
||||||
|
import Data.List qualified as List
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.String
|
||||||
|
import Data.Text.IO qualified as TIO
|
||||||
|
import Data.Text qualified as Text
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Data.Time.Clock.POSIX
|
||||||
|
import GHC.Generics hiding (C)
|
||||||
|
import Prettyprinter
|
||||||
|
import Prettyprinter.Render.Terminal
|
||||||
|
import Safe
|
||||||
|
import Streaming.Prelude qualified as S
|
||||||
|
import System.Environment
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
import UnliftIO
|
||||||
|
|
||||||
|
-- TODO: move-to-suckless-conf
|
||||||
|
|
||||||
|
data ManApplyArg = ManApplyArg Text Text
|
||||||
|
deriving stock (Eq,Show,Data,Generic)
|
||||||
|
|
||||||
|
newtype ManApply = ManApply [ ManApplyArg ]
|
||||||
|
deriving stock (Eq,Show,Data,Generic)
|
||||||
|
deriving newtype (Semigroup,Monoid)
|
||||||
|
|
||||||
|
data ManSynopsis =
|
||||||
|
ManSynopsis ManApply
|
||||||
|
deriving stock (Eq,Show,Data,Generic)
|
||||||
|
|
||||||
|
data ManDesc = ManDescRaw Text
|
||||||
|
deriving stock (Eq,Show,Data,Generic)
|
||||||
|
|
||||||
|
data ManRetVal = ManRetVal
|
||||||
|
deriving stock (Eq,Show,Data,Generic)
|
||||||
|
|
||||||
|
newtype ManName a = ManName Id
|
||||||
|
deriving stock (Eq,Show,Data,Generic)
|
||||||
|
deriving newtype (IsString,Pretty)
|
||||||
|
|
||||||
|
newtype ManBrief = ManBrief Text
|
||||||
|
deriving stock (Eq,Show,Data,Generic)
|
||||||
|
deriving newtype (Pretty,IsString)
|
||||||
|
|
||||||
|
data ManReturns = ManReturns Text Text
|
||||||
|
deriving stock (Eq,Show,Data,Generic)
|
||||||
|
|
||||||
|
newtype ManExamples =
|
||||||
|
ManExamples Text
|
||||||
|
deriving stock (Eq,Show,Data,Generic)
|
||||||
|
deriving newtype (Pretty,IsString,Monoid,Semigroup)
|
||||||
|
|
||||||
|
class ManNameOf a ann where
|
||||||
|
manNameOf :: a -> ManName ann
|
||||||
|
|
||||||
|
data Man a =
|
||||||
|
Man
|
||||||
|
{ manName :: Maybe (ManName a)
|
||||||
|
, manHidden :: Bool
|
||||||
|
, manBrief :: Maybe ManBrief
|
||||||
|
, manSynopsis :: [ManSynopsis]
|
||||||
|
, manDesc :: Maybe ManDesc
|
||||||
|
, manReturns :: Maybe ManReturns
|
||||||
|
, manExamples :: [ManExamples]
|
||||||
|
}
|
||||||
|
deriving stock (Eq,Show,Generic)
|
||||||
|
|
||||||
|
instance Monoid (Man a) where
|
||||||
|
mempty = Man Nothing False Nothing mempty Nothing Nothing mempty
|
||||||
|
|
||||||
|
instance Semigroup (Man a) where
|
||||||
|
(<>) a b = Man (manName b <|> manName a)
|
||||||
|
(manHidden b || manHidden a)
|
||||||
|
(manBrief b <|> manBrief a)
|
||||||
|
(manSynopsis a <> manSynopsis b)
|
||||||
|
(manDesc b <|> manDesc a)
|
||||||
|
(manReturns b <|> manReturns a)
|
||||||
|
(manExamples a <> manExamples b)
|
||||||
|
|
||||||
|
instance ManNameOf Id a where
|
||||||
|
manNameOf = ManName
|
||||||
|
|
||||||
|
|
||||||
|
instance Pretty ManDesc where
|
||||||
|
pretty = \case
|
||||||
|
ManDescRaw t -> pretty t
|
||||||
|
|
||||||
|
instance IsString ManDesc where
|
||||||
|
fromString s = ManDescRaw (Text.pack s)
|
||||||
|
|
||||||
|
instance Pretty (Man a) where
|
||||||
|
pretty e = "NAME"
|
||||||
|
<> line
|
||||||
|
<> indent 8 (pretty (manName e) <> fmtBrief e)
|
||||||
|
<> line
|
||||||
|
<> fmtSynopsis
|
||||||
|
<> fmtDescription
|
||||||
|
<> retval
|
||||||
|
<> fmtExamples
|
||||||
|
where
|
||||||
|
fmtBrief a = case manBrief a of
|
||||||
|
Nothing -> mempty
|
||||||
|
Just x -> " - " <> pretty x
|
||||||
|
|
||||||
|
retval = case manReturns e of
|
||||||
|
Nothing -> mempty
|
||||||
|
Just (ManReturns t s) ->
|
||||||
|
line <> "RETURN VALUE" <> line
|
||||||
|
<> indent 8 (
|
||||||
|
if not (Text.null s) then
|
||||||
|
(pretty t <> hsep ["","-",""] <> pretty s) <> line
|
||||||
|
else pretty t )
|
||||||
|
|
||||||
|
fmtDescription = line
|
||||||
|
<> "DESCRIPTION" <> line
|
||||||
|
<> indent 8 ( case manDesc e of
|
||||||
|
Nothing -> pretty (manBrief e)
|
||||||
|
Just x -> pretty x)
|
||||||
|
<> line
|
||||||
|
|
||||||
|
fmtSynopsis = case manSynopsis e of
|
||||||
|
[] -> mempty
|
||||||
|
_ ->
|
||||||
|
line
|
||||||
|
<> "SYNOPSIS"
|
||||||
|
<> line
|
||||||
|
<> vcat (fmap synEntry (manSynopsis e))
|
||||||
|
<> line
|
||||||
|
|
||||||
|
fmtExamples = case manExamples e of
|
||||||
|
[] -> mempty
|
||||||
|
es -> line
|
||||||
|
<> "EXAMPLES"
|
||||||
|
<> line
|
||||||
|
<> indent 8 ( vcat (fmap pretty es) )
|
||||||
|
|
||||||
|
synEntry (ManSynopsis (ManApply [])) =
|
||||||
|
indent 8 ( parens (pretty (manName e)) ) <> line
|
||||||
|
|
||||||
|
synEntry (ManSynopsis (ManApply xs)) = do
|
||||||
|
indent 8 do
|
||||||
|
parens (pretty (manName e) <+>
|
||||||
|
hsep [ pretty n | ManApplyArg t n <- xs ] )
|
||||||
|
<> line
|
||||||
|
<> line
|
||||||
|
<> vcat [ pretty n <+> ":" <+> pretty t | ManApplyArg t n <- xs ]
|
||||||
|
|
||||||
|
stringLike :: Syntax c -> Maybe String
|
||||||
|
stringLike = \case
|
||||||
|
LitStrVal s -> Just $ Text.unpack s
|
||||||
|
SymbolVal (Id s) -> Just $ Text.unpack s
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
stringLikeList :: [Syntax c] -> [String]
|
||||||
|
stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
|
||||||
|
|
||||||
|
blobLike :: Syntax c -> Maybe ByteString
|
||||||
|
blobLike = \case
|
||||||
|
LitStrVal s -> Just $ BS8.pack (Text.unpack s)
|
||||||
|
ListVal [SymbolVal "blob", LitStrVal s] -> Just $ BS8.pack (Text.unpack s)
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
pattern BlobLike :: forall {c} . ByteString -> Syntax c
|
||||||
|
pattern BlobLike s <- (blobLike -> Just s)
|
||||||
|
|
||||||
|
class Display a where
|
||||||
|
display :: MonadIO m => a -> m ()
|
||||||
|
|
||||||
|
instance {-# OVERLAPPABLE #-} Pretty w => Display w where
|
||||||
|
display = liftIO . print . pretty
|
||||||
|
|
||||||
|
instance IsContext c => Display (Syntax c) where
|
||||||
|
display = \case
|
||||||
|
LitStrVal s -> liftIO $ TIO.putStr s
|
||||||
|
-- ListVal [SymbolVal "small-encrypted-block", LitStrVal txt] -> do
|
||||||
|
-- let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty
|
||||||
|
-- liftIO $ print $ parens $ "small-encrypted-block" <+> parens ("blob" <+> dquotes s)
|
||||||
|
-- ListVal [SymbolVal "blob", LitStrVal txt] -> do
|
||||||
|
-- let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty
|
||||||
|
-- liftIO $ print $ parens $ "blob:base58" <+> dquotes s
|
||||||
|
x -> liftIO $ putStr (show $ pretty x)
|
||||||
|
|
||||||
|
instance Display Text where
|
||||||
|
display = liftIO . TIO.putStr
|
||||||
|
|
||||||
|
instance Display String where
|
||||||
|
display = liftIO . putStr
|
||||||
|
|
||||||
|
display_ :: (MonadIO m, Show a) => a -> m ()
|
||||||
|
display_ = liftIO . print
|
||||||
|
|
||||||
|
{- HLINT ignore "Functor law" -}
|
||||||
|
|
||||||
|
class IsContext c => MkSym c a where
|
||||||
|
mkSym :: a -> Syntax c
|
||||||
|
|
||||||
|
instance IsContext c => MkSym c String where
|
||||||
|
mkSym s = Symbol noContext (Id $ Text.pack s)
|
||||||
|
|
||||||
|
instance IsContext c => MkSym c Text where
|
||||||
|
mkSym s = Symbol noContext (Id s)
|
||||||
|
|
||||||
|
instance IsContext c => MkSym c Id where
|
||||||
|
mkSym = Symbol noContext
|
||||||
|
|
||||||
|
class IsContext c => MkStr c s where
|
||||||
|
mkStr :: s -> Syntax c
|
||||||
|
|
||||||
|
instance IsContext c => MkStr c String where
|
||||||
|
mkStr s = Literal noContext $ LitStr (Text.pack s)
|
||||||
|
|
||||||
|
instance IsContext c => MkStr c Text where
|
||||||
|
mkStr s = Literal noContext $ LitStr s
|
||||||
|
|
||||||
|
mkBool :: forall c . IsContext c => Bool -> Syntax c
|
||||||
|
mkBool v = Literal noContext (LitBool v)
|
||||||
|
|
||||||
|
|
||||||
|
class IsContext c => MkForm c a where
|
||||||
|
mkForm :: a-> [Syntax c] -> Syntax c
|
||||||
|
|
||||||
|
instance (IsContext c, MkSym c s) => MkForm c s where
|
||||||
|
mkForm s sy = List noContext ( mkSym @c s : sy )
|
||||||
|
|
||||||
|
mkList :: forall c. IsContext c => [Syntax c] -> Syntax c
|
||||||
|
mkList = List noContext
|
||||||
|
|
||||||
|
isFalse :: forall c . IsContext c => Syntax c -> Bool
|
||||||
|
isFalse = \case
|
||||||
|
Literal _ (LitBool False) -> True
|
||||||
|
ListVal [] -> True
|
||||||
|
_ -> False
|
||||||
|
|
||||||
|
eatNil :: Monad m => (Syntax c -> m a) -> Syntax c -> m ()
|
||||||
|
eatNil f = \case
|
||||||
|
Nil -> pure ()
|
||||||
|
x -> void $ f x
|
||||||
|
|
||||||
|
class IsContext c => MkInt c s where
|
||||||
|
mkInt :: s -> Syntax c
|
||||||
|
|
||||||
|
instance (Integral i, IsContext c) => MkInt c i where
|
||||||
|
mkInt n = Literal noContext $ LitInt (fromIntegral n)
|
||||||
|
|
||||||
|
class OptionalVal c b where
|
||||||
|
optional :: b -> Syntax c -> b
|
||||||
|
|
||||||
|
instance IsContext c => OptionalVal c Int where
|
||||||
|
optional d = \case
|
||||||
|
LitIntVal x -> fromIntegral x
|
||||||
|
_ -> d
|
||||||
|
|
||||||
|
hasKey :: IsContext c => Id -> [Syntax c] -> Maybe (Syntax c)
|
||||||
|
hasKey k ss = headMay [ e | ListVal [SymbolVal z, e] <- ss, z == k]
|
||||||
|
|
||||||
|
|
||||||
|
pattern Lambda :: forall {c}. [Id] -> Syntax c -> Syntax c
|
||||||
|
pattern Lambda a e <- ListVal [SymbolVal "lambda", LambdaArgs a, e]
|
||||||
|
|
||||||
|
pattern LambdaArgs :: [Id] -> Syntax c
|
||||||
|
pattern LambdaArgs a <- (lambdaArgList -> Just a)
|
||||||
|
|
||||||
|
|
||||||
|
lambdaArgList :: Syntax c -> Maybe [Id]
|
||||||
|
|
||||||
|
lambdaArgList (ListVal a) = sequence argz
|
||||||
|
where
|
||||||
|
argz = flip fmap a \case
|
||||||
|
(SymbolVal x) -> Just x
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
lambdaArgList _ = Nothing
|
||||||
|
|
||||||
|
|
||||||
|
pattern PairList :: [Syntax c] -> [Syntax c]
|
||||||
|
pattern PairList es <- (pairList -> es)
|
||||||
|
|
||||||
|
pairList :: [Syntax c ] -> [Syntax c]
|
||||||
|
pairList syn = [ isPair s | s <- syn ] & takeWhile isJust & catMaybes
|
||||||
|
|
||||||
|
optlist :: IsContext c => [Syntax c] -> [(Id, Syntax c)]
|
||||||
|
optlist = reverse . go []
|
||||||
|
where
|
||||||
|
go acc ( SymbolVal i : b : rest ) = go ((i, b) : acc) rest
|
||||||
|
go acc [ SymbolVal i ] = (i, nil) : acc
|
||||||
|
go acc _ = acc
|
||||||
|
|
||||||
|
|
||||||
|
isPair :: Syntax c -> Maybe (Syntax c)
|
||||||
|
isPair = \case
|
||||||
|
e@(ListVal [_,_]) -> Just e
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
data BindAction c ( m :: Type -> Type) =
|
||||||
|
BindLambda { fromLambda :: [Syntax c] -> RunM c m (Syntax c) }
|
||||||
|
| BindValue (Syntax c)
|
||||||
|
|
||||||
|
data Bind c ( m :: Type -> Type) = Bind
|
||||||
|
{ bindMan :: Maybe (Man AnsiStyle)
|
||||||
|
, bindAction :: BindAction c m
|
||||||
|
} deriving (Generic)
|
||||||
|
|
||||||
|
deriving newtype instance Hashable Id
|
||||||
|
|
||||||
|
newtype NameNotBoundException =
|
||||||
|
NameNotBound Id
|
||||||
|
deriving stock Show
|
||||||
|
deriving newtype (Generic,Typeable)
|
||||||
|
|
||||||
|
newtype NotLambda = NotLambda Id
|
||||||
|
deriving stock Show
|
||||||
|
deriving newtype (Generic,Typeable)
|
||||||
|
|
||||||
|
instance Exception NotLambda
|
||||||
|
|
||||||
|
data BadFormException c = BadFormException (Syntax c)
|
||||||
|
| ArityMismatch (Syntax c)
|
||||||
|
|
||||||
|
newtype TypeCheckError c = TypeCheckError (Syntax c)
|
||||||
|
|
||||||
|
instance Exception (TypeCheckError C)
|
||||||
|
|
||||||
|
newtype BadValueException = BadValueException String
|
||||||
|
deriving stock Show
|
||||||
|
deriving newtype (Generic,Typeable)
|
||||||
|
|
||||||
|
instance Exception NameNotBoundException
|
||||||
|
|
||||||
|
instance IsContext c => Show (BadFormException c) where
|
||||||
|
show (BadFormException sy) = show $ "BadFormException" <+> pretty sy
|
||||||
|
show (ArityMismatch sy) = show $ "ArityMismatch" <+> pretty sy
|
||||||
|
|
||||||
|
instance IsContext c => Show (TypeCheckError c) where
|
||||||
|
show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy
|
||||||
|
|
||||||
|
instance Exception (BadFormException C)
|
||||||
|
|
||||||
|
instance Exception BadValueException
|
||||||
|
|
||||||
|
type Dict c m = HashMap Id (Bind c m)
|
||||||
|
|
||||||
|
newtype RunM c m a = RunM { fromRunM :: ReaderT (TVar (Dict c m)) m a }
|
||||||
|
deriving newtype ( Applicative
|
||||||
|
, Functor
|
||||||
|
, Monad
|
||||||
|
, MonadIO
|
||||||
|
, MonadUnliftIO
|
||||||
|
, MonadReader (TVar (Dict c m))
|
||||||
|
)
|
||||||
|
|
||||||
|
instance MonadTrans (RunM c) where
|
||||||
|
lift = RunM . lift
|
||||||
|
|
||||||
|
newtype MakeDictM c m a = MakeDictM { fromMakeDict :: Writer (Dict c m) a }
|
||||||
|
deriving newtype ( Applicative
|
||||||
|
, Functor
|
||||||
|
, Monad
|
||||||
|
, MonadWriter (Dict c m)
|
||||||
|
)
|
||||||
|
|
||||||
|
makeDict :: (IsContext c, Monad m) => MakeDictM c m () -> Dict c m
|
||||||
|
makeDict w = execWriter ( fromMakeDict w )
|
||||||
|
|
||||||
|
entry :: Dict c m -> MakeDictM c m ()
|
||||||
|
entry = tell
|
||||||
|
|
||||||
|
hide :: MakeDictM c m ()
|
||||||
|
hide = pure ()
|
||||||
|
|
||||||
|
desc :: Doc ann -> MakeDictM c m () -> MakeDictM c m ()
|
||||||
|
desc txt = censor (HM.map setDesc)
|
||||||
|
where
|
||||||
|
w0 = mempty { manDesc = Just (ManDescRaw $ Text.pack $ show txt) }
|
||||||
|
setDesc (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x
|
||||||
|
|
||||||
|
brief :: ManBrief -> MakeDictM c m () -> MakeDictM c m ()
|
||||||
|
brief txt = censor (HM.map setBrief)
|
||||||
|
where
|
||||||
|
w0 = mempty { manBrief = Just txt }
|
||||||
|
setBrief (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x
|
||||||
|
|
||||||
|
returns :: Text -> Text -> MakeDictM c m () -> MakeDictM c m ()
|
||||||
|
returns tp txt = censor (HM.map setReturns)
|
||||||
|
where
|
||||||
|
w0 = mempty { manReturns = Just (ManReturns tp txt) }
|
||||||
|
setReturns (Bind w x) = Bind (Just (maybe w0 (<>w0) w)) x
|
||||||
|
|
||||||
|
|
||||||
|
addSynopsis :: ManSynopsis -> Bind c m -> Bind c m
|
||||||
|
addSynopsis synopsis (Bind w x) = Bind (Just updatedMan) x
|
||||||
|
where
|
||||||
|
updatedMan = case w of
|
||||||
|
Nothing -> mempty { manSynopsis = [synopsis] }
|
||||||
|
Just man -> man { manSynopsis = manSynopsis man <> [synopsis] }
|
||||||
|
|
||||||
|
noArgs :: MakeDictM c m () -> MakeDictM c m ()
|
||||||
|
noArgs = censor (HM.map (addSynopsis (ManSynopsis (ManApply []))))
|
||||||
|
|
||||||
|
arg :: Text -> Text -> ManApplyArg
|
||||||
|
arg = ManApplyArg
|
||||||
|
|
||||||
|
|
||||||
|
args :: [ManApplyArg] -> MakeDictM c m () -> MakeDictM c m ()
|
||||||
|
args argList = censor (HM.map (addSynopsis (ManSynopsis (ManApply argList))))
|
||||||
|
|
||||||
|
opt :: Doc a -> Doc a -> Doc a
|
||||||
|
opt n d = n <+> "-" <+> d
|
||||||
|
|
||||||
|
examples :: ManExamples -> MakeDictM c m () -> MakeDictM c m ()
|
||||||
|
examples (ManExamples s) = censor (HM.map setExamples )
|
||||||
|
where
|
||||||
|
ex = ManExamples (Text.unlines $ Text.strip <$> Text.lines (Text.strip s))
|
||||||
|
ex0 = mempty { manExamples = [ex] }
|
||||||
|
setExamples (Bind w x) = Bind (Just (maybe ex0 (<>ex0) w)) x
|
||||||
|
|
||||||
|
splitForms :: [String] -> [[String]]
|
||||||
|
splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
|
||||||
|
where
|
||||||
|
go acc ( "then" : rest ) = emit acc >> go mempty rest
|
||||||
|
go acc ( "and" : rest ) = emit acc >> go mempty rest
|
||||||
|
go acc ( x : rest ) | isPrefixOf "-" x = go ( x : acc ) rest
|
||||||
|
go acc ( x : rest ) | isPrefixOf "--" x = go ( x : acc ) rest
|
||||||
|
go acc ( x : rest ) = go ( x : acc ) rest
|
||||||
|
go acc [] = emit acc
|
||||||
|
|
||||||
|
emit = S.yield . reverse
|
||||||
|
|
||||||
|
applyLambda :: forall c m . ( IsContext c
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, Exception (BadFormException c)
|
||||||
|
)
|
||||||
|
=> [Id]
|
||||||
|
-> Syntax c
|
||||||
|
-> [Syntax c]
|
||||||
|
-> RunM c m (Syntax c)
|
||||||
|
applyLambda decl body args = do
|
||||||
|
|
||||||
|
when (length decl /= length args) do
|
||||||
|
throwIO (ArityMismatch @c nil)
|
||||||
|
|
||||||
|
ev <- mapM eval args
|
||||||
|
tv <- ask
|
||||||
|
d0 <- readTVarIO tv
|
||||||
|
|
||||||
|
forM_ (zip decl ev) $ \(n,v) -> do
|
||||||
|
bind n v
|
||||||
|
|
||||||
|
e <- eval body
|
||||||
|
|
||||||
|
atomically $ writeTVar tv d0
|
||||||
|
pure e
|
||||||
|
|
||||||
|
apply_ :: forall c m . ( IsContext c
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, Exception (BadFormException c)
|
||||||
|
)
|
||||||
|
=> Syntax c
|
||||||
|
-> [Syntax c]
|
||||||
|
-> RunM c m (Syntax c)
|
||||||
|
|
||||||
|
apply_ s args = case s of
|
||||||
|
ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> apply n args
|
||||||
|
SymbolVal what -> apply what args
|
||||||
|
Lambda d body -> applyLambda d body args
|
||||||
|
e -> throwIO $ BadFormException @c s
|
||||||
|
|
||||||
|
apply :: forall c m . ( IsContext c
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, Exception (BadFormException c)
|
||||||
|
)
|
||||||
|
=> Id
|
||||||
|
-> [Syntax c]
|
||||||
|
-> RunM c m (Syntax c)
|
||||||
|
apply name args' = do
|
||||||
|
-- notice $ red "APPLY" <+> pretty name
|
||||||
|
what <- ask >>= readTVarIO <&> HM.lookup name
|
||||||
|
|
||||||
|
case bindAction <$> what of
|
||||||
|
Just (BindLambda e) -> mapM eval args' >>= e
|
||||||
|
|
||||||
|
Just (BindValue (Lambda argz body) ) -> do
|
||||||
|
applyLambda argz body args'
|
||||||
|
|
||||||
|
Just (BindValue _) -> do
|
||||||
|
throwIO (NotLambda name)
|
||||||
|
|
||||||
|
Nothing -> throwIO (NameNotBound name)
|
||||||
|
|
||||||
|
bind :: forall c m . ( IsContext c
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, Exception (BadFormException c)
|
||||||
|
)
|
||||||
|
=> Id
|
||||||
|
-> Syntax c
|
||||||
|
-> RunM c m ()
|
||||||
|
bind name expr = do
|
||||||
|
t <- ask
|
||||||
|
|
||||||
|
what <- case expr of
|
||||||
|
ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> do
|
||||||
|
m <- readTVarIO t
|
||||||
|
HM.lookup n m & maybe (throwIO (NameNotBound n)) pure
|
||||||
|
|
||||||
|
e -> pure $ Bind mzero (BindValue e)
|
||||||
|
|
||||||
|
atomically do
|
||||||
|
modifyTVar t (HM.insert name what)
|
||||||
|
|
||||||
|
bindBuiltins :: forall c m . ( IsContext c
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, Exception (BadFormException c)
|
||||||
|
)
|
||||||
|
=> Dict c m
|
||||||
|
-> RunM c m ()
|
||||||
|
|
||||||
|
bindBuiltins dict = do
|
||||||
|
t <- ask
|
||||||
|
atomically do
|
||||||
|
modifyTVar t (<> dict)
|
||||||
|
|
||||||
|
eval :: forall c m . ( IsContext c
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, Exception (BadFormException c)
|
||||||
|
) => Syntax c -> RunM c m (Syntax c)
|
||||||
|
eval syn = handle (handleForm syn) $ do
|
||||||
|
|
||||||
|
dict <- ask >>= readTVarIO
|
||||||
|
|
||||||
|
case syn of
|
||||||
|
|
||||||
|
ListVal [ w, SymbolVal ".", b] -> do
|
||||||
|
pure $ mkList [w, b]
|
||||||
|
|
||||||
|
ListVal [ SymbolVal "quot", ListVal b] -> do
|
||||||
|
pure $ mkList b
|
||||||
|
|
||||||
|
ListVal [SymbolVal "define", SymbolVal what, e] -> do
|
||||||
|
ev <- eval e
|
||||||
|
bind what ev>> pure nil
|
||||||
|
|
||||||
|
ListVal [SymbolVal "lambda", arglist, body] -> do
|
||||||
|
pure $ mkForm @c "lambda" [ arglist, body ]
|
||||||
|
|
||||||
|
ListVal [SymbolVal "define", LambdaArgs (name : args), e] -> do
|
||||||
|
bind name ( mkForm @c "lambda" [ mkList [ mkSym s | s <- args], e ] )
|
||||||
|
pure nil
|
||||||
|
|
||||||
|
ListVal [SymbolVal "false?", e'] -> do
|
||||||
|
e <- eval e'
|
||||||
|
pure $ if isFalse e then mkBool True else mkBool False
|
||||||
|
|
||||||
|
ListVal [SymbolVal "if", w, e1, e2] -> do
|
||||||
|
what <- eval w
|
||||||
|
if isFalse what then eval e2 else eval e1
|
||||||
|
|
||||||
|
ListVal (SymbolVal "begin" : what) -> do
|
||||||
|
evalTop what
|
||||||
|
|
||||||
|
e@(ListVal (SymbolVal "blob" : what)) -> do
|
||||||
|
pure e
|
||||||
|
-- evalTop what
|
||||||
|
|
||||||
|
lc@(ListVal (Lambda decl body : args)) -> do
|
||||||
|
applyLambda decl body args
|
||||||
|
|
||||||
|
ListVal (SymbolVal name : args') -> do
|
||||||
|
apply name args'
|
||||||
|
|
||||||
|
SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
|
||||||
|
pure (mkSym @c (Text.drop 1 s))
|
||||||
|
|
||||||
|
SymbolVal name | HM.member name dict -> do
|
||||||
|
let what = HM.lookup name dict
|
||||||
|
& maybe (BindValue (mkSym name)) bindAction
|
||||||
|
|
||||||
|
case what of
|
||||||
|
BindValue e -> pure e
|
||||||
|
BindLambda e -> pure $ mkForm "builtin:lambda" [mkSym name]
|
||||||
|
|
||||||
|
e@(SymbolVal name) | not (HM.member name dict) -> do
|
||||||
|
pure e
|
||||||
|
|
||||||
|
e@Literal{} -> pure e
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @c e
|
||||||
|
|
||||||
|
where
|
||||||
|
handleForm syn = \case
|
||||||
|
(BadFormException _ :: BadFormException c) -> do
|
||||||
|
throwIO (BadFormException syn)
|
||||||
|
(ArityMismatch s :: BadFormException c) -> do
|
||||||
|
throwIO (ArityMismatch syn)
|
||||||
|
|
||||||
|
runM :: forall c m a. ( IsContext c
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, Exception (BadFormException c)
|
||||||
|
) => Dict c m -> RunM c m a -> m a
|
||||||
|
runM d m = do
|
||||||
|
tvd <- newTVarIO d
|
||||||
|
runReaderT (fromRunM m) tvd
|
||||||
|
|
||||||
|
run :: forall c m . ( IsContext c
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, Exception (BadFormException c)
|
||||||
|
) => Dict c m -> [Syntax c] -> m (Syntax c)
|
||||||
|
run d sy = do
|
||||||
|
tvd <- newTVarIO d
|
||||||
|
lastDef nil <$> runReaderT (fromRunM (mapM eval sy)) tvd
|
||||||
|
|
||||||
|
evalTop :: forall c m . ( IsContext c
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, Exception (BadFormException c))
|
||||||
|
=> [Syntax c]
|
||||||
|
-> RunM c m (Syntax c)
|
||||||
|
evalTop syn = lastDef nil <$> mapM eval syn
|
||||||
|
|
||||||
|
bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m
|
||||||
|
bindMatch n fn = HM.singleton n (Bind man (BindLambda fn))
|
||||||
|
where
|
||||||
|
man = Just $ mempty { manName = Just (manNameOf n) }
|
||||||
|
|
||||||
|
bindValue :: Id -> Syntax c -> Dict c m
|
||||||
|
bindValue n e = HM.singleton n (Bind mzero (BindValue e))
|
||||||
|
|
||||||
|
nil :: forall c . IsContext c => Syntax c
|
||||||
|
nil = List noContext []
|
||||||
|
|
||||||
|
nil_ :: (IsContext c, MonadIO m) => (a -> RunM c m b) -> a -> RunM c m (Syntax c)
|
||||||
|
nil_ m w = m w >> pure (List noContext [])
|
||||||
|
|
||||||
|
fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2
|
||||||
|
fixContext = go
|
||||||
|
where
|
||||||
|
go = \case
|
||||||
|
List _ xs -> List noContext (fmap go xs)
|
||||||
|
Symbol _ w -> Symbol noContext w
|
||||||
|
Literal _ l -> Literal noContext l
|
||||||
|
|
||||||
|
|
||||||
|
fmt :: Syntax c -> Doc ann
|
||||||
|
fmt = \case
|
||||||
|
LitStrVal x -> pretty $ Text.unpack x
|
||||||
|
x -> pretty x
|
||||||
|
|
||||||
|
internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m ()
|
||||||
|
internalEntries = do
|
||||||
|
|
||||||
|
entry $ bindValue "false" (mkBool False)
|
||||||
|
entry $ bindValue "true" (mkBool True)
|
||||||
|
entry $ bindValue "chr:semi" (mkStr ";")
|
||||||
|
entry $ bindValue "chr:tilda" (mkStr "~")
|
||||||
|
entry $ bindValue "chr:colon" (mkStr ":")
|
||||||
|
entry $ bindValue "chr:comma" (mkStr ",")
|
||||||
|
entry $ bindValue "chr:q" (mkStr "'")
|
||||||
|
entry $ bindValue "chr:minus" (mkStr "-")
|
||||||
|
entry $ bindValue "chr:dq" (mkStr "\"")
|
||||||
|
entry $ bindValue "chr:lf" (mkStr "\n")
|
||||||
|
entry $ bindValue "chr:cr" (mkStr "\r")
|
||||||
|
entry $ bindValue "chr:tab" (mkStr "\t")
|
||||||
|
entry $ bindValue "chr:space" (mkStr " ")
|
||||||
|
|
||||||
|
brief "concatenates list of string-like elements into a string"
|
||||||
|
$ args [arg "list" "(list ...)"]
|
||||||
|
$ args [arg "..." "..."]
|
||||||
|
$ returns "string" ""
|
||||||
|
$ examples [qc|
|
||||||
|
(concat a b c d)
|
||||||
|
abcd|]
|
||||||
|
$ examples [qc|
|
||||||
|
(concat 1 2 3 4 5)
|
||||||
|
12345|]
|
||||||
|
|
||||||
|
$ entry $ bindMatch "concat" $ \syn -> do
|
||||||
|
|
||||||
|
case syn of
|
||||||
|
[ListVal xs] -> do
|
||||||
|
pure $ mkStr ( show $ hcat (fmap fmt xs) )
|
||||||
|
|
||||||
|
xs -> do
|
||||||
|
pure $ mkStr ( show $ hcat (fmap fmt xs) )
|
||||||
|
|
||||||
|
brief "creates a list of elements"
|
||||||
|
$ args [arg "..." "..."]
|
||||||
|
$ returns "list" ""
|
||||||
|
$ examples [qc|
|
||||||
|
(list 1 2 3 fuu bar "baz")
|
||||||
|
(1 2 3 fuu bar "baz")
|
||||||
|
|]
|
||||||
|
$ entry $ bindMatch "list" $ \case
|
||||||
|
es -> do
|
||||||
|
pure $ mkList es
|
||||||
|
|
||||||
|
entry $ bindMatch "dict" $ \case
|
||||||
|
(pairList -> es@(_:_)) -> do
|
||||||
|
pure $ mkForm "dict" es
|
||||||
|
[a, b] -> do
|
||||||
|
pure $ mkForm "dict" [ mkList [a, b] ]
|
||||||
|
_ -> throwIO (BadFormException @C nil)
|
||||||
|
|
||||||
|
brief "creates a dict from a linear list of string-like items"
|
||||||
|
$ args [arg "list-of-terms" "..."]
|
||||||
|
$ desc ( "macro; syntax sugar" <> line
|
||||||
|
<> "useful for creating function args" <> line
|
||||||
|
<> "leftover records are skipped"
|
||||||
|
)
|
||||||
|
$ returns "dict" ""
|
||||||
|
$ examples [qc|
|
||||||
|
[kw a 1 b 2 c 3]
|
||||||
|
(dict (a 1) (b 2) (c 3))
|
||||||
|
|
||||||
|
[kw a]
|
||||||
|
(dict (a ()))
|
||||||
|
|
||||||
|
[kw a b]
|
||||||
|
(dict (a b))
|
||||||
|
|
||||||
|
[kw 1 2 3]
|
||||||
|
(dict)
|
||||||
|
|
||||||
|
[kw a b c]
|
||||||
|
(dict (a b) (c ()))
|
||||||
|
|]
|
||||||
|
$ entry $ bindMatch "kw" $ \syn -> do
|
||||||
|
let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ]
|
||||||
|
pure $ mkForm "dict" wat
|
||||||
|
|
||||||
|
entry $ bindMatch "iterate" $ nil_ $ \syn -> do
|
||||||
|
case syn of
|
||||||
|
[ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do
|
||||||
|
mapM_ (apply @c fn . List.singleton) rs
|
||||||
|
|
||||||
|
[Lambda decl body, ListVal args] -> do
|
||||||
|
mapM_ (applyLambda decl body . List.singleton) args
|
||||||
|
|
||||||
|
_ -> do
|
||||||
|
throwIO (BadFormException @C nil)
|
||||||
|
|
||||||
|
entry $ bindMatch "repeat" $ nil_ $ \case
|
||||||
|
[LitIntVal n, Lambda [] b] -> do
|
||||||
|
replicateM_ (fromIntegral n) (applyLambda [] b [])
|
||||||
|
|
||||||
|
[LitIntVal n, e@(ListVal _)] -> do
|
||||||
|
replicateM_ (fromIntegral n) (eval e)
|
||||||
|
|
||||||
|
z ->
|
||||||
|
throwIO (BadFormException @C nil)
|
||||||
|
|
||||||
|
entry $ bindMatch "map" $ \syn -> do
|
||||||
|
case syn of
|
||||||
|
[ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do
|
||||||
|
mapM (apply @c fn . List.singleton) rs
|
||||||
|
<&> mkList
|
||||||
|
|
||||||
|
[Lambda decl body, ListVal args] -> do
|
||||||
|
mapM (applyLambda decl body . List.singleton) args
|
||||||
|
<&> mkList
|
||||||
|
|
||||||
|
_ -> do
|
||||||
|
throwIO (BadFormException @C nil)
|
||||||
|
|
||||||
|
entry $ bindMatch "head" $ \case
|
||||||
|
[ ListVal es ] -> pure (head es)
|
||||||
|
_ -> throwIO (TypeCheckError @C nil)
|
||||||
|
|
||||||
|
brief "get tail of list"
|
||||||
|
$ args [arg "list" "list"]
|
||||||
|
$ desc "nil if the list is empty; error if not list"
|
||||||
|
$ examples [qc|
|
||||||
|
(tail [list 1 2 3])
|
||||||
|
(2 3)
|
||||||
|
(tail [list])
|
||||||
|
|]
|
||||||
|
$ entry $ bindMatch "tail" $ \case
|
||||||
|
[] -> pure nil
|
||||||
|
[ListVal []] -> pure nil
|
||||||
|
[ListVal es] -> pure $ mkList (tail es)
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
entry $ bindMatch "lookup" $ \case
|
||||||
|
[s, ListVal (SymbolVal "dict" : es) ] -> do
|
||||||
|
let val = headDef nil [ v | ListVal [k, v] <- es, k == s ]
|
||||||
|
pure val
|
||||||
|
|
||||||
|
[StringLike s, ListVal [] ] -> do
|
||||||
|
pure nil
|
||||||
|
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
brief "returns current unix time"
|
||||||
|
$ returns "int" "current unix time in seconds"
|
||||||
|
$ noArgs
|
||||||
|
$ entry $ bindMatch "now" $ \case
|
||||||
|
[] -> mkInt . round <$> liftIO getPOSIXTime
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
entry $ bindMatch "display" $ nil_ \case
|
||||||
|
[ sy ] -> display sy
|
||||||
|
ss -> display (mkList ss)
|
||||||
|
|
||||||
|
brief "prints new line character to stdout"
|
||||||
|
$ entry $ bindMatch "newline" $ nil_ $ \case
|
||||||
|
[] -> liftIO (putStrLn "")
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
brief "prints a list of terms to stdout"
|
||||||
|
$ entry $ bindMatch "print" $ nil_ $ \case
|
||||||
|
[ sy ] -> display sy
|
||||||
|
ss -> mapM_ display ss
|
||||||
|
|
||||||
|
entry $ bindMatch "println" $ nil_ $ \case
|
||||||
|
[ sy ] -> display sy >> liftIO (putStrLn "")
|
||||||
|
ss -> mapM_ display ss >> liftIO (putStrLn "")
|
||||||
|
|
||||||
|
entry $ bindMatch "str:read-stdin" $ \case
|
||||||
|
[] -> liftIO getContents <&> mkStr @c
|
||||||
|
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
entry $ bindMatch "str:put" $ nil_ $ \case
|
||||||
|
[LitStrVal s] -> liftIO $ TIO.putStr s
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
brief "reads file as a string" do
|
||||||
|
entry $ bindMatch "str:read-file" $ \case
|
||||||
|
[StringLike fn] -> liftIO (TIO.readFile fn) <&> mkStr
|
||||||
|
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
entry $ bindMatch "str:save" $ nil_ \case
|
||||||
|
[StringLike fn, StringLike what] ->
|
||||||
|
liftIO (writeFile fn what)
|
||||||
|
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
entry $ bindValue "space" $ mkStr " "
|
||||||
|
|
||||||
|
entry $ bindMatch "parse-top" $ \case
|
||||||
|
|
||||||
|
[SymbolVal w, LitStrVal s] -> do
|
||||||
|
pure $ parseTop s & either (const nil) (mkForm w . fmap fixContext)
|
||||||
|
|
||||||
|
[LitStrVal s] -> do
|
||||||
|
pure $ parseTop s & either (const nil) (mkList . fmap fixContext)
|
||||||
|
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
let atomFrom = \case
|
||||||
|
[StringLike s] -> pure (mkSym s)
|
||||||
|
[e] -> pure (mkSym $ show $ pretty e)
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
brief "type of argument"
|
||||||
|
$ args [arg "term" "term"]
|
||||||
|
$ returns "symbol" "type"
|
||||||
|
$ entry $ bindMatch "type" \case
|
||||||
|
[ListVal _] -> pure $ mkSym "list"
|
||||||
|
[SymbolVal _] -> pure $ mkSym "symbol"
|
||||||
|
[LitStrVal _] -> pure $ mkSym "string"
|
||||||
|
[LitIntVal _] -> pure $ mkSym "int"
|
||||||
|
[LitScientificVal _] -> pure $ mkSym "float"
|
||||||
|
[LitBoolVal _] -> pure $ mkSym "bool"
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
brief "creates a symbol from argument"
|
||||||
|
$ args [arg "any-term" "term"]
|
||||||
|
$ returns "symbol" ""
|
||||||
|
do
|
||||||
|
entry $ bindMatch "sym" atomFrom
|
||||||
|
entry $ bindMatch "atom" atomFrom
|
||||||
|
|
||||||
|
brief "compares two terms" $
|
||||||
|
args [arg "term" "a", arg "term" "b"] $
|
||||||
|
returns "boolean" "#t if terms are equal, otherwise #f" $
|
||||||
|
entry $ bindMatch "eq?" $ \case
|
||||||
|
[a, b] -> do
|
||||||
|
pure $ if a == b then mkBool True else mkBool False
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
entry $ bindMatch "length" $ \case
|
||||||
|
[ListVal es] -> pure $ mkInt (length es)
|
||||||
|
[StringLike es] -> pure $ mkInt (length es)
|
||||||
|
_ -> pure $ mkInt 0
|
||||||
|
|
||||||
|
entry $ bindMatch "nil?" $ \case
|
||||||
|
[ListVal []] -> pure $ mkBool True
|
||||||
|
_ -> pure $ mkBool False
|
||||||
|
|
||||||
|
entry $ bindMatch "not" $ \case
|
||||||
|
[w] -> do
|
||||||
|
pure $ if isFalse w then mkBool True else mkBool False
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
brief "get system environment"
|
||||||
|
$ args []
|
||||||
|
$ args [ arg "string" "string" ]
|
||||||
|
$ returns "env" "single var or dict of all vars"
|
||||||
|
$ examples [qc|
|
||||||
|
(env HOME)
|
||||||
|
/home/user
|
||||||
|
|
||||||
|
(env)
|
||||||
|
(dict
|
||||||
|
(HOME "/home/user") ... (CC "gcc") ...)
|
||||||
|
|]
|
||||||
|
$ entry $ bindMatch "env" $ \case
|
||||||
|
[] -> do
|
||||||
|
s <- liftIO getEnvironment
|
||||||
|
pure $ mkForm "dict" [ mkList [mkSym @c a, mkStr b] | (a,b) <- s ]
|
||||||
|
|
||||||
|
[StringLike s] -> do
|
||||||
|
liftIO (lookupEnv s)
|
||||||
|
<&> maybe nil mkStr
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
-- FIXME: we-need-opaque-type
|
||||||
|
entry $ bindMatch "blob:read-stdin" $ \case
|
||||||
|
[] -> do
|
||||||
|
blob <- liftIO BS8.getContents <&> BS8.unpack
|
||||||
|
pure (mkForm "blob" [mkStr @c blob])
|
||||||
|
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
entry $ bindMatch "blob:read-file" $ \case
|
||||||
|
[StringLike fn] -> do
|
||||||
|
blob <- liftIO (BS8.readFile fn) <&> BS8.unpack
|
||||||
|
pure (mkForm "blob" [mkStr @c blob])
|
||||||
|
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
entry $ bindMatch "blob:save" $ nil_ $ \case
|
||||||
|
[StringLike fn, ListVal [SymbolVal "blob", LitStrVal t]] -> do
|
||||||
|
let s = Text.unpack t & BS8.pack
|
||||||
|
liftIO $ BS8.writeFile fn s
|
||||||
|
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
entry $ bindMatch "blob:put" $ nil_ $ \case
|
||||||
|
[ListVal [SymbolVal "blob", LitStrVal t]] -> do
|
||||||
|
let s = Text.unpack t & BS8.pack
|
||||||
|
liftIO $ BS8.putStr s
|
||||||
|
|
||||||
|
_ -> throwIO (BadFormException @c nil)
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,211 @@
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
|
{-# Language ViewPatterns #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
module Data.Config.Suckless.Syntax
|
||||||
|
( Syntax(..)
|
||||||
|
, Id(..)
|
||||||
|
, Literal(..)
|
||||||
|
, HasContext
|
||||||
|
, C(..)
|
||||||
|
, Context(..)
|
||||||
|
, IsContext(..)
|
||||||
|
, IsLiteral(..)
|
||||||
|
, pattern SymbolVal
|
||||||
|
, pattern ListVal
|
||||||
|
, pattern LitIntVal
|
||||||
|
, pattern LitStrVal
|
||||||
|
, pattern LitBoolVal
|
||||||
|
, pattern LitScientificVal
|
||||||
|
, pattern StringLike
|
||||||
|
, pattern StringLikeList
|
||||||
|
, pattern Nil
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Data.Data
|
||||||
|
import Data.Kind
|
||||||
|
import Data.String
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Data.Scientific
|
||||||
|
import GHC.Generics (Generic(..))
|
||||||
|
import Data.Maybe
|
||||||
|
-- import GHC.Generics( Fixity(..) )
|
||||||
|
-- import Data.Data as Data
|
||||||
|
import Data.Aeson
|
||||||
|
import Data.Aeson.Key
|
||||||
|
import Data.Aeson.KeyMap qualified as Aeson
|
||||||
|
import Data.Vector qualified as V
|
||||||
|
import Data.Traversable (forM)
|
||||||
|
import Data.Text qualified as Text
|
||||||
|
import Data.Function
|
||||||
|
|
||||||
|
import Prettyprinter
|
||||||
|
|
||||||
|
pattern SymbolVal :: Id -> Syntax c
|
||||||
|
pattern SymbolVal v <- Symbol _ v
|
||||||
|
|
||||||
|
-- pattern LitVal :: forall {c}. Id -> Li
|
||||||
|
pattern LitIntVal :: Integer -> Syntax c
|
||||||
|
pattern LitIntVal v <- Literal _ (LitInt v)
|
||||||
|
|
||||||
|
pattern LitScientificVal :: Scientific -> Syntax c
|
||||||
|
pattern LitScientificVal v <- Literal _ (LitScientific v)
|
||||||
|
|
||||||
|
pattern LitStrVal :: Text -> Syntax c
|
||||||
|
pattern LitStrVal v <- Literal _ (LitStr v)
|
||||||
|
|
||||||
|
pattern LitBoolVal :: Bool -> Syntax c
|
||||||
|
pattern LitBoolVal v <- Literal _ (LitBool v)
|
||||||
|
|
||||||
|
pattern ListVal :: [Syntax c] -> Syntax c
|
||||||
|
pattern ListVal v <- List _ v
|
||||||
|
|
||||||
|
|
||||||
|
stringLike :: Syntax c -> Maybe String
|
||||||
|
stringLike = \case
|
||||||
|
LitStrVal s -> Just $ Text.unpack s
|
||||||
|
SymbolVal (Id s) -> Just $ Text.unpack s
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
stringLikeList :: [Syntax c] -> [String]
|
||||||
|
stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
|
||||||
|
|
||||||
|
|
||||||
|
pattern StringLike :: forall {c} . String -> Syntax c
|
||||||
|
pattern StringLike e <- (stringLike -> Just e)
|
||||||
|
|
||||||
|
pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
|
||||||
|
pattern StringLikeList e <- (stringLikeList -> e)
|
||||||
|
|
||||||
|
|
||||||
|
pattern Nil :: forall {c} . Syntax c
|
||||||
|
pattern Nil <- ListVal []
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
data family Context c :: Type
|
||||||
|
|
||||||
|
class IsContext c where
|
||||||
|
noContext :: Context c
|
||||||
|
|
||||||
|
data instance Context () = EmptyContext
|
||||||
|
|
||||||
|
instance IsContext () where
|
||||||
|
noContext = EmptyContext
|
||||||
|
|
||||||
|
class HasContext c a where
|
||||||
|
|
||||||
|
class IsLiteral a where
|
||||||
|
mkLit :: a -> Literal
|
||||||
|
|
||||||
|
newtype Id =
|
||||||
|
Id Text
|
||||||
|
deriving newtype (IsString,Pretty)
|
||||||
|
deriving stock (Data,Generic,Show,Eq,Ord)
|
||||||
|
|
||||||
|
data Literal =
|
||||||
|
LitStr Text
|
||||||
|
| LitInt Integer
|
||||||
|
| LitScientific Scientific
|
||||||
|
| LitBool Bool
|
||||||
|
deriving stock (Eq,Ord,Data,Generic,Show)
|
||||||
|
|
||||||
|
instance IsLiteral Text where
|
||||||
|
mkLit = LitStr
|
||||||
|
|
||||||
|
instance IsLiteral Bool where
|
||||||
|
mkLit = LitBool
|
||||||
|
|
||||||
|
instance IsLiteral Integer where
|
||||||
|
mkLit = LitInt
|
||||||
|
|
||||||
|
data C = C
|
||||||
|
deriving stock (Eq,Ord,Show,Data,Typeable,Generic)
|
||||||
|
|
||||||
|
-- simple, yet sufficient context
|
||||||
|
-- Integer may be offset, maybe line number,
|
||||||
|
-- token number, whatever
|
||||||
|
-- it's up to parser to use this context for
|
||||||
|
-- error printing, etc
|
||||||
|
newtype instance (Context C) =
|
||||||
|
SimpleContext { fromSimpleContext :: Maybe Integer }
|
||||||
|
deriving stock (Eq,Ord,Show,Data,Typeable,Generic)
|
||||||
|
|
||||||
|
instance IsContext C where
|
||||||
|
noContext = SimpleContext Nothing
|
||||||
|
|
||||||
|
data Syntax c
|
||||||
|
= List (Context c) [Syntax c]
|
||||||
|
| Symbol (Context c) Id
|
||||||
|
| Literal (Context c) Literal
|
||||||
|
deriving stock (Generic,Typeable)
|
||||||
|
|
||||||
|
|
||||||
|
instance Eq (Syntax c) where
|
||||||
|
(==) (Literal _ a) (Literal _ b) = a == b
|
||||||
|
(==) (Symbol _ a) (Symbol _ b) = a == b
|
||||||
|
(==) (List _ a) (List _ b) = a == b
|
||||||
|
(==) _ _ = False
|
||||||
|
|
||||||
|
deriving instance (Data c, Data (Context c)) => Data (Syntax c)
|
||||||
|
|
||||||
|
instance Pretty (Syntax c) where
|
||||||
|
pretty (Literal _ ast) = pretty ast
|
||||||
|
pretty (Symbol _ s) = pretty s
|
||||||
|
pretty (List _ (x:xs)) = parens $ align $ sep ( fmap pretty (x:xs) )
|
||||||
|
pretty (List _ []) = parens mempty
|
||||||
|
|
||||||
|
instance Pretty Literal where
|
||||||
|
pretty = \case
|
||||||
|
LitStr s -> dquotes (pretty s)
|
||||||
|
LitInt i -> pretty i
|
||||||
|
LitScientific v -> viaShow v
|
||||||
|
|
||||||
|
LitBool b | b -> "#t"
|
||||||
|
| otherwise -> "#f"
|
||||||
|
|
||||||
|
|
||||||
|
instance ToJSON Literal where
|
||||||
|
toJSON (LitStr s) = String s
|
||||||
|
toJSON (LitInt i) = Number (fromInteger i)
|
||||||
|
toJSON (LitScientific s) = Number s
|
||||||
|
toJSON (LitBool b) = Bool b
|
||||||
|
|
||||||
|
instance ToJSON (Syntax c) where
|
||||||
|
toJSON (Symbol _ (Id "#nil")) = Null
|
||||||
|
toJSON (Symbol _ (Id s)) = String s
|
||||||
|
toJSON (Literal _ l) = toJSON l
|
||||||
|
toJSON (List _ items) =
|
||||||
|
case items of
|
||||||
|
(Symbol _ "object" : rest) ->
|
||||||
|
object $ mapMaybe pairToKeyValue rest
|
||||||
|
_ -> Array . V.fromList $ fmap toJSON items
|
||||||
|
|
||||||
|
where
|
||||||
|
pairToKeyValue :: Syntax c -> Maybe (Key, Value)
|
||||||
|
pairToKeyValue (List _ [SymbolVal (Id k), SymbolVal ":", v]) = Just (fromText k .= toJSON v)
|
||||||
|
pairToKeyValue (List _ [LitStrVal k, SymbolVal ":", v]) = Just (fromText k .= toJSON v)
|
||||||
|
pairToKeyValue _ = Nothing
|
||||||
|
|
||||||
|
|
||||||
|
instance IsContext c => FromJSON (Syntax c) where
|
||||||
|
parseJSON (String t) = pure $ Literal noContext (LitStr t)
|
||||||
|
parseJSON (Number n)
|
||||||
|
| isInteger n = pure $ Literal noContext (LitInt (floor n))
|
||||||
|
| otherwise = pure $ Literal noContext (LitScientific n)
|
||||||
|
parseJSON (Bool b) = pure $ Literal noContext (LitBool b)
|
||||||
|
parseJSON (Array a) = List noContext <$> mapM parseJSON (V.toList a)
|
||||||
|
parseJSON (Object o) = do
|
||||||
|
pairs <- forM (Aeson.toList o) $ \(key, value) -> do
|
||||||
|
valueSyntax <- parseJSON value
|
||||||
|
pure $ List noContext [ Symbol noContext (Id (toText key))
|
||||||
|
, Symbol noContext ":"
|
||||||
|
, valueSyntax
|
||||||
|
]
|
||||||
|
pure $ List noContext (Symbol noContext (Id "object") : pairs)
|
||||||
|
parseJSON _ = fail "Cannot parse JSON to Syntax"
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
module Data.Config.Suckless.Types where
|
||||||
|
|
@ -0,0 +1,143 @@
|
||||||
|
cabal-version: 3.0
|
||||||
|
name: suckless-conf
|
||||||
|
version: 0.1.2.9
|
||||||
|
-- synopsis:
|
||||||
|
-- description:
|
||||||
|
license: BSD-3-Clause
|
||||||
|
license-file: LICENSE
|
||||||
|
author: Dmitry Zuikov
|
||||||
|
maintainer: dzuikov@gmail.com
|
||||||
|
-- copyright:
|
||||||
|
category: Text
|
||||||
|
build-type: Simple
|
||||||
|
extra-doc-files: CHANGELOG.md
|
||||||
|
-- extra-source-files:
|
||||||
|
|
||||||
|
common shared-properties
|
||||||
|
ghc-options:
|
||||||
|
-Wall
|
||||||
|
-- -fno-warn-unused-matches
|
||||||
|
-- -fno-warn-unused-do-bind
|
||||||
|
-- -Werror=missing-methods
|
||||||
|
-- -Werror=incomplete-patterns
|
||||||
|
-- -fno-warn-unused-binds
|
||||||
|
-- -threaded
|
||||||
|
-- -rtsopts
|
||||||
|
-- "-with-rtsopts=-N4 -A64m -AL256m -I0"
|
||||||
|
|
||||||
|
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
default-extensions:
|
||||||
|
ApplicativeDo
|
||||||
|
, BangPatterns
|
||||||
|
, BlockArguments
|
||||||
|
, ConstraintKinds
|
||||||
|
, DataKinds
|
||||||
|
, DeriveDataTypeable
|
||||||
|
, DeriveGeneric
|
||||||
|
, DerivingStrategies
|
||||||
|
, DerivingVia
|
||||||
|
, ExtendedDefaultRules
|
||||||
|
, FlexibleContexts
|
||||||
|
, FlexibleInstances
|
||||||
|
, GADTs
|
||||||
|
, GeneralizedNewtypeDeriving
|
||||||
|
, ImportQualifiedPost
|
||||||
|
, LambdaCase
|
||||||
|
, MultiParamTypeClasses
|
||||||
|
, OverloadedStrings
|
||||||
|
, QuasiQuotes
|
||||||
|
, ScopedTypeVariables
|
||||||
|
, StandaloneDeriving
|
||||||
|
, TupleSections
|
||||||
|
, TypeApplications
|
||||||
|
, TypeFamilies
|
||||||
|
, ImportQualifiedPost
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
library
|
||||||
|
import: shared-properties
|
||||||
|
|
||||||
|
exposed-modules:
|
||||||
|
Data.Config.Suckless
|
||||||
|
, Data.Config.Suckless.Syntax
|
||||||
|
, Data.Config.Suckless.Parse
|
||||||
|
, Data.Config.Suckless.KeyValue
|
||||||
|
, Data.Config.Suckless.Script
|
||||||
|
, Data.Config.Suckless.Script.File
|
||||||
|
|
||||||
|
other-modules:
|
||||||
|
Data.Config.Suckless.Types
|
||||||
|
, Data.Config.Suckless.Parse.Fuzzy
|
||||||
|
, Data.Config.Suckless.Script.Internal
|
||||||
|
|
||||||
|
-- other-extensions:
|
||||||
|
build-depends: base
|
||||||
|
, aeson
|
||||||
|
, bytestring
|
||||||
|
, containers
|
||||||
|
, directory
|
||||||
|
, filepath
|
||||||
|
, filepattern
|
||||||
|
, fuzzy-parse >= 0.1.3.1
|
||||||
|
, hashable
|
||||||
|
, interpolatedstring-perl6
|
||||||
|
, microlens-platform
|
||||||
|
, mtl
|
||||||
|
, prettyprinter
|
||||||
|
, prettyprinter-ansi-terminal
|
||||||
|
, safe
|
||||||
|
, scientific
|
||||||
|
, streaming
|
||||||
|
, stm
|
||||||
|
, text
|
||||||
|
, time
|
||||||
|
, transformers
|
||||||
|
, unliftio
|
||||||
|
, unordered-containers
|
||||||
|
, vector
|
||||||
|
|
||||||
|
hs-source-dirs: lib
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
test-suite spec
|
||||||
|
import: shared-properties
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Spec.hs
|
||||||
|
other-modules:
|
||||||
|
Data.Config.Suckless.KeyValueSpec
|
||||||
|
Data.Config.Suckless.AesonSpec
|
||||||
|
|
||||||
|
hs-source-dirs:
|
||||||
|
test
|
||||||
|
ghc-options:
|
||||||
|
-Wall
|
||||||
|
-threaded
|
||||||
|
-rtsopts
|
||||||
|
-with-rtsopts=-N
|
||||||
|
build-tool-depends:
|
||||||
|
hspec-discover:hspec-discover
|
||||||
|
build-depends: base
|
||||||
|
, hspec
|
||||||
|
, aeson
|
||||||
|
, scientific
|
||||||
|
, suckless-conf
|
||||||
|
, fuzzy-parse >= 0.1.3.1
|
||||||
|
, containers
|
||||||
|
, mtl
|
||||||
|
, text
|
||||||
|
, prettyprinter
|
||||||
|
, interpolatedstring-perl6
|
||||||
|
, tasty-hunit
|
||||||
|
|
||||||
|
default-language: Haskell2010
|
||||||
|
default-extensions:
|
||||||
|
DerivingStrategies
|
||||||
|
, FlexibleInstances
|
||||||
|
, MultiParamTypeClasses
|
||||||
|
, OverloadedStrings
|
||||||
|
, ScopedTypeVariables
|
||||||
|
, TypeApplications
|
||||||
|
|
||||||
|
|
@ -0,0 +1,23 @@
|
||||||
|
|
||||||
|
;; fixme config file
|
||||||
|
|
||||||
|
fixme-comments // # --
|
||||||
|
|
||||||
|
fixme-prefix FIXME: bugs issues
|
||||||
|
fixme-prefix TODO: bugs issues
|
||||||
|
|
||||||
|
fixme-files **/*.hs
|
||||||
|
|
||||||
|
fixme-files doc/devlog
|
||||||
|
|
||||||
|
fixme-files-ignore .direnv/** dist-newstyle/**
|
||||||
|
|
||||||
|
fixme-id-show-len 10
|
||||||
|
|
||||||
|
; fixme-tag-prefix #
|
||||||
|
|
||||||
|
fixme-list-full-row-pref "## "
|
||||||
|
fixme-list-full-row-suff "\n\n;;;"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,4 @@
|
||||||
|
; fixme log file
|
||||||
|
|
||||||
|
fixme-merged BbjfCj H4epFBNr2i
|
||||||
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
; blah-blah
|
||||||
|
|
@ -0,0 +1,34 @@
|
||||||
|
; comment
|
||||||
|
foo "a"
|
||||||
|
bar "a"
|
||||||
|
bar "b"
|
||||||
|
|
||||||
|
int1 122
|
||||||
|
int2 0
|
||||||
|
int3 -22
|
||||||
|
int4 0xFAFA
|
||||||
|
int5 0b11111111
|
||||||
|
int6 -0xFAFA
|
||||||
|
|
||||||
|
(jopa-kita)
|
||||||
|
|
||||||
|
(sci1 1e9)
|
||||||
|
(sci2 0.003)
|
||||||
|
(sci3 -0.001)
|
||||||
|
(sci4 -2e11)
|
||||||
|
(sci5 -2e-3)
|
||||||
|
|
||||||
|
(wtf1 .001)
|
||||||
|
|
||||||
|
some-object {object ( key : 42) }
|
||||||
|
|
||||||
|
{another-object
|
||||||
|
(object
|
||||||
|
( key1 : 42 )
|
||||||
|
( key2 : #f )
|
||||||
|
( key3 : [ 1 2 3 4 ] )
|
||||||
|
)
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,212 @@
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE KindSignatures #-}
|
||||||
|
|
||||||
|
|
||||||
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
|
module Data.Config.Suckless.AesonSpec (spec) where
|
||||||
|
|
||||||
|
import Data.Config.Suckless.KeyValue
|
||||||
|
import Data.Config.Suckless.Parse
|
||||||
|
import Data.Config.Suckless.Syntax
|
||||||
|
import Data.Functor
|
||||||
|
import Data.Function
|
||||||
|
import Data.Scientific
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Data.Text.IO qualified as Text
|
||||||
|
|
||||||
|
import GHC.Generics hiding (C)
|
||||||
|
import Text.InterpolatedString.Perl6 (qc,q)
|
||||||
|
import Data.Aeson
|
||||||
|
import Data.Maybe
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import Test.Hspec
|
||||||
|
import Test.Tasty.HUnit
|
||||||
|
import Prettyprinter
|
||||||
|
|
||||||
|
|
||||||
|
readConfig :: Text -> IO [Syntax C]
|
||||||
|
readConfig s = do
|
||||||
|
pure $ parseTop s & either mempty id
|
||||||
|
-- print $ pretty f
|
||||||
|
-- pure f
|
||||||
|
|
||||||
|
data SomeData =
|
||||||
|
SomeData
|
||||||
|
{ someDataKey1 :: Int
|
||||||
|
, someDataKey2 :: String
|
||||||
|
, someDataKey3 :: [Scientific]
|
||||||
|
}
|
||||||
|
deriving stock (Generic,Show,Eq)
|
||||||
|
|
||||||
|
instance ToJSON SomeData
|
||||||
|
instance FromJSON SomeData
|
||||||
|
|
||||||
|
data Port
|
||||||
|
data Users
|
||||||
|
|
||||||
|
instance HasCfgKey Port (Maybe Int)
|
||||||
|
where key = "port"
|
||||||
|
|
||||||
|
instance HasCfgKey Users [Value]
|
||||||
|
where key = "basic-users"
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
describe "toJSON" $ do
|
||||||
|
|
||||||
|
it "reads int" $ do
|
||||||
|
c <- readConfig [qc|1|] <&> toJSON
|
||||||
|
c `shouldBe` toJSON [[1::Int]]
|
||||||
|
|
||||||
|
it "reads scientific" $ do
|
||||||
|
c <- readConfig [qc|1.00|] <&> toJSON
|
||||||
|
c `shouldBe` toJSON [[1.00 :: Scientific]]
|
||||||
|
|
||||||
|
it "reads bool" $ do
|
||||||
|
t <- readConfig [qc|#t|] <&> toJSON . head
|
||||||
|
t `shouldBe` toJSON [Bool True]
|
||||||
|
f <- readConfig [qc|#f|] <&> toJSON . head
|
||||||
|
f `shouldBe` toJSON [Bool False]
|
||||||
|
|
||||||
|
it "reads string" $ do
|
||||||
|
s <- readConfig [qc|"somestring"|] <&> toJSON
|
||||||
|
s `shouldBe` toJSON [["somestring" :: String]]
|
||||||
|
|
||||||
|
it "reads array" $ do
|
||||||
|
s <- readConfig [qc|(1 2 3 4)|] <&> toJSON . head
|
||||||
|
print s
|
||||||
|
s `shouldBe` toJSON [1::Int,2,3,4]
|
||||||
|
|
||||||
|
it "reads simple object" $ do
|
||||||
|
s <- readConfig [qc|
|
||||||
|
(object
|
||||||
|
(key1 : 22)
|
||||||
|
(key2 : #f)
|
||||||
|
(key3 : [1 2 3 4])
|
||||||
|
(key4 : (object (o1 : "bebe")) )
|
||||||
|
("fafa" : "fifa")
|
||||||
|
(none : #nil)
|
||||||
|
)
|
||||||
|
|] <&> toJSON . head
|
||||||
|
|
||||||
|
let s1 = decode @Value [q|
|
||||||
|
{
|
||||||
|
"key1": 22,
|
||||||
|
"key2": false,
|
||||||
|
"key3": [1, 2, 3, 4],
|
||||||
|
"key4": {
|
||||||
|
"o1": "bebe"
|
||||||
|
},
|
||||||
|
"fafa" : "fifa",
|
||||||
|
"none" : null
|
||||||
|
}
|
||||||
|
|
||||||
|
|]
|
||||||
|
|
||||||
|
print s
|
||||||
|
print s1
|
||||||
|
Just s `shouldBe` s1
|
||||||
|
|
||||||
|
|
||||||
|
it "serializes object to syntax" $ do
|
||||||
|
let some = SomeData 1 "some-data" [1, 2, 3, 4, 5, 10]
|
||||||
|
|
||||||
|
let someSyn = case fromJSON @(Syntax ()) (toJSON some) of
|
||||||
|
Success syn -> Just syn
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
print $ pretty someSyn
|
||||||
|
|
||||||
|
let json = fromJust $ someSyn <&> toJSON
|
||||||
|
|
||||||
|
let someObject = fromJSON @SomeData json
|
||||||
|
|
||||||
|
print someObject
|
||||||
|
someObject `shouldBe` Success some
|
||||||
|
|
||||||
|
it "read-real-config" do
|
||||||
|
let cfg = [q|
|
||||||
|
|
||||||
|
port 3000
|
||||||
|
|
||||||
|
hbs2-url "http://localhost:5001"
|
||||||
|
|
||||||
|
default-token-name "LCOIN"
|
||||||
|
|
||||||
|
hbs2-keyring "/home/hbs2/lcoin-adapter/secrets/hbs2.key"
|
||||||
|
|
||||||
|
; old test thermoland reflog
|
||||||
|
hbs2-keyring "/home/hbs2/lcoin-adapter/secrets/termoland-reflog-GX8gmPi2cAxxgnaKmLmR5iViup1BNkwpdCCub3snLT1y.key"
|
||||||
|
|
||||||
|
; new test thermoland reflog
|
||||||
|
hbs2-keyring "/home/hbs2/lcoin-adapter/secrets/termoland-reflog-AdowWzo4iW1JejHFRnPnxQWNot8uL5sciFup6RHx2gZG.key"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
hbs2-keyring "/home/hbs2/keys/lcoin-belorusskaya-JAiAjKzfWfTGXjuSf4GXaj44cWfDQ8vifxoQU3tq5hn7.key"
|
||||||
|
hbs2-keyring "/home/hbs2/keys/lcoin-krymskaya-CEDBX2niVK3YL7WxzLR3xj8iUNHa9GU2EfXUqDU7fSGK.key"
|
||||||
|
hbs2-keyring "/home/hbs2/keys/lcoin-ushakova-GyTXGiCUJu81CMXYZzs7RhHu4vxJnLYgT3n2neXG5uaY.key"
|
||||||
|
hbs2-keyring "/home/hbs2/keys/lcoin-zelenopark-4fFvFGzQRp2WSXtDHepeJvMtCfQdSASq9qmsELWRJDgv.key"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
jwk-path "/home/hbs2/lcoin-adapter/secrets/jwk/public_key.jwk"
|
||||||
|
|
||||||
|
jwk-path "/home/hbs2/lcoin-adapter/secrets/jwk/public-key-2023-11-03.jwk"
|
||||||
|
|
||||||
|
lcoin-rate 5
|
||||||
|
|
||||||
|
db-path "/home/hbs2/.local/share/lcoin-adapter/state.db"
|
||||||
|
|
||||||
|
registration-bonus 500
|
||||||
|
|
||||||
|
log-file "/home/hbs2/lcoin-adapter/log.txt"
|
||||||
|
|
||||||
|
; qblf-socket "/tmp/qblf.socket"
|
||||||
|
|
||||||
|
qblf-treasure "64zvWqGUf57WmGCTFWrVaNEqXikUocGyKFtg5mhyWCiB"
|
||||||
|
|
||||||
|
reports-ignore-key "DyKWNLvpRSsTsJfVxTciqxnCJ6UhF4Mf6WoMw5qkftG4"
|
||||||
|
reports-ignore-key "3MjGvpffawUijHxbbsaF9J6wt4YReRdArUCTfHo1RhSm"
|
||||||
|
|
||||||
|
|
||||||
|
;; v2
|
||||||
|
db-journal "/tmp/lcoin-adapter-journal.sqlite"
|
||||||
|
db-cache "/tmp/lcoin-adapter-cache-db.sqlite"
|
||||||
|
hbs2-store "/tmp/hbs2-store"
|
||||||
|
|
||||||
|
treasure "64zvWqGUf57WmGCTFWrVaNEqXikUocGyKFtg5mhyWCiB"
|
||||||
|
|
||||||
|
keybox "http://localhost:8034/"
|
||||||
|
dev-env false
|
||||||
|
(jwk-keys (
|
||||||
|
"/home/hbs2/lcoin-adapter/secrets/jwk/public_key.jwk"
|
||||||
|
"/home/hbs2/lcoin-adapter/secrets/jwk/public-key-2023-11-03.jwk"
|
||||||
|
))
|
||||||
|
|
||||||
|
(basic-users (
|
||||||
|
(object (name "mobile") (pass "mobile-pass"))
|
||||||
|
(object (name "termo") (pass "termo-pass"))
|
||||||
|
))
|
||||||
|
|
||||||
|
(client-creator "BYVqWJdn18Q3AjmJBPw2yusZ5ouNmgiRydWQgBEh684J")
|
||||||
|
(client-creator-keyring "/home/hbs2/keys/journal/client-creator_BYVqWJdn18Q3AjmJBPw2yusZ5ouNmgiRydWQgBEh684J.key")
|
||||||
|
|
||||||
|
(coin-minter "4Gnno5yXUbT5dwfphKtDW7dWeq4uBvassSdbVvB3y67p")
|
||||||
|
(coin-minter-keyring "/home/hbs2/keys/journal/coin-minter_4Gnno5yXUbT5dwfphKtDW7dWeq4uBvassSdbVvB3y67p.key")
|
||||||
|
|] :: Text
|
||||||
|
|
||||||
|
|
||||||
|
let what = parseTop cfg & either (error.show) id
|
||||||
|
|
||||||
|
let pno = runReader (cfgValue @Port @(Maybe Int)) what
|
||||||
|
-- what
|
||||||
|
|
||||||
|
assertEqual "pno" pno (Just 3000)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,184 @@
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
|
|
||||||
|
module Data.Config.Suckless.KeyValueSpec (spec) where
|
||||||
|
|
||||||
|
import Data.Function
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import Data.Config.Suckless.KeyValue
|
||||||
|
import Data.Config.Suckless.Parse
|
||||||
|
import Data.Config.Suckless.Syntax
|
||||||
|
import Data.Functor
|
||||||
|
import Data.Scientific
|
||||||
|
import Data.Text.IO qualified as Text
|
||||||
|
import Data.Set (Set)
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import Prettyprinter
|
||||||
|
import Data.Aeson
|
||||||
|
import Text.InterpolatedString.Perl6 (qc,q)
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
|
|
||||||
|
data FirstKey
|
||||||
|
|
||||||
|
data SecondKey
|
||||||
|
|
||||||
|
data ThirdKey
|
||||||
|
|
||||||
|
data Int1
|
||||||
|
data Int2
|
||||||
|
data Int3
|
||||||
|
data Int4
|
||||||
|
data Int5
|
||||||
|
data Int6
|
||||||
|
|
||||||
|
data Sci1
|
||||||
|
data Sci2
|
||||||
|
data Sci3
|
||||||
|
data Sci4
|
||||||
|
data Sci5
|
||||||
|
|
||||||
|
data O1
|
||||||
|
data O2
|
||||||
|
|
||||||
|
instance HasCfgKey FirstKey (Maybe String) where
|
||||||
|
key = "foo"
|
||||||
|
|
||||||
|
instance HasCfgKey SecondKey (Set String) where
|
||||||
|
key = "bar"
|
||||||
|
|
||||||
|
instance HasCfgKey ThirdKey (Maybe String) where
|
||||||
|
key = "baz"
|
||||||
|
|
||||||
|
instance HasCfgKey Int1 b where
|
||||||
|
key = "int1"
|
||||||
|
|
||||||
|
instance HasCfgKey Int2 b where
|
||||||
|
key = "int2"
|
||||||
|
|
||||||
|
instance HasCfgKey Int3 b where
|
||||||
|
key = "int3"
|
||||||
|
|
||||||
|
instance HasCfgKey Int4 b where
|
||||||
|
key = "int4"
|
||||||
|
|
||||||
|
instance HasCfgKey Int5 b where
|
||||||
|
key = "int5"
|
||||||
|
|
||||||
|
instance HasCfgKey Int6 b where
|
||||||
|
key = "int6"
|
||||||
|
|
||||||
|
instance HasCfgKey Sci1 b where
|
||||||
|
key = "sci1"
|
||||||
|
|
||||||
|
instance HasCfgKey Sci2 b where
|
||||||
|
key = "sci2"
|
||||||
|
|
||||||
|
instance HasCfgKey Sci3 b where
|
||||||
|
key = "sci3"
|
||||||
|
|
||||||
|
instance HasCfgKey Sci4 b where
|
||||||
|
key = "sci4"
|
||||||
|
|
||||||
|
instance HasCfgKey Sci5 b where
|
||||||
|
key = "sci5"
|
||||||
|
|
||||||
|
instance HasCfgKey O1 b where
|
||||||
|
key = "some-object"
|
||||||
|
|
||||||
|
instance HasCfgKey O2 b where
|
||||||
|
key = "another-object"
|
||||||
|
|
||||||
|
instance HasConf IO where
|
||||||
|
getConf = liftIO readConfig
|
||||||
|
|
||||||
|
readConfig :: IO [Syntax C]
|
||||||
|
readConfig = do
|
||||||
|
let configFilePath = "t/key-value-test-config"
|
||||||
|
f <- Text.readFile configFilePath <&> parseTop <&> either mempty id
|
||||||
|
print $ pretty f
|
||||||
|
pure f
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
describe "config parsing" $ do
|
||||||
|
|
||||||
|
it "reads string" $ do
|
||||||
|
firstValue <- cfgValue @FirstKey @(Maybe String)
|
||||||
|
firstValue `shouldBe` Just "a"
|
||||||
|
|
||||||
|
it "reads a set of strings" $ do
|
||||||
|
secondValue <- cfgValue @SecondKey @(Set String)
|
||||||
|
secondValue `shouldBe` Set.fromList ["a", "b"]
|
||||||
|
|
||||||
|
it "reads nothing" $ do
|
||||||
|
thridValue <- cfgValue @ThirdKey @(Maybe String)
|
||||||
|
thridValue `shouldBe` Nothing
|
||||||
|
|
||||||
|
it "reads ints" $ do
|
||||||
|
x1 <- cfgValue @Int1 @(Maybe Integer)
|
||||||
|
x1 `shouldBe` Just 122
|
||||||
|
|
||||||
|
x2 <- cfgValue @Int2
|
||||||
|
x2 `shouldBe` Just (0 :: Integer)
|
||||||
|
|
||||||
|
x3 <- cfgValue @Int3
|
||||||
|
x3 `shouldBe` Just (-22 :: Integer)
|
||||||
|
|
||||||
|
x4 <- cfgValue @Int4 @(Maybe Integer)
|
||||||
|
x4 `shouldBe` Just 0xFAFA
|
||||||
|
|
||||||
|
x5 <- cfgValue @Int5 @(Maybe Integer)
|
||||||
|
x5 `shouldBe` Just 255
|
||||||
|
|
||||||
|
x6 <- cfgValue @Int6 @(Maybe Integer)
|
||||||
|
x6 `shouldBe` Just (-0xFAFA)
|
||||||
|
|
||||||
|
it "reads scientifics" $ do
|
||||||
|
x1 <- cfgValue @Sci1 @(Maybe Scientific)
|
||||||
|
x1 `shouldBe` Just 1e9
|
||||||
|
|
||||||
|
x2 <- cfgValue @Sci2 @(Maybe Scientific)
|
||||||
|
x2 `shouldBe` Just 0.003
|
||||||
|
|
||||||
|
-- x3 <- cfgValue @Sci3 @(Maybe Scientific)
|
||||||
|
-- x3 `shouldBe` Just (-0.001)
|
||||||
|
|
||||||
|
x4 <- cfgValue @Sci4 @(Maybe Scientific)
|
||||||
|
x4 `shouldBe` Just (-2e11)
|
||||||
|
|
||||||
|
x5 <- cfgValue @Sci5 @(Maybe Scientific)
|
||||||
|
x5 `shouldBe` Just (-2e-3)
|
||||||
|
|
||||||
|
it "reads objects" $ do
|
||||||
|
o1 <- cfgValue @O1 @(Maybe Value)
|
||||||
|
let wtf1 = [q|{ "key" : 42 }|]
|
||||||
|
o1 `shouldBe` decode wtf1
|
||||||
|
let wtf2 = [q|
|
||||||
|
{ "key1" : 42
|
||||||
|
, "key2" : false
|
||||||
|
, "key3" : [ 1, 2, 3, 4]
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
o2 <- cfgValue @O2 @(Maybe Value)
|
||||||
|
o2 `shouldBe` decode wtf2
|
||||||
|
|
||||||
|
|
||||||
|
it "works in Reader" $ do
|
||||||
|
|
||||||
|
let cfg = [qc|
|
||||||
|
int1 123
|
||||||
|
|
||||||
|
|]
|
||||||
|
let conf = parseTop cfg & either mempty id
|
||||||
|
|
||||||
|
let v = runReader (cfgValue @Int1 @(Maybe Int)) conf
|
||||||
|
|
||||||
|
v `shouldBe` Just 123
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||||
Loading…
Reference in New Issue