diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for fuzzy-parse + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fuzzy-parse.cabal b/fuzzy-parse.cabal new file mode 100644 --- /dev/null +++ b/fuzzy-parse.cabal @@ -0,0 +1,72 @@ +cabal-version: 2.2 + +name: fuzzy-parse +version: 0.1.0.0 +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.md, 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 + +source-repository this + type: git + location: https://github.com/hexresearch/fuzzy-parse.git + tag: 0.1.0.0 + +library + + ghc-options: -Wall + + exposed-modules: Data.Text.Fuzzy.Tokenize + , Data.Text.Fuzzy.Dates + + other-modules: Data.Text.Fuzzy.Attoparsec.Day + + build-depends: base >= 4.11 && <5 + , attoparsec >= 0.13 + , containers + , mtl >= 2.2 + , text >= 1.2 + , time >= 1.8 + + + hs-source-dirs: src + default-language: Haskell2010 + + default-extensions: OverloadedStrings + , FlexibleInstances + , FlexibleContexts + , GeneralizedNewtypeDeriving + +test-suite fuzzy-parse-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: FuzzyParseSpec + hs-source-dirs: test + build-depends: base >= 4 && < 5 + , hspec + , hspec-discover + , fuzzy-parse + , interpolatedstring-perl6 + , text + build-tool-depends: hspec-discover:hspec-discover == 2.* + + diff --git a/src/Data/Text/Fuzzy/Attoparsec/Day.hs b/src/Data/Text/Fuzzy/Attoparsec/Day.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Fuzzy/Attoparsec/Day.hs @@ -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 diff --git a/src/Data/Text/Fuzzy/Dates.hs b/src/Data/Text/Fuzzy/Dates.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Fuzzy/Dates.hs @@ -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) + diff --git a/src/Data/Text/Fuzzy/Tokenize.hs b/src/Data/Text/Fuzzy/Tokenize.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Fuzzy/Tokenize.hs @@ -0,0 +1,487 @@ +-- | +-- 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 + , keywords + ) where + +import Prelude hiding (init) + +import Data.Set (Set) +import Data.Map (Map) +import Data.Text (Text) +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.List as List +import Data.Monoid() +import Control.Applicative + +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 + , tsStripLeft :: Maybe Bool + , tsStripRight :: Maybe Bool + , tsUW :: Maybe Bool + , tsNotNormalize :: Maybe Bool + , tsEsc :: Maybe Bool + , tsAddEmptyFields :: Maybe Bool + , tsPunct :: Set Char + , 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 + , 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 + , tsKeywords = tsKeywords b <> tsKeywords a + } + +instance Monoid TokenizeSpec where + mempty = TokenizeSpec { tsAtoms = mempty + , tsStringQQ = Nothing + , tsStringQ = Nothing + , tsNoSlits = Nothing + , tsLineComment = mempty + , tsDelims = mempty + , tsStripLeft = Nothing + , tsStripRight = Nothing + , tsUW = Nothing + , tsNotNormalize = Nothing + , tsEsc = Nothing + , tsAddEmptyFields = Nothing + , tsPunct = mempty + , tsKeywords = mempty + } + + +justTrue :: Maybe Bool -> Bool +justTrue (Just True) = True +justTrue _ = False + +-- | 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 during +-- 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 during +-- 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 during +-- 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 } + +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 + 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 + +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 + +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 + + root ts = do + r <- ask + + case Text.uncons ts of + Nothing -> pure () + + 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 + + + scanComment (c,rest) = do + suff <- Map.lookup c <$> asks tsLineComment + case suff of + Just t | Text.isPrefixOf t rest -> do + root $ Text.drop 1 $ Text.dropWhile ('\n' /=) rest + + _ -> tell [TChar c] >> root rest + + scanQ q ts = do + r <- ask + + 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 (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 + + 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) + diff --git a/test/FuzzyParseSpec.hs b/test/FuzzyParseSpec.hs new file mode 100644 --- /dev/null +++ b/test/FuzzyParseSpec.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedStrings + , QuasiQuotes + , ExtendedDefaultRules #-} + +module FuzzyParseSpec (spec) where + +import Data.Text (Text) +import Test.Hspec +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 + +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 + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}