mirror of https://github.com/voidlizard/hbs2
Squashed 'miscellaneous/fuzzy-parse/' content from commit a834b152e
git-subtree-dir: miscellaneous/fuzzy-parse git-subtree-split: a834b152e29d632c816eefe117036e5d9330bd03
This commit is contained in:
voidlizard
commit
cf85d2df2a
|
|
@ -0,0 +1,5 @@
|
||||||
|
if [ -f .envrc.local ]; then
|
||||||
|
source_env .envrc.local
|
||||||
|
fi
|
||||||
|
|
||||||
|
use flake
|
||||||
|
|
@ -0,0 +1,6 @@
|
||||||
|
*.swp
|
||||||
|
dist-newstyle/
|
||||||
|
Setup.hs
|
||||||
|
|
||||||
|
.direnv
|
||||||
|
.hbs2-git/
|
||||||
|
|
@ -0,0 +1,10 @@
|
||||||
|
# Revision history for fuzzy-parse
|
||||||
|
|
||||||
|
## 0.1.2.0
|
||||||
|
|
||||||
|
- Techical release
|
||||||
|
- Added some missed things
|
||||||
|
|
||||||
|
## 0.1.0.0 -- YYYY-mm-dd
|
||||||
|
|
||||||
|
* First version. Released on an unsuspecting world.
|
||||||
|
|
@ -0,0 +1,20 @@
|
||||||
|
Copyright (c) 2019 Dmitry Zuikov
|
||||||
|
|
||||||
|
Permission is hereby granted, free of charge, to any person obtaining
|
||||||
|
a copy of this software and associated documentation files (the
|
||||||
|
"Software"), to deal in the Software without restriction, including
|
||||||
|
without limitation the rights to use, copy, modify, merge, publish,
|
||||||
|
distribute, sublicense, and/or sell copies of the Software, and to
|
||||||
|
permit persons to whom the Software is furnished to do so, subject to
|
||||||
|
the following conditions:
|
||||||
|
|
||||||
|
The above copyright notice and this permission notice shall be included
|
||||||
|
in all copies or substantial portions of the Software.
|
||||||
|
|
||||||
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||||
|
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||||
|
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
|
||||||
|
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||||
|
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
|
||||||
|
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
|
||||||
|
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
||||||
|
|
@ -0,0 +1,131 @@
|
||||||
|
# About
|
||||||
|
|
||||||
|
# Data.Text.Fuzzy.Tokenize
|
||||||
|
|
||||||
|
The lightweight and multi-functional text tokenizer allowing different types of text tokenization
|
||||||
|
depending on it's settings.
|
||||||
|
|
||||||
|
It may be used in different sutiations, for DSL, text markups or even for parsing simple grammars
|
||||||
|
easier and sometimes faster than in case of usage mainstream parsing combinators or parser
|
||||||
|
generators.
|
||||||
|
|
||||||
|
The primary goal of this package is to parse unstructured text data, however it may be used for
|
||||||
|
parsing such data formats as CSV with ease.
|
||||||
|
|
||||||
|
Currently it supports the following types of entities: atoms, string literals (currently with the
|
||||||
|
minimal set of escaped characters), punctuation characters and delimeters.
|
||||||
|
|
||||||
|
## Examples
|
||||||
|
|
||||||
|
### Simple CSV-like tokenization
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
tokenize (delims ":") "aaa : bebeb : qqq ::::" :: [Text]
|
||||||
|
|
||||||
|
["aaa "," bebeb "," qqq "]
|
||||||
|
```
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
tokenize (delims ":"<>sq<>emptyFields ) "aaa : bebeb : qqq ::::" :: [Text]
|
||||||
|
|
||||||
|
["aaa "," bebeb "," qqq ","","","",""]
|
||||||
|
```
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
tokenize (delims ":"<>sq<>emptyFields ) "aaa : bebeb : qqq ::::" :: [Maybe Text]
|
||||||
|
|
||||||
|
[Just "aaa ",Just " bebeb ",Just " qqq ",Nothing,Nothing,Nothing,Nothing]
|
||||||
|
```
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
tokenize (delims ":"<>sq<>emptyFields ) "aaa : 'bebeb:colon inside' : qqq ::::" :: [Maybe Text]
|
||||||
|
|
||||||
|
[Just "aaa ",Just " ",Just "bebeb:colon inside",Just " ",Just " qqq ",Nothing,Nothing,Nothing,Nothing]
|
||||||
|
```
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
let spec = sl<>delims ":"<>sq<>emptyFields<>noslits
|
||||||
|
tokenize spec " aaa : 'bebeb:colon inside' : qqq ::::" :: [Maybe Text]
|
||||||
|
|
||||||
|
[Just "aaa ",Just "bebeb:colon inside ",Just "qqq ",Nothing,Nothing,Nothing,Nothing]
|
||||||
|
```
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
let spec = delims ":"<>sq<>emptyFields<>uw<>noslits
|
||||||
|
tokenize spec " a b c : 'bebeb:colon inside' : qqq ::::" :: [Maybe Text]
|
||||||
|
|
||||||
|
[Just "a b c",Just "bebeb:colon inside",Just "qqq",Nothing,Nothing,Nothing,Nothing]
|
||||||
|
```
|
||||||
|
|
||||||
|
### Primitive lisp-like language
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
{-# LANGUAGE QuasiQuotes, ExtendedDefaultRules #-}
|
||||||
|
|
||||||
|
import Text.InterpolatedString.Perl6 (q)
|
||||||
|
import Data.Text.Fuzzy.Tokenize
|
||||||
|
|
||||||
|
data TTok = TChar Char
|
||||||
|
| TSChar Char
|
||||||
|
| TPunct Char
|
||||||
|
| TText Text
|
||||||
|
| TStrLit Text
|
||||||
|
| TKeyword Text
|
||||||
|
| TEmpty
|
||||||
|
deriving(Eq,Ord,Show)
|
||||||
|
|
||||||
|
instance IsToken TTok where
|
||||||
|
mkChar = TChar
|
||||||
|
mkSChar = TSChar
|
||||||
|
mkPunct = TPunct
|
||||||
|
mkText = TText
|
||||||
|
mkStrLit = TStrLit
|
||||||
|
mkKeyword = TKeyword
|
||||||
|
mkEmpty = TEmpty
|
||||||
|
|
||||||
|
main = do
|
||||||
|
|
||||||
|
let spec = delims " \n\t" <> comment ";"
|
||||||
|
<> punct "{}()[]<>"
|
||||||
|
<> sq <> sqq
|
||||||
|
<> uw
|
||||||
|
<> keywords ["define","apply","+"]
|
||||||
|
let code = [q|
|
||||||
|
(define add (a b ) ; define simple function
|
||||||
|
(+ a b) )
|
||||||
|
(define r (add 10 20))
|
||||||
|
|]
|
||||||
|
let toks = tokenize spec code :: [TTok]
|
||||||
|
|
||||||
|
print toks
|
||||||
|
```
|
||||||
|
|
||||||
|
## Notes
|
||||||
|
|
||||||
|
### About the delimeter tokens
|
||||||
|
This type of tokens appears during a "delimited" formats processing and disappears in results.
|
||||||
|
Currenly you will never see it unless normalization is turned off by 'nn' option.
|
||||||
|
|
||||||
|
The delimeters make sense in case of processing the CSV-like formats, but in this case you probably
|
||||||
|
need only values in results.
|
||||||
|
|
||||||
|
This behavior may be changed later. But right now delimeters seem pointless in results. If you
|
||||||
|
process some sort of grammar where delimeter character is important, you may use punctuation
|
||||||
|
instead, i.e:
|
||||||
|
|
||||||
|
```haskell
|
||||||
|
let spec = delims " \t"<>punct ",;()" <>emptyFields<>sq
|
||||||
|
tokenize spec "( delimeters , are , important, 'spaces are not');" :: [Text]
|
||||||
|
|
||||||
|
["(","delimeters",",","are",",","important",",","spaces are not",")",";"]
|
||||||
|
```
|
||||||
|
|
||||||
|
### Other
|
||||||
|
For CSV-like formats it makes sense to split text to lines first, otherwise newline characters may
|
||||||
|
cause to weird results
|
||||||
|
|
||||||
|
|
||||||
|
# Authors
|
||||||
|
|
||||||
|
This library is written and maintained by Dmitry Zuikov, dzuikov@gmail.com
|
||||||
|
|
||||||
|
|
@ -0,0 +1,12 @@
|
||||||
|
|
||||||
|
|
||||||
|
- [ ] TODO: Tests for Data.Text.Fuzzy.Section
|
||||||
|
- [ ] TODO: haddock for Data.Text.Fuzzy.Section
|
||||||
|
|
||||||
|
- [~] TODO: Tests
|
||||||
|
- [+] TODO: Freeze dependencies versions
|
||||||
|
- [ ] TODO: Version number
|
||||||
|
- [+] TODO: Haddocks
|
||||||
|
- [ ] TODO: Tokenizer: Identation support
|
||||||
|
- [ ] TODO: Tokenizer: Block comments support
|
||||||
|
|
||||||
|
|
@ -0,0 +1,6 @@
|
||||||
|
packages: *.cabal
|
||||||
|
|
||||||
|
allow-newer: all
|
||||||
|
|
||||||
|
tests: True
|
||||||
|
|
||||||
|
|
@ -0,0 +1,61 @@
|
||||||
|
{
|
||||||
|
"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"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"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"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"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"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"root": {
|
||||||
|
"inputs": {
|
||||||
|
"haskell-flake-utils": "haskell-flake-utils",
|
||||||
|
"nixpkgs": "nixpkgs"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"root": "root",
|
||||||
|
"version": 7
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,69 @@
|
||||||
|
{
|
||||||
|
description = "Haskell cabal package";
|
||||||
|
|
||||||
|
inputs = {
|
||||||
|
nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable";
|
||||||
|
haskell-flake-utils.url = "github:ivanovs-4/haskell-flake-utils";
|
||||||
|
|
||||||
|
# another-simple-haskell-flake.url = "something";
|
||||||
|
|
||||||
|
# some-cabal-pkg.url = "github:example/some-cabal-pkg";
|
||||||
|
# some-cabal-pkg.flake = false;
|
||||||
|
};
|
||||||
|
|
||||||
|
outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
|
||||||
|
haskell-flake-utils.lib.simpleCabal2flake {
|
||||||
|
inherit self nixpkgs;
|
||||||
|
# systems = [ "x86_64-linux" ];
|
||||||
|
|
||||||
|
# DON'T FORGET TO PUT YOUR PACKAGE NAME HERE, REMOVING `throw`
|
||||||
|
name = "fuzzy-parse";
|
||||||
|
|
||||||
|
shellExtBuildInputs = {pkgs}: with pkgs; [
|
||||||
|
haskellPackages.haskell-language-server
|
||||||
|
];
|
||||||
|
|
||||||
|
# Wether to build hoogle in the default shell
|
||||||
|
shellWithHoogle = true;
|
||||||
|
|
||||||
|
|
||||||
|
## 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
|
||||||
|
# shell = ./shell.nix
|
||||||
|
|
||||||
|
# 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,160 @@
|
||||||
|
cabal-version: 3.0
|
||||||
|
|
||||||
|
name: fuzzy-parse
|
||||||
|
version: 0.1.3.1
|
||||||
|
synopsis: Tools for processing unstructured text data
|
||||||
|
|
||||||
|
description:
|
||||||
|
The lightweight and easy to use functions for text tokenizing and parsing. It aimed for
|
||||||
|
parsing mostly unstructured data, but the structured formats may be parsed as well.
|
||||||
|
|
||||||
|
It may be used in different sutiations, for DSL, tex markups or even for parsing simple
|
||||||
|
grammars easier and sometimes faster than in case of usage mainstream parsing combinators
|
||||||
|
or parser generators.
|
||||||
|
|
||||||
|
See the README.markdown, examples and modules documentation for more.
|
||||||
|
|
||||||
|
license: MIT
|
||||||
|
license-file: LICENSE
|
||||||
|
author: Dmitry Zuikov
|
||||||
|
maintainer: dzuikov@gmail.com
|
||||||
|
|
||||||
|
category: Text, Parsing
|
||||||
|
extra-source-files: CHANGELOG.md
|
||||||
|
|
||||||
|
homepage: https://github.com/hexresearch/fuzzy-parse
|
||||||
|
bug-reports: https://github.com/hexresearch/fuzzy-parse/issues
|
||||||
|
|
||||||
|
extra-source-files:
|
||||||
|
README.markdown
|
||||||
|
|
||||||
|
common shared-properties
|
||||||
|
|
||||||
|
default-language: GHC2021
|
||||||
|
|
||||||
|
default-extensions:
|
||||||
|
ApplicativeDo
|
||||||
|
, BangPatterns
|
||||||
|
, BlockArguments
|
||||||
|
, ConstraintKinds
|
||||||
|
, DataKinds
|
||||||
|
, DeriveDataTypeable
|
||||||
|
, DeriveGeneric
|
||||||
|
, DerivingStrategies
|
||||||
|
, DerivingVia
|
||||||
|
, ExtendedDefaultRules
|
||||||
|
, FlexibleContexts
|
||||||
|
, FlexibleInstances
|
||||||
|
, GADTs
|
||||||
|
, GeneralizedNewtypeDeriving
|
||||||
|
, ImportQualifiedPost
|
||||||
|
, LambdaCase
|
||||||
|
, MultiParamTypeClasses
|
||||||
|
, OverloadedStrings
|
||||||
|
, QuasiQuotes
|
||||||
|
, RecordWildCards
|
||||||
|
, ScopedTypeVariables
|
||||||
|
, StandaloneDeriving
|
||||||
|
, TemplateHaskell
|
||||||
|
, TupleSections
|
||||||
|
, TypeApplications
|
||||||
|
, TypeFamilies
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
library
|
||||||
|
|
||||||
|
import: shared-properties
|
||||||
|
|
||||||
|
ghc-options:
|
||||||
|
-Wall
|
||||||
|
-fno-warn-type-defaults
|
||||||
|
-O2
|
||||||
|
"-with-rtsopts=-N4 -A64m -AL256m -I0"
|
||||||
|
|
||||||
|
|
||||||
|
exposed-modules: Data.Text.Fuzzy.Tokenize
|
||||||
|
, Data.Text.Fuzzy.Dates
|
||||||
|
, Data.Text.Fuzzy.Section
|
||||||
|
, Data.Text.Fuzzy.SExp
|
||||||
|
, Data.Text.Fuzzy.Attoparsec.Day
|
||||||
|
, Data.Text.Fuzzy.Attoparsec.Month
|
||||||
|
|
||||||
|
build-depends: base
|
||||||
|
, attoparsec
|
||||||
|
, containers
|
||||||
|
, mtl
|
||||||
|
, prettyprinter
|
||||||
|
, safe
|
||||||
|
, streaming
|
||||||
|
, scientific
|
||||||
|
, text
|
||||||
|
, time
|
||||||
|
, microlens-platform
|
||||||
|
, uniplate
|
||||||
|
, unliftio
|
||||||
|
, unordered-containers
|
||||||
|
, timeit
|
||||||
|
|
||||||
|
hs-source-dirs: src
|
||||||
|
|
||||||
|
|
||||||
|
executable fuzzy-sexp-parse
|
||||||
|
|
||||||
|
import: shared-properties
|
||||||
|
default-language: GHC2021
|
||||||
|
|
||||||
|
ghc-options:
|
||||||
|
-Wall
|
||||||
|
-fno-warn-type-defaults
|
||||||
|
-O2
|
||||||
|
|
||||||
|
|
||||||
|
main-is: FuzzySexpParse.hs
|
||||||
|
|
||||||
|
hs-source-dirs: misc
|
||||||
|
|
||||||
|
build-depends: base, fuzzy-parse
|
||||||
|
, containers
|
||||||
|
, hspec
|
||||||
|
, hspec-discover
|
||||||
|
, interpolatedstring-perl6
|
||||||
|
, text
|
||||||
|
, mtl
|
||||||
|
, streaming
|
||||||
|
, transformers
|
||||||
|
, exceptions
|
||||||
|
, uniplate
|
||||||
|
, microlens-platform
|
||||||
|
, safe
|
||||||
|
, timeit
|
||||||
|
, prettyprinter
|
||||||
|
|
||||||
|
|
||||||
|
test-suite fuzzy-parse-test
|
||||||
|
import: shared-properties
|
||||||
|
default-language: GHC2021
|
||||||
|
|
||||||
|
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Spec.hs
|
||||||
|
other-modules: FuzzyParseSpec
|
||||||
|
hs-source-dirs: test
|
||||||
|
build-depends: base, fuzzy-parse
|
||||||
|
, containers
|
||||||
|
, hspec
|
||||||
|
, hspec-discover
|
||||||
|
, interpolatedstring-perl6
|
||||||
|
, text
|
||||||
|
, mtl
|
||||||
|
, streaming
|
||||||
|
, transformers
|
||||||
|
, exceptions
|
||||||
|
, uniplate
|
||||||
|
, microlens-platform
|
||||||
|
, safe
|
||||||
|
, timeit
|
||||||
|
|
||||||
|
build-tool-depends: hspec-discover:hspec-discover == 2.*
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,30 @@
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import Data.Text.Fuzzy.SExp
|
||||||
|
import Data.Text.IO qualified as IO
|
||||||
|
import Data.Text qualified as Text
|
||||||
|
import Data.Either
|
||||||
|
import System.TimeIt
|
||||||
|
import Control.Monad.Except
|
||||||
|
import Data.Functor
|
||||||
|
import Data.Function
|
||||||
|
import Data.Fixed
|
||||||
|
import Prettyprinter
|
||||||
|
import System.IO
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
s <- IO.getContents
|
||||||
|
|
||||||
|
(tt,toks) <- timeItT do
|
||||||
|
pure (tokenizeSexp s)
|
||||||
|
|
||||||
|
(pt,top) <- timeItT do
|
||||||
|
runExceptT (parseTop @() s) <&> either (error.show) id
|
||||||
|
|
||||||
|
print (vcat (fmap pretty top))
|
||||||
|
|
||||||
|
hPrint stderr $ pretty (Text.length s) <+> "chars, parsed in" <+> viaShow (realToFrac pt :: Fixed E6)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,7 @@
|
||||||
|
{
|
||||||
|
"url": "https://github.com/NixOS/nixpkgs.git",
|
||||||
|
"rev": "5cf0de2485efeccc307692eedadbb2d9bfdc7013",
|
||||||
|
"date": "2020-06-04T17:30:37+08:00",
|
||||||
|
"sha256": "07axrr50nlmnvba5ja2ihzjwczi66znak57bhcz472w22w7m3sd1",
|
||||||
|
"fetchSubmodules": false
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,5 @@
|
||||||
|
import ((import <nixpkgs> {}).fetchFromGitHub {
|
||||||
|
owner = "NixOS";
|
||||||
|
repo = "nixpkgs";
|
||||||
|
inherit (builtins.fromJSON (builtins.readFile ./pkgs.json)) rev sha256;
|
||||||
|
})
|
||||||
|
|
@ -0,0 +1,29 @@
|
||||||
|
let
|
||||||
|
pkgs = import ./pkgs.nix { inherit config;
|
||||||
|
};
|
||||||
|
lib = pkgs.haskell.lib;
|
||||||
|
config = {
|
||||||
|
packageOverrides = pkgs: rec {
|
||||||
|
haskellPackages = pkgs.haskellPackages.override { overrides = haskOverrides; };
|
||||||
|
};
|
||||||
|
};
|
||||||
|
gitignore = pkgs.callPackage (pkgs.fetchFromGitHub {
|
||||||
|
owner = "siers";
|
||||||
|
repo = "nix-gitignore";
|
||||||
|
rev = "ce0778ddd8b1f5f92d26480c21706b51b1af9166";
|
||||||
|
sha256 = "1d7ab78i2k13lffskb23x8b5h24x7wkdmpvmria1v3wb9pcpkg2w";
|
||||||
|
}) {};
|
||||||
|
ignore = gitignore.gitignoreSourceAux ''
|
||||||
|
.stack-work
|
||||||
|
dist
|
||||||
|
dist-newstyle
|
||||||
|
.ghc.environment*
|
||||||
|
'';
|
||||||
|
haskOverrides = new: old:
|
||||||
|
let overrides = lib.packagesFromDirectory { directory = ./derivations; } new old;
|
||||||
|
in overrides;
|
||||||
|
in rec {
|
||||||
|
inherit pkgs;
|
||||||
|
packages = { inherit (pkgs.haskellPackages) fuzzy-parse;
|
||||||
|
};
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,3 @@
|
||||||
|
#!/usr/bin/env nix-shell
|
||||||
|
#! nix-shell -i bash -p nix-prefetch-git
|
||||||
|
nix-prefetch-git https://github.com/NixOS/nixpkgs.git | tee pkgs.json
|
||||||
|
|
@ -0,0 +1,10 @@
|
||||||
|
#!/bin/sh
|
||||||
|
set -e
|
||||||
|
|
||||||
|
dir=$(mktemp -d dist-docs.XXXXXX)
|
||||||
|
trap 'rm -r "$dir"' EXIT
|
||||||
|
|
||||||
|
# assumes cabal 2.4 or later
|
||||||
|
cabal v2-haddock --builddir="$dir" --haddock-for-hackage --enable-doc
|
||||||
|
|
||||||
|
cabal upload -d --publish $dir/*-docs.tar.gz
|
||||||
|
|
@ -0,0 +1,97 @@
|
||||||
|
module Data.Text.Fuzzy.Attoparsec.Day ( dayDMY
|
||||||
|
, dayYMD
|
||||||
|
, dayYYYYMMDD
|
||||||
|
, dayDMonY
|
||||||
|
, day
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.List (zipWith)
|
||||||
|
import Control.Applicative ((<|>))
|
||||||
|
import Data.Attoparsec.Text (Parser,decimal,digit,count,satisfy,inClass,skipWhile)
|
||||||
|
import Data.Time.Calendar (Day,fromGregorian,gregorianMonthLength)
|
||||||
|
import qualified Data.Char as Char
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
day :: Parser Day
|
||||||
|
day = dayDMonY <|> dayYYYYMMDD <|> dayYMD <|> dayDMY
|
||||||
|
|
||||||
|
skipDelim :: Parser ()
|
||||||
|
skipDelim = skipWhile (inClass " ./-")
|
||||||
|
|
||||||
|
dayDMY :: Parser Day
|
||||||
|
dayDMY = do
|
||||||
|
d <- decimal :: Parser Int
|
||||||
|
skipDelim
|
||||||
|
m <- decimal :: Parser Int
|
||||||
|
skipDelim
|
||||||
|
y' <- decimal :: Parser Integer
|
||||||
|
maybe (fail "bad date format") pure (makeDay y' m d)
|
||||||
|
|
||||||
|
dayYMD :: Parser Day
|
||||||
|
dayYMD = do
|
||||||
|
y' <- decimal :: Parser Integer
|
||||||
|
skipDelim
|
||||||
|
m <- decimal :: Parser Int
|
||||||
|
skipDelim
|
||||||
|
d <- decimal :: Parser Int
|
||||||
|
maybe (fail "bad date format") pure (makeDay y' m d)
|
||||||
|
|
||||||
|
dayYYYYMMDD :: Parser Day
|
||||||
|
dayYYYYMMDD = do
|
||||||
|
y <- fromIntegral . num n4 . map o <$> count 4 digit
|
||||||
|
m <- num n2 . map o <$> count 2 digit
|
||||||
|
d <- num n2 . map o <$> count 2 digit
|
||||||
|
maybe (fail "bad date format") pure (makeDay y m d)
|
||||||
|
where n4 = [1000,100,10,1]
|
||||||
|
n2 = [10,1]
|
||||||
|
o x = Char.ord x - Char.ord '0'
|
||||||
|
num n x = sum $ zipWith (*) x n
|
||||||
|
|
||||||
|
dayDMonY :: Parser Day
|
||||||
|
dayDMonY = do
|
||||||
|
d <- decimal :: Parser Int
|
||||||
|
skipDelim
|
||||||
|
m <- pMon
|
||||||
|
skipDelim
|
||||||
|
y <- decimal :: Parser Integer
|
||||||
|
maybe (fail "bad date format") pure (makeDay y m d)
|
||||||
|
where
|
||||||
|
pMon :: Parser Int
|
||||||
|
pMon = do
|
||||||
|
txt <- Text.toUpper . Text.pack <$> count 3 (satisfy Char.isLetter)
|
||||||
|
case txt of
|
||||||
|
"JAN" -> pure 1
|
||||||
|
"FEB" -> pure 2
|
||||||
|
"MAR" -> pure 3
|
||||||
|
"APR" -> pure 4
|
||||||
|
"MAY" -> pure 5
|
||||||
|
"JUN" -> pure 6
|
||||||
|
"JUL" -> pure 7
|
||||||
|
"AUG" -> pure 8
|
||||||
|
"SEP" -> pure 9
|
||||||
|
"OCT" -> pure 10
|
||||||
|
"NOV" -> pure 11
|
||||||
|
"DEC" -> pure 12
|
||||||
|
_ -> fail "bad month name"
|
||||||
|
|
||||||
|
|
||||||
|
makeYear :: Integer -> Maybe Integer
|
||||||
|
makeYear y' = if y < 1900 && y' < 99
|
||||||
|
then Nothing
|
||||||
|
else pure y
|
||||||
|
where
|
||||||
|
y = if y' < 50
|
||||||
|
then y' + 2000
|
||||||
|
else (if y' >= 50 && y' <= 99
|
||||||
|
then y' + 1900
|
||||||
|
else y' )
|
||||||
|
|
||||||
|
makeDay :: Integer -> Int -> Int -> Maybe Day
|
||||||
|
makeDay y m d | m <= 12 && m > 0 =
|
||||||
|
makeYear y >>= \yyyy -> if d <= gregorianMonthLength yyyy m
|
||||||
|
then pure $ fromGregorian yyyy m d
|
||||||
|
else Nothing
|
||||||
|
|
||||||
|
| otherwise = Nothing
|
||||||
|
|
@ -0,0 +1,46 @@
|
||||||
|
module Data.Text.Fuzzy.Attoparsec.Month ( fuzzyMonth, fuzzyMonthFromText
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Applicative ((<|>))
|
||||||
|
import Data.Attoparsec.Text (Parser,decimal,digit,letter,many1,parseOnly)
|
||||||
|
import Data.Map (Map)
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Data.Time.Calendar (Day,fromGregorian,gregorianMonthLength)
|
||||||
|
import qualified Data.Char as Char
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
|
|
||||||
|
fuzzyMonth :: Parser Int
|
||||||
|
fuzzyMonth = pMonthNum <|> pMonth
|
||||||
|
|
||||||
|
fuzzyMonthFromText :: Text -> Maybe Int
|
||||||
|
fuzzyMonthFromText = either (const Nothing) Just . parseOnly fuzzyMonth
|
||||||
|
|
||||||
|
pMonthNum :: Parser Int
|
||||||
|
pMonthNum = do
|
||||||
|
n <- decimal
|
||||||
|
if n >= 1 && n <= 13
|
||||||
|
then pure n
|
||||||
|
else fail "invalid months num"
|
||||||
|
|
||||||
|
pMonth :: Parser Int
|
||||||
|
pMonth = do
|
||||||
|
mo <- many1 (Char.toLower <$> letter)
|
||||||
|
maybe (fail "invalid month name") pure (Map.lookup mo months)
|
||||||
|
where
|
||||||
|
months :: Map String Int
|
||||||
|
months = Map.fromList [ ("jan", 1), ("january" , 1)
|
||||||
|
, ("feb", 2), ("febuary" , 2)
|
||||||
|
, ("mar", 3), ("march" , 3)
|
||||||
|
, ("apr", 4), ("april" , 4)
|
||||||
|
, ("may", 5), ("may" , 5)
|
||||||
|
, ("jun", 6), ("june" , 6)
|
||||||
|
, ("jul", 7), ("july" , 7)
|
||||||
|
, ("aug", 8), ("august" , 8)
|
||||||
|
, ("sep", 9), ("september", 9)
|
||||||
|
, ("oct", 10), ("october" , 10)
|
||||||
|
, ("nov", 11), ("november" , 11)
|
||||||
|
, ("dec", 12), ("december" , 12)
|
||||||
|
]
|
||||||
|
|
@ -0,0 +1,46 @@
|
||||||
|
-- |
|
||||||
|
-- Module : Data.Text.Fuzzy.Dates
|
||||||
|
-- Copyright : Dmitry Zuikov 2020
|
||||||
|
-- License : MIT
|
||||||
|
--
|
||||||
|
-- Maintainer : dzuikov@gmail.com
|
||||||
|
-- Stability : experimental
|
||||||
|
-- Portability : unknown
|
||||||
|
--
|
||||||
|
-- Dates fuzzy parsing.
|
||||||
|
-- Supports a number of dates format and tries to recover
|
||||||
|
-- the incomplete dates from text, with use of some
|
||||||
|
-- reasonable assumptions. Does not support locales,
|
||||||
|
-- i.e assums only English for dates yet.
|
||||||
|
--
|
||||||
|
-- == Examples
|
||||||
|
--
|
||||||
|
-- > parseMaybeDay "01.01.1979"
|
||||||
|
-- > Just 1979-01-01
|
||||||
|
-- > parseMaybeDay "01.01.01"
|
||||||
|
-- > Just 2001-01-01
|
||||||
|
-- > parseMaybeDay "13/01/2019"
|
||||||
|
-- > Just 2019-01-13
|
||||||
|
-- > parseMaybeDay "2019-12-1"
|
||||||
|
-- > Just 2019-12-01
|
||||||
|
-- > parseMaybeDay "21-feb-79"
|
||||||
|
-- > Just 1979-02-21
|
||||||
|
-- > parseMaybeDay "21-feb-01"
|
||||||
|
-- > Just 2001-02-21
|
||||||
|
-- > parseMaybeDay "29feb04"
|
||||||
|
-- > Just 2004-02-29
|
||||||
|
-- > parseMaybeDay "21feb28"
|
||||||
|
-- > Just 2028-02-21
|
||||||
|
|
||||||
|
module Data.Text.Fuzzy.Dates where
|
||||||
|
|
||||||
|
import Data.Attoparsec.Text (parseOnly)
|
||||||
|
import Data.Either (either)
|
||||||
|
import Data.Text.Fuzzy.Attoparsec.Day
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Data.Time.Calendar
|
||||||
|
|
||||||
|
-- | Tries to parse a date from the text.
|
||||||
|
parseMaybeDay :: Text -> Maybe Day
|
||||||
|
parseMaybeDay s = either (const Nothing) pure (parseOnly day s)
|
||||||
|
|
||||||
|
|
@ -0,0 +1,378 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE ExtendedDefaultRules #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
module Data.Text.Fuzzy.SExp where
|
||||||
|
|
||||||
|
import Data.Text (Text)
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Control.Monad
|
||||||
|
import Data.Function
|
||||||
|
import Data.Functor
|
||||||
|
import Data.Text.Fuzzy.Tokenize
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import Data.Typeable
|
||||||
|
import Control.Monad.Except
|
||||||
|
import Control.Monad.RWS
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Char (isSpace,digitToInt)
|
||||||
|
import Data.Generics.Uniplate.Data()
|
||||||
|
import Safe
|
||||||
|
import Data.Data
|
||||||
|
import GHC.Generics
|
||||||
|
import Lens.Micro.Platform
|
||||||
|
import Data.Text qualified as Text
|
||||||
|
import Data.Coerce
|
||||||
|
import Data.Scientific
|
||||||
|
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
|
|
||||||
|
import Prettyprinter hiding (braces,list)
|
||||||
|
|
||||||
|
|
||||||
|
import Streaming.Prelude qualified as S
|
||||||
|
|
||||||
|
data TTok = TChar Char
|
||||||
|
| TSChar Char
|
||||||
|
| TPunct Char
|
||||||
|
| TText Text
|
||||||
|
| TStrLit Text
|
||||||
|
| TKeyword Text
|
||||||
|
| TEmpty
|
||||||
|
| TIndent Int
|
||||||
|
deriving stock (Eq,Ord,Show,Data,Generic)
|
||||||
|
|
||||||
|
instance IsToken TTok where
|
||||||
|
mkChar = TChar
|
||||||
|
mkSChar = TSChar
|
||||||
|
mkPunct = TPunct
|
||||||
|
mkText = TText
|
||||||
|
mkStrLit = TStrLit
|
||||||
|
mkKeyword = TKeyword
|
||||||
|
mkEmpty = TEmpty
|
||||||
|
mkIndent = TIndent
|
||||||
|
|
||||||
|
newtype C0 = C0 (Maybe Int)
|
||||||
|
deriving stock (Eq,Ord,Show,Data,Typeable,Generic)
|
||||||
|
|
||||||
|
data SExpParseError =
|
||||||
|
ParensOver C0
|
||||||
|
| ParensUnder C0
|
||||||
|
| ParensUnmatched C0
|
||||||
|
| SyntaxError C0
|
||||||
|
deriving stock (Show,Typeable)
|
||||||
|
|
||||||
|
|
||||||
|
data NumType =
|
||||||
|
NumInteger Integer
|
||||||
|
| NumDouble Scientific
|
||||||
|
deriving stock (Eq,Ord,Show,Data,Generic)
|
||||||
|
|
||||||
|
class Monoid c => ForMicroSexp c where
|
||||||
|
|
||||||
|
instance Monoid C0 where
|
||||||
|
mempty = C0 Nothing
|
||||||
|
|
||||||
|
instance Semigroup C0 where
|
||||||
|
(<>) (C0 a) (C0 b) = C0 (b <|> a)
|
||||||
|
|
||||||
|
instance ForMicroSexp C0 where
|
||||||
|
|
||||||
|
|
||||||
|
instance ForMicroSexp () where
|
||||||
|
|
||||||
|
data MicroSexp c =
|
||||||
|
List_ c [MicroSexp c]
|
||||||
|
| Symbol_ c Text
|
||||||
|
| String_ c Text
|
||||||
|
| Number_ c NumType
|
||||||
|
| Boolean_ c Bool
|
||||||
|
deriving stock (Show,Data,Generic)
|
||||||
|
|
||||||
|
pattern List :: ForMicroSexp c => [MicroSexp c] -> MicroSexp c
|
||||||
|
pattern List xs <- List_ _ xs where
|
||||||
|
List xs = List_ mempty xs
|
||||||
|
|
||||||
|
pattern Symbol :: ForMicroSexp c => Text -> MicroSexp c
|
||||||
|
pattern Symbol xs <- Symbol_ _ xs where
|
||||||
|
Symbol xs = Symbol_ mempty xs
|
||||||
|
|
||||||
|
pattern String :: ForMicroSexp c => Text -> MicroSexp c
|
||||||
|
pattern String x <- String_ _ x where
|
||||||
|
String x = String_ mempty x
|
||||||
|
|
||||||
|
pattern Number :: ForMicroSexp c => NumType -> MicroSexp c
|
||||||
|
pattern Number n <- Number_ _ n where
|
||||||
|
Number n = Number_ mempty n
|
||||||
|
|
||||||
|
pattern Boolean :: ForMicroSexp c => Bool -> MicroSexp c
|
||||||
|
pattern Boolean b <- Boolean_ _ b where
|
||||||
|
Boolean b = Boolean_ mempty b
|
||||||
|
|
||||||
|
{-# COMPLETE List, Symbol, String, Number, Boolean #-}
|
||||||
|
|
||||||
|
|
||||||
|
contextOf :: Lens (MicroSexp c) (MicroSexp c) c c
|
||||||
|
contextOf = lens g s
|
||||||
|
where
|
||||||
|
s sexp c = case sexp of
|
||||||
|
List_ _ a -> List_ c a
|
||||||
|
Symbol_ _ a -> Symbol_ c a
|
||||||
|
String_ _ a -> String_ c a
|
||||||
|
Number_ _ a -> Number_ c a
|
||||||
|
Boolean_ _ a -> Boolean_ c a
|
||||||
|
|
||||||
|
g = \case
|
||||||
|
List_ c _ -> c
|
||||||
|
Symbol_ c _ -> c
|
||||||
|
String_ c _ -> c
|
||||||
|
Number_ c _ -> c
|
||||||
|
Boolean_ c _ -> c
|
||||||
|
|
||||||
|
nil :: forall c . ForMicroSexp c => MicroSexp c
|
||||||
|
nil = List []
|
||||||
|
|
||||||
|
symbol :: forall c . ForMicroSexp c => Text -> MicroSexp c
|
||||||
|
symbol = Symbol
|
||||||
|
|
||||||
|
str :: forall c . ForMicroSexp c => Text -> MicroSexp c
|
||||||
|
str = String
|
||||||
|
|
||||||
|
newtype SExpEnv =
|
||||||
|
SExpEnv
|
||||||
|
{ sexpTranslate :: Bool
|
||||||
|
}
|
||||||
|
|
||||||
|
data SExpState =
|
||||||
|
SExpState
|
||||||
|
{ _sexpLno :: Int
|
||||||
|
, _sexpBraces :: [Char]
|
||||||
|
}
|
||||||
|
|
||||||
|
makeLenses 'SExpState
|
||||||
|
|
||||||
|
defEnv :: SExpEnv
|
||||||
|
defEnv = SExpEnv True
|
||||||
|
|
||||||
|
newtype SExpM m a = SExpM { fromSexpM :: RWST SExpEnv () SExpState m a }
|
||||||
|
deriving newtype
|
||||||
|
( Applicative
|
||||||
|
, Functor
|
||||||
|
, Monad
|
||||||
|
, MonadState SExpState
|
||||||
|
, MonadReader SExpEnv
|
||||||
|
, MonadTrans
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
instance MonadError SExpParseError m => MonadError SExpParseError (SExpM m) where
|
||||||
|
throwError = lift . throwError
|
||||||
|
catchError w = catchError (coerce $ fromSexpM w)
|
||||||
|
|
||||||
|
tokenizeSexp :: Text -> [TTok]
|
||||||
|
tokenizeSexp txt = do
|
||||||
|
let spec = delims " \r\t" <> comment ";"
|
||||||
|
<> punct "'{}()[]\n"
|
||||||
|
<> sqq
|
||||||
|
<> uw
|
||||||
|
tokenize spec txt
|
||||||
|
|
||||||
|
runSexpM :: Monad m => SExpM m a -> m a
|
||||||
|
runSexpM f = evalRWST (fromSexpM f) defEnv (SExpState 0 []) <&> fst
|
||||||
|
|
||||||
|
|
||||||
|
parseSexp :: (ForMicroSexp c, MonadError SExpParseError m) => Text -> m (MicroSexp c)
|
||||||
|
parseSexp txt = do
|
||||||
|
(s, _) <- runSexpM do
|
||||||
|
(s,rest) <- sexp (tokenizeSexp txt)
|
||||||
|
checkBraces
|
||||||
|
pure (s,rest)
|
||||||
|
|
||||||
|
pure s
|
||||||
|
|
||||||
|
checkBraces :: (MonadError SExpParseError m) => SExpM m ()
|
||||||
|
checkBraces = do
|
||||||
|
braces <- gets (view sexpBraces)
|
||||||
|
unless (null braces) $ raiseWith ParensUnder
|
||||||
|
|
||||||
|
succLno :: (MonadError SExpParseError m) => SExpM m ()
|
||||||
|
succLno = modify (over sexpLno succ)
|
||||||
|
|
||||||
|
parseTop :: (ForMicroSexp c, MonadError SExpParseError m) => Text -> m [MicroSexp c]
|
||||||
|
parseTop txt = do
|
||||||
|
let tokens = tokenizeSexp txt
|
||||||
|
S.toList_ $ runSexpM do
|
||||||
|
flip fix (mempty,tokens) $ \next -> \case
|
||||||
|
(acc, []) -> do
|
||||||
|
emit acc
|
||||||
|
(acc, TPunct '\n' : rest) -> do
|
||||||
|
succLno
|
||||||
|
emit acc
|
||||||
|
next (mempty,rest)
|
||||||
|
(acc, rest) -> do
|
||||||
|
(s, xs) <- sexp rest
|
||||||
|
next (acc <> [s],xs)
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
emit [] = pure ()
|
||||||
|
emit wtf = case wtf of
|
||||||
|
[List one] -> lift $ S.yield (List one)
|
||||||
|
xs -> lift $ S.yield (List xs)
|
||||||
|
|
||||||
|
sexp :: (ForMicroSexp c, MonadError SExpParseError m) => [TTok] -> SExpM m (MicroSexp c, [TTok])
|
||||||
|
sexp s = case s of
|
||||||
|
[] -> do
|
||||||
|
checkBraces
|
||||||
|
pure (nil, mempty)
|
||||||
|
|
||||||
|
(TText l : w) -> (,w) <$> trNum (Symbol l)
|
||||||
|
|
||||||
|
(TStrLit l : w) -> pure (String l, w)
|
||||||
|
|
||||||
|
-- so far ignored
|
||||||
|
(TPunct '\'' : rest) -> sexp rest
|
||||||
|
|
||||||
|
(TPunct '\n' : rest) -> succLno >> sexp rest
|
||||||
|
|
||||||
|
(TPunct c : rest) | isSpace c -> sexp rest
|
||||||
|
|
||||||
|
(TPunct c : rest) | isBrace c ->
|
||||||
|
maybe (pure (nil, rest)) (`list` rest) (closing c)
|
||||||
|
| otherwise -> do
|
||||||
|
raiseWith ParensOver
|
||||||
|
|
||||||
|
( _ : _ ) -> raiseWith SyntaxError
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
setContext w = do
|
||||||
|
co <- getC0
|
||||||
|
pure $ over _2 (set contextOf co) w
|
||||||
|
|
||||||
|
isBrace :: Char -> Bool
|
||||||
|
isBrace c = HM.member c braces
|
||||||
|
|
||||||
|
closing :: Char -> Maybe Char
|
||||||
|
closing c = HM.lookup c braces
|
||||||
|
|
||||||
|
braces :: HashMap Char Char
|
||||||
|
braces = HM.fromList[ ('{', '}')
|
||||||
|
, ('(', ')')
|
||||||
|
, ('[', ']')
|
||||||
|
, ('<', '>')
|
||||||
|
]
|
||||||
|
|
||||||
|
cBraces :: [Char]
|
||||||
|
cBraces = HM.elems braces
|
||||||
|
|
||||||
|
trNum tok = do
|
||||||
|
|
||||||
|
trans <- asks sexpTranslate
|
||||||
|
|
||||||
|
case tok of
|
||||||
|
Symbol s | trans -> do
|
||||||
|
let s0 = Text.unpack s
|
||||||
|
|
||||||
|
let what = Number . NumInteger <$> readMay @Integer s0
|
||||||
|
<|>
|
||||||
|
Number . NumInteger <$> parseBinary s0
|
||||||
|
<|>
|
||||||
|
Number . NumDouble <$> readMay @Scientific s0
|
||||||
|
<|>
|
||||||
|
( case s of
|
||||||
|
"#t" -> Just (Boolean True)
|
||||||
|
"#f" -> Just (Boolean False)
|
||||||
|
_ -> Nothing
|
||||||
|
)
|
||||||
|
|
||||||
|
pure $ fromMaybe (Symbol s) what
|
||||||
|
|
||||||
|
|
||||||
|
x -> pure x
|
||||||
|
{-# INLINE trNum #-}
|
||||||
|
|
||||||
|
list :: (ForMicroSexp c, MonadError SExpParseError m)
|
||||||
|
=> Char
|
||||||
|
-> [TTok]
|
||||||
|
-> SExpM m (MicroSexp c, [TTok])
|
||||||
|
|
||||||
|
list _ [] = raiseWith ParensUnder
|
||||||
|
|
||||||
|
list cb tokens = do
|
||||||
|
modify $ over sexpBraces (cb:)
|
||||||
|
|
||||||
|
go cb mempty tokens
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
isClosingFor :: Char -> Bool
|
||||||
|
isClosingFor c = c `elem` cBraces
|
||||||
|
|
||||||
|
go _ _ [] = do
|
||||||
|
checkBraces
|
||||||
|
pure (List mempty, mempty)
|
||||||
|
|
||||||
|
go cl acc (TPunct c : rest) | isSpace c = do
|
||||||
|
go cl acc rest
|
||||||
|
|
||||||
|
go cl acc (TPunct c : rest)
|
||||||
|
| isClosingFor c && c == cl = do
|
||||||
|
modify $ over sexpBraces (drop 1)
|
||||||
|
pure (List (reverse acc), rest)
|
||||||
|
|
||||||
|
| isClosingFor c && c /= cl = do
|
||||||
|
raiseWith ParensUnmatched
|
||||||
|
-- throwError =<< ParensUnmatched <$> undefined
|
||||||
|
|
||||||
|
go cl acc rest = do
|
||||||
|
(e,r) <- sexp rest
|
||||||
|
go cl (e : acc) r
|
||||||
|
|
||||||
|
|
||||||
|
getC0 :: Monad m => SExpM m C0
|
||||||
|
getC0 = do
|
||||||
|
lno <- gets (view sexpLno)
|
||||||
|
pure (C0 (Just lno))
|
||||||
|
|
||||||
|
raiseWith :: (MonadError SExpParseError m)
|
||||||
|
=> (C0 -> SExpParseError) -> SExpM m b
|
||||||
|
|
||||||
|
raiseWith a = throwError =<< a <$> getC0
|
||||||
|
|
||||||
|
instance Pretty NumType where
|
||||||
|
pretty = \case
|
||||||
|
NumInteger n -> pretty n
|
||||||
|
NumDouble n -> viaShow n
|
||||||
|
|
||||||
|
instance ForMicroSexp c => Pretty (MicroSexp c) where
|
||||||
|
|
||||||
|
pretty = \case
|
||||||
|
List xs -> parens (hsep (fmap pretty xs))
|
||||||
|
String s -> dquotes (pretty s)
|
||||||
|
Symbol s -> pretty s
|
||||||
|
Number n -> pretty n
|
||||||
|
Boolean True -> pretty "#t"
|
||||||
|
Boolean False -> pretty "#f"
|
||||||
|
|
||||||
|
isBinaryDigit :: Char -> Bool
|
||||||
|
isBinaryDigit c = c == '0' || c == '1'
|
||||||
|
|
||||||
|
parseBinary :: String -> Maybe Integer
|
||||||
|
parseBinary str =
|
||||||
|
let
|
||||||
|
withoutPrefix = case str of
|
||||||
|
'0':'b':rest -> Just rest
|
||||||
|
'0':'B':rest -> Just rest
|
||||||
|
_ -> Nothing
|
||||||
|
in if isJust withoutPrefix && all isBinaryDigit (fromJust withoutPrefix)
|
||||||
|
then Just $ foldl (\acc x -> acc * 2 + toInteger (digitToInt x)) 0 (fromJust withoutPrefix)
|
||||||
|
else Nothing
|
||||||
|
|
||||||
|
|
@ -0,0 +1,15 @@
|
||||||
|
module Data.Text.Fuzzy.Section (cutSectionBy, cutSectionOn) where
|
||||||
|
|
||||||
|
import Data.Text (Text)
|
||||||
|
import qualified Data.List as List
|
||||||
|
|
||||||
|
|
||||||
|
cutSectionOn :: Text -> Text -> [Text] -> [Text]
|
||||||
|
cutSectionOn a b txt = cutSectionBy ((==)a) ((==b)) txt
|
||||||
|
|
||||||
|
cutSectionBy :: (Text -> Bool) -> (Text -> Bool) -> [Text] -> [Text]
|
||||||
|
cutSectionBy a b txt = cutI
|
||||||
|
where
|
||||||
|
cutC = List.dropWhile (not . a) txt
|
||||||
|
cutI = List.takeWhile (not . b) cutC
|
||||||
|
|
||||||
|
|
@ -0,0 +1,556 @@
|
||||||
|
-- |
|
||||||
|
-- Module : Data.Text.Fuzzy.Tokenize
|
||||||
|
-- Copyright : Dmitry Zuikov 2020
|
||||||
|
-- License : MIT
|
||||||
|
--
|
||||||
|
-- Maintainer : dzuikov@gmail.com
|
||||||
|
-- Stability : experimental
|
||||||
|
-- Portability : unknown
|
||||||
|
--
|
||||||
|
-- The lightweight and multi-functional text tokenizer allowing different types of text tokenization
|
||||||
|
-- depending on it's settings.
|
||||||
|
--
|
||||||
|
-- It may be used in different sutiations, for DSL, text markups or even for parsing simple grammars
|
||||||
|
-- easier and sometimes faster than in case of usage mainstream parsing combinators or parser
|
||||||
|
-- generators.
|
||||||
|
--
|
||||||
|
-- The primary goal of this package is to parse unstructured text data, however it may be used for
|
||||||
|
-- parsing such data formats as CSV with ease.
|
||||||
|
--
|
||||||
|
-- Currently it supports the following types of entities: atoms, string literals (currently with the
|
||||||
|
-- minimal set of escaped characters), punctuation characters and delimeters.
|
||||||
|
--
|
||||||
|
-- == Examples
|
||||||
|
-- === Simple CSV-like tokenization
|
||||||
|
-- >>> tokenize (delims ":") "aaa : bebeb : qqq ::::" :: [Text]
|
||||||
|
-- ["aaa "," bebeb "," qqq "]
|
||||||
|
--
|
||||||
|
-- >>> tokenize (delims ":"<>sq<>emptyFields ) "aaa : bebeb : qqq ::::" :: [Text]
|
||||||
|
-- ["aaa "," bebeb "," qqq ","","","",""]
|
||||||
|
--
|
||||||
|
-- >>>> tokenize (delims ":"<>sq<>emptyFields ) "aaa : bebeb : qqq ::::" :: [Maybe Text]
|
||||||
|
-- [Just "aaa ",Just " bebeb ",Just " qqq ",Nothing,Nothing,Nothing,Nothing]
|
||||||
|
--
|
||||||
|
-- >>> tokenize (delims ":"<>sq<>emptyFields ) "aaa : 'bebeb:colon inside' : qqq ::::" :: [Maybe Text]
|
||||||
|
-- [Just "aaa ",Just " ",Just "bebeb:colon inside",Just " ",Just " qqq ",Nothing,Nothing,Nothing,Nothing]
|
||||||
|
--
|
||||||
|
-- >>> let spec = sl<>delims ":"<>sq<>emptyFields<>noslits
|
||||||
|
-- >>> tokenize spec " aaa : 'bebeb:colon inside' : qqq ::::" :: [Maybe Text]
|
||||||
|
-- [Just "aaa ",Just "bebeb:colon inside ",Just "qqq ",Nothing,Nothing,Nothing,Nothing]
|
||||||
|
--
|
||||||
|
-- >>> let spec = delims ":"<>sq<>emptyFields<>uw<>noslits
|
||||||
|
-- >>> tokenize spec " a b c : 'bebeb:colon inside' : qqq ::::" :: [Maybe Text]
|
||||||
|
-- [Just "a b c",Just "bebeb:colon inside",Just "qqq",Nothing,Nothing,Nothing,Nothing]
|
||||||
|
--
|
||||||
|
-- == Notes
|
||||||
|
--
|
||||||
|
-- === About the delimeter tokens
|
||||||
|
-- This type of tokens appears during a "delimited"
|
||||||
|
-- formats processing and disappears in results. Currenly
|
||||||
|
-- you will never see it unless normalization is turned off by 'nn' option.
|
||||||
|
--
|
||||||
|
-- The delimeters make sense in case of processing the CSV-like formats,
|
||||||
|
-- but in this case you probably need only values in results.
|
||||||
|
--
|
||||||
|
-- This behavior may be changed later. But right now delimeters seem pointless
|
||||||
|
-- in results. If you process some sort of grammar where delimeter character
|
||||||
|
-- is important, you may use punctuation instead, i.e:
|
||||||
|
--
|
||||||
|
-- >>> let spec = delims " \t"<>punct ",;()" <>emptyFields<>sq
|
||||||
|
-- >>> tokenize spec "( delimeters , are , important, 'spaces are not');" :: [Text]
|
||||||
|
-- ["(","delimeters",",","are",",","important",",","spaces are not",")",";"]
|
||||||
|
--
|
||||||
|
-- == Other
|
||||||
|
-- For CSV-like formats it makes sense to split text to lines first,
|
||||||
|
-- otherwise newline characters may cause to weird results
|
||||||
|
--
|
||||||
|
--
|
||||||
|
|
||||||
|
module Data.Text.Fuzzy.Tokenize ( TokenizeSpec
|
||||||
|
, IsToken(..)
|
||||||
|
, tokenize
|
||||||
|
, esc
|
||||||
|
, addEmptyFields
|
||||||
|
, emptyFields
|
||||||
|
, nn
|
||||||
|
, sq
|
||||||
|
, sqq
|
||||||
|
, noslits
|
||||||
|
, sl
|
||||||
|
, sr
|
||||||
|
, uw
|
||||||
|
, delims
|
||||||
|
, comment
|
||||||
|
, punct
|
||||||
|
, indent
|
||||||
|
, itabstops
|
||||||
|
, keywords
|
||||||
|
, eol
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Prelude hiding (init)
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Data.Map (Map)
|
||||||
|
import Data.Maybe (fromMaybe)
|
||||||
|
import Data.Monoid()
|
||||||
|
import Data.Set (Set)
|
||||||
|
import Data.Text (Text)
|
||||||
|
import qualified Data.List as List
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
|
import Control.Monad (when)
|
||||||
|
import Control.Monad.RWS
|
||||||
|
|
||||||
|
-- | Tokenization settings. Use mempty for an empty value
|
||||||
|
-- and construction functions for changing the settings.
|
||||||
|
--
|
||||||
|
data TokenizeSpec = TokenizeSpec { tsAtoms :: Set Text
|
||||||
|
, tsStringQQ :: Maybe Bool
|
||||||
|
, tsStringQ :: Maybe Bool
|
||||||
|
, tsNoSlits :: Maybe Bool
|
||||||
|
, tsLineComment :: Map Char Text
|
||||||
|
, tsDelims :: Set Char
|
||||||
|
, tsEol :: Maybe Bool
|
||||||
|
, tsStripLeft :: Maybe Bool
|
||||||
|
, tsStripRight :: Maybe Bool
|
||||||
|
, tsUW :: Maybe Bool
|
||||||
|
, tsNotNormalize :: Maybe Bool
|
||||||
|
, tsEsc :: Maybe Bool
|
||||||
|
, tsAddEmptyFields :: Maybe Bool
|
||||||
|
, tsPunct :: Set Char
|
||||||
|
, tsIndent :: Maybe Bool
|
||||||
|
, tsItabStops :: Maybe Int
|
||||||
|
, tsKeywords :: Set Text
|
||||||
|
}
|
||||||
|
deriving (Eq,Ord,Show)
|
||||||
|
|
||||||
|
|
||||||
|
instance Semigroup TokenizeSpec where
|
||||||
|
(<>) a b = TokenizeSpec { tsAtoms = tsAtoms b <> tsAtoms a
|
||||||
|
, tsStringQQ = tsStringQQ b <|> tsStringQQ a
|
||||||
|
, tsStringQ = tsStringQ b <|> tsStringQ a
|
||||||
|
, tsNoSlits = tsNoSlits b <|> tsNoSlits a
|
||||||
|
, tsLineComment = tsLineComment b <> tsLineComment a
|
||||||
|
, tsDelims = tsDelims b <> tsDelims a
|
||||||
|
, tsEol = tsEol b <|> tsEol a
|
||||||
|
, tsStripLeft = tsStripLeft b <|> tsStripLeft a
|
||||||
|
, tsStripRight = tsStripRight b <|> tsStripRight a
|
||||||
|
, tsUW = tsUW b <|> tsUW a
|
||||||
|
, tsNotNormalize = tsNotNormalize b <|> tsNotNormalize a
|
||||||
|
, tsEsc = tsEsc b <|> tsEsc a
|
||||||
|
, tsAddEmptyFields = tsAddEmptyFields b <|> tsAddEmptyFields a
|
||||||
|
, tsPunct = tsPunct b <> tsPunct a
|
||||||
|
, tsIndent = tsIndent b <|> tsIndent a
|
||||||
|
, tsItabStops = tsItabStops b <|> tsItabStops a
|
||||||
|
, tsKeywords = tsKeywords b <> tsKeywords a
|
||||||
|
}
|
||||||
|
|
||||||
|
instance Monoid TokenizeSpec where
|
||||||
|
mempty = TokenizeSpec { tsAtoms = mempty
|
||||||
|
, tsStringQQ = Nothing
|
||||||
|
, tsStringQ = Nothing
|
||||||
|
, tsNoSlits = Nothing
|
||||||
|
, tsLineComment = mempty
|
||||||
|
, tsDelims = mempty
|
||||||
|
, tsEol = Nothing
|
||||||
|
, tsStripLeft = Nothing
|
||||||
|
, tsStripRight = Nothing
|
||||||
|
, tsUW = Nothing
|
||||||
|
, tsNotNormalize = Nothing
|
||||||
|
, tsEsc = Nothing
|
||||||
|
, tsAddEmptyFields = Nothing
|
||||||
|
, tsPunct = mempty
|
||||||
|
, tsIndent = Nothing
|
||||||
|
, tsItabStops = Nothing
|
||||||
|
, tsKeywords = mempty
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
justTrue :: Maybe Bool -> Bool
|
||||||
|
justTrue (Just True) = True
|
||||||
|
justTrue _ = False
|
||||||
|
|
||||||
|
-- | Turns on EOL token generation
|
||||||
|
eol :: TokenizeSpec
|
||||||
|
eol = mempty { tsEol = pure True }
|
||||||
|
|
||||||
|
-- | Turn on character escaping inside string literals.
|
||||||
|
-- Currently the following escaped characters are
|
||||||
|
-- supported: [" ' \ t n r a b f v ]
|
||||||
|
esc :: TokenizeSpec
|
||||||
|
esc = mempty { tsEsc = pure True }
|
||||||
|
|
||||||
|
-- | Raise empty field tokens (note mkEmpty method)
|
||||||
|
-- when no tokens found before a delimeter.
|
||||||
|
-- Useful for processing CSV-like data in
|
||||||
|
-- order to distingush empty columns
|
||||||
|
addEmptyFields :: TokenizeSpec
|
||||||
|
addEmptyFields = mempty { tsAddEmptyFields = pure True }
|
||||||
|
|
||||||
|
-- | same as addEmptyFields
|
||||||
|
emptyFields :: TokenizeSpec
|
||||||
|
emptyFields = addEmptyFields
|
||||||
|
|
||||||
|
-- | Turns off token normalization. Makes the tokenizer
|
||||||
|
-- generate character stream. Useful for debugging.
|
||||||
|
nn :: TokenizeSpec
|
||||||
|
nn = mempty { tsNotNormalize = pure True }
|
||||||
|
|
||||||
|
-- | Turns on single-quoted string literals.
|
||||||
|
-- Character stream after '\'' character
|
||||||
|
-- will be proceesed as single-quoted stream,
|
||||||
|
-- assuming all delimeter, comment and other special
|
||||||
|
-- characters as a part of the string literal until
|
||||||
|
-- the next unescaped single quote character.
|
||||||
|
sq :: TokenizeSpec
|
||||||
|
sq = mempty { tsStringQ = pure True }
|
||||||
|
|
||||||
|
-- | Enable double-quoted string literals support
|
||||||
|
-- as 'sq' for single-quoted strings.
|
||||||
|
sqq :: TokenizeSpec
|
||||||
|
sqq = mempty { tsStringQQ = pure True }
|
||||||
|
|
||||||
|
-- | Disable separate string literals.
|
||||||
|
--
|
||||||
|
-- Useful when processed delimeted data (csv-like formats).
|
||||||
|
-- Normally, sequential text chunks are concatenated together,
|
||||||
|
-- but consequent text and string literal will produce the two
|
||||||
|
-- different tokens and it may cause weird results if data
|
||||||
|
-- is in csv-like format, i.e:
|
||||||
|
--
|
||||||
|
-- >>> tokenize (delims ":"<>emptyFields<>sq ) "aaa:bebe:'qq' aaa:next::" :: [Maybe Text]
|
||||||
|
-- [Just "aaa",Just "bebe",Just "qq",Just " aaa",Just "next",Nothing,Nothing]
|
||||||
|
--
|
||||||
|
-- look: "qq" and " aaa" are turned into two separate tokens that makes the result
|
||||||
|
-- of CSV processing looks improper, like it has an extra-column. This behavior may be
|
||||||
|
-- avoided using this option, if you don't need to distinguish text chunks and string
|
||||||
|
-- literals:
|
||||||
|
--
|
||||||
|
-- >>> tokenize (delims ":"<>emptyFields<>sq<>noslits) "aaa:bebe:'qq:foo' aaa:next::" :: [Maybe Text]
|
||||||
|
-- [Just "aaa",Just "bebe",Just "qq:foo aaa",Just "next",Nothing,Nothing]
|
||||||
|
--
|
||||||
|
noslits :: TokenizeSpec
|
||||||
|
noslits = mempty { tsNoSlits = pure True }
|
||||||
|
|
||||||
|
-- | Specify the list of delimers (characters)
|
||||||
|
-- to split the character stream into fields. Useful for CSV-like separated formats. Support for
|
||||||
|
-- empty fields in token stream may be enabled by 'addEmptyFields' function
|
||||||
|
delims :: String -> TokenizeSpec
|
||||||
|
delims s = mempty { tsDelims = Set.fromList s }
|
||||||
|
|
||||||
|
-- | Strip spaces on left side of a token.
|
||||||
|
-- Does not affect string literals, i.e string are processed normally. Useful mostly for
|
||||||
|
-- processing CSV-like formats, otherwise 'delims' may be used to skip unwanted spaces.
|
||||||
|
sl :: TokenizeSpec
|
||||||
|
sl = mempty { tsStripLeft = pure True }
|
||||||
|
|
||||||
|
-- | Strip spaces on right side of a token.
|
||||||
|
-- Does not affect string literals, i.e string are processed normally. Useful mostly for
|
||||||
|
-- processing CSV-like formats, otherwise 'delims' may be used to skip unwanted spaces.
|
||||||
|
sr :: TokenizeSpec
|
||||||
|
sr = mempty { tsStripRight = pure True }
|
||||||
|
|
||||||
|
-- | Strips spaces on right and left sides and transforms multiple spaces into the one.
|
||||||
|
-- Name origins from unwords . words
|
||||||
|
--
|
||||||
|
-- Does not affect string literals, i.e string are processed normally. Useful mostly for
|
||||||
|
-- processing CSV-like formats, otherwise 'delims' may be used to skip unwanted spaces.
|
||||||
|
uw :: TokenizeSpec
|
||||||
|
uw = mempty { tsUW = pure True }
|
||||||
|
|
||||||
|
-- | Specify the line comment prefix.
|
||||||
|
-- All text after the line comment prefix will
|
||||||
|
-- be ignored until the newline character appearance.
|
||||||
|
-- Multiple line comments are supported.
|
||||||
|
comment :: Text -> TokenizeSpec
|
||||||
|
comment s = mempty { tsLineComment = cmt }
|
||||||
|
where
|
||||||
|
cmt = case Text.uncons s of
|
||||||
|
Just (p,su) -> Map.singleton p su
|
||||||
|
Nothing -> mempty
|
||||||
|
|
||||||
|
-- | Specify the punctuation characters.
|
||||||
|
-- Any punctuation character is handled as a separate
|
||||||
|
-- token.
|
||||||
|
-- Any token will be breaked on a punctiation character.
|
||||||
|
--
|
||||||
|
-- Useful for handling ... er... punctuaton, like
|
||||||
|
--
|
||||||
|
-- >> function(a,b)
|
||||||
|
--
|
||||||
|
-- or
|
||||||
|
--
|
||||||
|
-- >> (apply function 1 2 3)
|
||||||
|
--
|
||||||
|
--
|
||||||
|
-- >>> tokenize spec "(apply function 1 2 3)" :: [Text]
|
||||||
|
-- ["(","apply","function","1","2","3",")"]
|
||||||
|
--
|
||||||
|
punct :: Text -> TokenizeSpec
|
||||||
|
punct s = mempty { tsPunct = Set.fromList (Text.unpack s) }
|
||||||
|
|
||||||
|
-- | Specify the keywords list.
|
||||||
|
-- Each keyword will be threated as a separate token.
|
||||||
|
keywords :: [Text] -> TokenizeSpec
|
||||||
|
keywords s = mempty { tsKeywords = Set.fromList s }
|
||||||
|
|
||||||
|
-- | Enable identation support
|
||||||
|
indent :: TokenizeSpec
|
||||||
|
indent = mempty { tsIndent = Just True }
|
||||||
|
|
||||||
|
-- | Set tab expanding multiplier
|
||||||
|
-- i.e. each tab extends into n spaces before processing.
|
||||||
|
-- It also turns on the indentation. Only the tabs at the beginning of the string are expanded,
|
||||||
|
-- i.e. before the first non-space character appears.
|
||||||
|
itabstops :: Int -> TokenizeSpec
|
||||||
|
itabstops n = mempty { tsIndent = Just True, tsItabStops = pure n }
|
||||||
|
|
||||||
|
newtype TokenizeM w a = TokenizeM (RWS TokenizeSpec w () a)
|
||||||
|
deriving( Applicative
|
||||||
|
, Functor
|
||||||
|
, MonadReader TokenizeSpec
|
||||||
|
, MonadWriter w
|
||||||
|
, MonadState ()
|
||||||
|
, Monad
|
||||||
|
)
|
||||||
|
|
||||||
|
data Token = TChar Char
|
||||||
|
| TSChar Char
|
||||||
|
| TPunct Char
|
||||||
|
| TText Text
|
||||||
|
| TSLit Text
|
||||||
|
| TKeyword Text
|
||||||
|
| TEmpty
|
||||||
|
| TDelim
|
||||||
|
| TIndent Int
|
||||||
|
| TEol
|
||||||
|
deriving (Eq,Ord,Show)
|
||||||
|
|
||||||
|
-- | Typeclass for token values.
|
||||||
|
-- Note, that some tokens appear in results
|
||||||
|
-- only when 'nn' option is set, i.e. sequences
|
||||||
|
-- of characters turn out to text tokens or string literals
|
||||||
|
-- and delimeter tokens are just removed from the
|
||||||
|
-- results
|
||||||
|
class IsToken a where
|
||||||
|
-- | Create a character token
|
||||||
|
mkChar :: Char -> a
|
||||||
|
-- | Create a string literal character token
|
||||||
|
mkSChar :: Char -> a
|
||||||
|
-- | Create a punctuation token
|
||||||
|
mkPunct :: Char -> a
|
||||||
|
-- | Create a text chunk token
|
||||||
|
mkText :: Text -> a
|
||||||
|
-- | Create a string literal token
|
||||||
|
mkStrLit :: Text -> a
|
||||||
|
-- | Create a keyword token
|
||||||
|
mkKeyword :: Text -> a
|
||||||
|
-- | Create an empty field token
|
||||||
|
mkEmpty :: a
|
||||||
|
-- | Create a delimeter token
|
||||||
|
mkDelim :: a
|
||||||
|
mkDelim = mkEmpty
|
||||||
|
|
||||||
|
-- | Creates an indent token
|
||||||
|
mkIndent :: Int -> a
|
||||||
|
mkIndent = const mkEmpty
|
||||||
|
|
||||||
|
-- | Creates an EOL token
|
||||||
|
mkEol :: a
|
||||||
|
mkEol = mkEmpty
|
||||||
|
|
||||||
|
instance IsToken (Maybe Text) where
|
||||||
|
mkChar = pure . Text.singleton
|
||||||
|
mkSChar = pure . Text.singleton
|
||||||
|
mkPunct = pure . Text.singleton
|
||||||
|
mkText = pure
|
||||||
|
mkStrLit = pure
|
||||||
|
mkKeyword = pure
|
||||||
|
mkEmpty = Nothing
|
||||||
|
|
||||||
|
instance IsToken Text where
|
||||||
|
mkChar = Text.singleton
|
||||||
|
mkSChar = Text.singleton
|
||||||
|
mkPunct = Text.singleton
|
||||||
|
mkText = id
|
||||||
|
mkStrLit = id
|
||||||
|
mkKeyword = id
|
||||||
|
mkEmpty = ""
|
||||||
|
|
||||||
|
-- | Tokenize a text
|
||||||
|
tokenize :: IsToken a => TokenizeSpec -> Text -> [a]
|
||||||
|
tokenize s t = map tr t1
|
||||||
|
where
|
||||||
|
t1 = tokenize' s t
|
||||||
|
tr (TChar c) = mkChar c
|
||||||
|
tr (TSChar c) = mkSChar c
|
||||||
|
tr (TText c) = mkText c
|
||||||
|
tr (TSLit c) = mkStrLit c
|
||||||
|
tr (TKeyword c) = mkKeyword c
|
||||||
|
tr TEmpty = mkEmpty
|
||||||
|
tr (TPunct c) = mkPunct c
|
||||||
|
tr TDelim = mkDelim
|
||||||
|
tr (TIndent n) = mkIndent n
|
||||||
|
tr TEol = mkEol
|
||||||
|
|
||||||
|
execTokenizeM :: TokenizeM [Token] a -> TokenizeSpec -> [Token]
|
||||||
|
execTokenizeM (TokenizeM m) spec =
|
||||||
|
let (_,w) = execRWS m spec () in norm w
|
||||||
|
|
||||||
|
where norm x | justTrue (tsNotNormalize spec) = x
|
||||||
|
| otherwise = normalize spec x
|
||||||
|
|
||||||
|
tokenize' :: TokenizeSpec -> Text -> [Token]
|
||||||
|
tokenize' spec txt = execTokenizeM (root' txt) spec
|
||||||
|
where
|
||||||
|
|
||||||
|
r = spec
|
||||||
|
|
||||||
|
noIndent = not doIndent
|
||||||
|
doIndent = justTrue (tsIndent r)
|
||||||
|
eolOk = justTrue (tsEol r)
|
||||||
|
|
||||||
|
root' x = scanIndent x >>= root
|
||||||
|
|
||||||
|
root ts = do
|
||||||
|
|
||||||
|
case Text.uncons ts of
|
||||||
|
Nothing -> pure ()
|
||||||
|
|
||||||
|
Just ('\n', rest) | doIndent -> raiseEol >> root' rest
|
||||||
|
Just (c, rest) | Set.member c (tsDelims r) -> tell [TDelim] >> root rest
|
||||||
|
Just ('\'', rest) | justTrue (tsStringQ r) -> scanQ '\'' rest
|
||||||
|
Just ('"', rest) | justTrue (tsStringQQ r) -> scanQ '"' rest
|
||||||
|
|
||||||
|
Just (c, rest) | Map.member c (tsLineComment r) -> scanComment (c,rest)
|
||||||
|
|
||||||
|
Just (c, rest) | Set.member c (tsPunct r) -> tell [TPunct c] >> root rest
|
||||||
|
|
||||||
|
Just (c, rest) | otherwise -> tell [TChar c] >> root rest
|
||||||
|
|
||||||
|
|
||||||
|
raiseEol | eolOk = tell [TEol]
|
||||||
|
| otherwise = pure ()
|
||||||
|
|
||||||
|
expandSpace ' ' = 1
|
||||||
|
expandSpace '\t' = (fromMaybe 8 (tsItabStops r))
|
||||||
|
expandSpace _ = 0
|
||||||
|
|
||||||
|
scanIndent x | noIndent = pure x
|
||||||
|
| otherwise = do
|
||||||
|
let (ss,as) = Text.span (\c -> c == ' ' || c == '\t') x
|
||||||
|
tell [ TIndent (sum (map expandSpace (Text.unpack ss))) ]
|
||||||
|
pure as
|
||||||
|
|
||||||
|
scanComment (c,rest) = do
|
||||||
|
suff <- Map.lookup c <$> asks tsLineComment
|
||||||
|
case suff of
|
||||||
|
Just t | Text.isPrefixOf t rest -> do
|
||||||
|
root $ Text.dropWhile ('\n' /=) rest
|
||||||
|
|
||||||
|
_ -> tell [TChar c] >> root rest
|
||||||
|
|
||||||
|
scanQ q ts = do
|
||||||
|
|
||||||
|
case Text.uncons ts of
|
||||||
|
Nothing -> root ts
|
||||||
|
|
||||||
|
Just ('\\', rest) | justTrue (tsEsc r) -> unesc (scanQ q) rest
|
||||||
|
| otherwise -> tell [tsChar '\\'] >> scanQ q rest
|
||||||
|
|
||||||
|
Just (c, rest) | c == q -> root rest
|
||||||
|
| otherwise -> tell [tsChar c] >> scanQ q rest
|
||||||
|
|
||||||
|
unesc f ts =
|
||||||
|
case Text.uncons ts of
|
||||||
|
Nothing -> f ts
|
||||||
|
Just ('"', rs) -> tell [tsChar '"' ] >> f rs
|
||||||
|
Just ('\'', rs) -> tell [tsChar '\''] >> f rs
|
||||||
|
Just ('\\', rs) -> tell [tsChar '\\'] >> f rs
|
||||||
|
Just ('t', rs) -> tell [tsChar '\t'] >> f rs
|
||||||
|
Just ('n', rs) -> tell [tsChar '\n'] >> f rs
|
||||||
|
Just ('r', rs) -> tell [tsChar '\r'] >> f rs
|
||||||
|
Just ('a', rs) -> tell [tsChar '\a'] >> f rs
|
||||||
|
Just ('b', rs) -> tell [tsChar '\b'] >> f rs
|
||||||
|
Just ('f', rs) -> tell [tsChar '\f'] >> f rs
|
||||||
|
Just ('v', rs) -> tell [tsChar '\v'] >> f rs
|
||||||
|
Just (_, rs) -> f rs
|
||||||
|
|
||||||
|
tsChar c | justTrue (tsNoSlits spec) = TChar c
|
||||||
|
| otherwise = TSChar c
|
||||||
|
|
||||||
|
newtype NormStats = NormStats { nstatBeforeDelim :: Int }
|
||||||
|
|
||||||
|
normalize :: TokenizeSpec -> [Token] -> [Token]
|
||||||
|
normalize spec tokens = snd $ execRWS (go tokens) () init
|
||||||
|
where
|
||||||
|
|
||||||
|
go [] = addEmptyField
|
||||||
|
|
||||||
|
go s@(TIndent _ : _) = do
|
||||||
|
let (iis, rest') = List.span isIndent s
|
||||||
|
tell [TIndent (sum [k | TIndent k <- iis])]
|
||||||
|
go rest'
|
||||||
|
|
||||||
|
go (TChar c0 : cs) = do
|
||||||
|
let (n,ns) = List.span isTChar cs
|
||||||
|
succStat
|
||||||
|
let chunk = eatSpaces $ Text.pack (c0 : [ c | TChar c <- n])
|
||||||
|
let kw = Set.member chunk (tsKeywords spec)
|
||||||
|
tell [ if kw then TKeyword chunk else TText chunk ]
|
||||||
|
go ns
|
||||||
|
|
||||||
|
go (TSChar x : xs) = do
|
||||||
|
let (n,ns) = List.span isTSChar xs
|
||||||
|
succStat
|
||||||
|
tell [ TSLit $ Text.pack (x : [ c | TSChar c <- n]) ]
|
||||||
|
go ns
|
||||||
|
|
||||||
|
go (TDelim : xs) = do
|
||||||
|
addEmptyField
|
||||||
|
pruneStat
|
||||||
|
go xs
|
||||||
|
|
||||||
|
go (TPunct c : xs) = do
|
||||||
|
tell [ TPunct c ]
|
||||||
|
succStat
|
||||||
|
go xs
|
||||||
|
|
||||||
|
go (x:xs) = tell [x] >> go xs
|
||||||
|
|
||||||
|
succStat = do
|
||||||
|
modify (\x -> x { nstatBeforeDelim = succ (nstatBeforeDelim x)})
|
||||||
|
|
||||||
|
pruneStat = do
|
||||||
|
modify (\x -> x { nstatBeforeDelim = 0 } )
|
||||||
|
|
||||||
|
addEmptyField = do
|
||||||
|
ns <- gets nstatBeforeDelim
|
||||||
|
when (ns == 0 && justTrue (tsAddEmptyFields spec) ) $ do
|
||||||
|
tell [ TEmpty ]
|
||||||
|
|
||||||
|
isTChar (TChar _) = True
|
||||||
|
isTChar _ = False
|
||||||
|
|
||||||
|
isTSChar (TSChar _) = True
|
||||||
|
isTSChar _ = False
|
||||||
|
|
||||||
|
isIndent (TIndent _) = True
|
||||||
|
isIndent _ = False
|
||||||
|
|
||||||
|
init = NormStats { nstatBeforeDelim = 0 }
|
||||||
|
|
||||||
|
eatSpaces s | sboth = Text.strip s
|
||||||
|
| sLonly = Text.stripStart s
|
||||||
|
| sRonly = Text.stripEnd s
|
||||||
|
| sWU = (Text.unwords . Text.words) s
|
||||||
|
| otherwise = s
|
||||||
|
|
||||||
|
where sboth = justTrue (tsStripLeft spec) && justTrue (tsStripRight spec)
|
||||||
|
sLonly = justTrue (tsStripLeft spec) && not (justTrue (tsStripRight spec))
|
||||||
|
sRonly = not (justTrue (tsStripLeft spec)) && justTrue (tsStripRight spec)
|
||||||
|
sWU = justTrue (tsUW spec)
|
||||||
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
module Data.Text.LSH where
|
||||||
|
|
@ -0,0 +1,150 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings
|
||||||
|
, QuasiQuotes
|
||||||
|
, ExtendedDefaultRules
|
||||||
|
, LambdaCase
|
||||||
|
, ImportQualifiedPost
|
||||||
|
, DerivingStrategies
|
||||||
|
, PatternSynonyms
|
||||||
|
, ViewPatterns
|
||||||
|
, MultiWayIf
|
||||||
|
, TemplateHaskell
|
||||||
|
#-}
|
||||||
|
|
||||||
|
module FuzzyParseSpec (spec) where
|
||||||
|
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Test.Hspec
|
||||||
|
import Text.InterpolatedString.Perl6 (q)
|
||||||
|
|
||||||
|
import Data.Text.Fuzzy.Tokenize
|
||||||
|
import Data.Data
|
||||||
|
import Data.Generics.Uniplate.Data()
|
||||||
|
import GHC.Generics
|
||||||
|
|
||||||
|
data TTok = TChar Char
|
||||||
|
| TSChar Char
|
||||||
|
| TPunct Char
|
||||||
|
| TText Text
|
||||||
|
| TStrLit Text
|
||||||
|
| TKeyword Text
|
||||||
|
| TEmpty
|
||||||
|
| TIndent Int
|
||||||
|
deriving stock (Eq,Ord,Show,Data,Generic)
|
||||||
|
|
||||||
|
instance IsToken TTok where
|
||||||
|
mkChar = TChar
|
||||||
|
mkSChar = TSChar
|
||||||
|
mkPunct = TPunct
|
||||||
|
mkText = TText
|
||||||
|
mkStrLit = TStrLit
|
||||||
|
mkKeyword = TKeyword
|
||||||
|
mkEmpty = TEmpty
|
||||||
|
mkIndent = TIndent
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
describe "csv-like" $ do
|
||||||
|
it "splits text using ':' delimeter" $ do
|
||||||
|
let toks = tokenize (delims ":") "aaa : bebeb : qqq ::::" :: [Text]
|
||||||
|
toks `shouldBe` ["aaa "," bebeb "," qqq "]
|
||||||
|
|
||||||
|
it "splits text using ':' delimeter with single-quotes string and empty fields" $ do
|
||||||
|
let toks = tokenize (delims ":"<>sq<>emptyFields ) "aaa : bebeb : qqq ::::" :: [Text]
|
||||||
|
toks `shouldBe` ["aaa "," bebeb "," qqq ","","","",""]
|
||||||
|
|
||||||
|
it "splits text using ':' delimeter with single-quotes string and empty fields" $ do
|
||||||
|
let toks = tokenize (delims ":"<>sq<>emptyFields ) "aaa : 'bebeb:colon inside' : qqq ::::" :: [Maybe Text]
|
||||||
|
toks `shouldBe` [Just "aaa ",Just " ",Just "bebeb:colon inside",Just " ",Just " qqq ",Nothing,Nothing,Nothing,Nothing]
|
||||||
|
|
||||||
|
it "splits text using ':' delimeter with single-quotes string and empty fields with noslits" $ do
|
||||||
|
let spec = sl<>delims ":"<>sq<>emptyFields<>noslits
|
||||||
|
let toks = tokenize spec " aaa : 'bebeb:colon inside' : qqq ::::" :: [Maybe Text]
|
||||||
|
toks `shouldBe` [Just "aaa ",Just "bebeb:colon inside ",Just "qqq ",Nothing,Nothing,Nothing,Nothing]
|
||||||
|
|
||||||
|
it "splits text using ':' delimeter with single-quotes string and empty fields with noslits and uw" $ do
|
||||||
|
let spec = delims ":"<>sq<>emptyFields<>uw<>noslits
|
||||||
|
let toks = tokenize spec " a b c : 'bebeb:colon inside' : qqq ::::" :: [Maybe Text]
|
||||||
|
toks `shouldBe` [Just "a b c",Just "bebeb:colon inside",Just "qqq",Nothing,Nothing,Nothing,Nothing]
|
||||||
|
|
||||||
|
it "uses punctuation tokens" $ do
|
||||||
|
let spec = delims " \t"<>punct ",;()" <>emptyFields<>sq
|
||||||
|
let toks = tokenize spec "( delimeters , are , important, 'spaces are not');" :: [Text]
|
||||||
|
toks `shouldBe` ["(","delimeters",",","are",",","important",",","spaces are not",")",";"]
|
||||||
|
|
||||||
|
|
||||||
|
it "tokenize simple lisp-like text with keywords" $ do
|
||||||
|
let spec = delims " \n\t" <> comment ";"
|
||||||
|
<> punct "{}()[]<>"
|
||||||
|
<> sq <> sqq
|
||||||
|
<> uw
|
||||||
|
<> keywords ["define","apply","+"]
|
||||||
|
|
||||||
|
let code = [q|
|
||||||
|
(define add (a b ) ; define simple function
|
||||||
|
(+ a b) )
|
||||||
|
(define r (add 10 20))
|
||||||
|
|]
|
||||||
|
|
||||||
|
let toks = tokenize spec code :: [TTok]
|
||||||
|
|
||||||
|
let expected = [ TPunct '('
|
||||||
|
, TKeyword "define"
|
||||||
|
, TText "add" , TPunct '(', TText "a" , TText "b", TPunct ')'
|
||||||
|
, TPunct '(', TKeyword "+", TText "a",TText "b",TPunct ')',TPunct ')'
|
||||||
|
, TPunct '(',TKeyword "define"
|
||||||
|
,TText "r"
|
||||||
|
,TPunct '(',TText "add",TText "10",TText "20"
|
||||||
|
,TPunct ')',TPunct ')']
|
||||||
|
|
||||||
|
toks `shouldBe` expected
|
||||||
|
|
||||||
|
|
||||||
|
describe "Checks indentation support" $ do
|
||||||
|
|
||||||
|
let spec = delims " \n\t" <> comment ";"
|
||||||
|
<> punct "{}()[]<>"
|
||||||
|
<> sq <> sqq
|
||||||
|
<> uw
|
||||||
|
<> indent
|
||||||
|
<> itabstops 8
|
||||||
|
<> keywords ["define"]
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
it "parses some indented blocks" $ do
|
||||||
|
|
||||||
|
let expected = [ TIndent 0, TKeyword "define", TText "a", TText "0"
|
||||||
|
, TIndent 2, TText "atom", TText "foo", TText "2"
|
||||||
|
, TIndent 2, TKeyword "define", TText "aq", TText "2"
|
||||||
|
, TIndent 4, TText "atom", TText "one", TText "4"
|
||||||
|
, TIndent 4, TText "atom", TText "two", TText "4"
|
||||||
|
, TIndent 0, TKeyword "define", TText "b", TText "0"
|
||||||
|
, TIndent 2, TText "atom", TText "baar", TText "2"
|
||||||
|
, TIndent 2, TText "atom", TText "quux", TText "2"
|
||||||
|
, TIndent 2, TKeyword "define", TText "new", TText "2"
|
||||||
|
, TIndent 6, TText "atom", TText "bar", TText "6"
|
||||||
|
, TIndent 4, TText "atom", TText "fuu", TText "4"
|
||||||
|
, TIndent 0
|
||||||
|
]
|
||||||
|
|
||||||
|
let pyLike = [q|
|
||||||
|
define a 0
|
||||||
|
atom foo 2
|
||||||
|
define aq 2
|
||||||
|
atom one 4
|
||||||
|
atom two 4
|
||||||
|
|
||||||
|
define b 0
|
||||||
|
atom baar 2
|
||||||
|
atom quux 2
|
||||||
|
define new 2
|
||||||
|
atom bar 6
|
||||||
|
atom fuu 4
|
||||||
|
|
||||||
|
|]
|
||||||
|
let toks = tokenize spec pyLike :: [TTok]
|
||||||
|
toks `shouldBe` expected
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||||
Loading…
Reference in New Issue