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