diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Mike Ledger (c) 2016-2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 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/bench/Parsing.hs b/bench/Parsing.hs new file mode 100644 --- /dev/null +++ b/bench/Parsing.hs @@ -0,0 +1,932 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +import Control.DeepSeq +import Criterion.Main +import qualified Data.Attoparsec.Text as A +import Data.List (sortOn) +import qualified Data.RadixTree as R +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Text.QuasiText + +parseNaiive :: [Text] -> A.Parser Text +parseNaiive = A.choice . map A.string . sortOn (negate . T.length) + +main :: IO () +main = defaultMain + [ env (return (source, sourceRadix, sourceRadixCompressed, tests0)) $ \ + ~(src, radix, radix2, tests) -> + bgroup "attoparsec" + [ bench "radix" $ + V.foldl' (\() t -> rnf $ A.parseOnly (R.parse radix) t) () `nf` tests + , bench "radix compressed" $ + V.foldl' (\() t -> rnf $ A.parseOnly (R.parse radix2) t) () `nf` tests + , bench "naiive" $ + V.foldl' (\() t -> rnf $ A.parseOnly (parseNaiive src) t) () `nf` tests + ] + ] + +tests0 :: V.Vector Text +tests0 = V.fromList $! T.lines + "acceleration\n\ + \acceleration, braking or coasting\n\ + \axle\n\ + \AAA\n\ + \2+2 seating\n\ + \long thing that doesn't parse\n\ + \z" + +sourceRadixCompressed :: R.CompressedRadixTree +sourceRadixCompressed = + case R.compressBy (T.concat source) sourceRadix of + Just ct -> ct + Nothing -> error "could not compress source" + +sourceRadix :: R.RadixTree +sourceRadix = R.fromFoldable source + +source :: [Text] +source = T.lines [embed| +% ++/- +2+2 seating +A. +AAA +AAR-10A Contoured Coupler +able +able-bodied +AC auxiliary power +accelerating, braking or coasting +acceleration +access +accessible +accessible toilet +accidental operation +accordance +accreditation +accumulate +accuracy +action +activation +active +activities +Adapter Coupling +adjacent +adjust +adverse +air +air pressure +Air Spring +air suspension +aisle +alarm +alerts +aligned +allocated +Alpha-Numeric Trip Codes +alternative +aluminium +announcements +apples +apportioned +appropriate +approval +approved +area calculation +armrests +arrival +ASA standards +asdf +asdff +Asset Information System +assistive listening +attack +audio +Australian +Authorised Crew Member +Authorised Crew Members +authorised personnel +authorised persons +autocoupler electrical connections +automatic +Automatic Coupler +Average +away +axle +Axle Bod +axle box +Axle Box +Axle Load +B. +baby change table +Ballast +Ballast strikes +balr +based +battery +bearings +being +bell +bend +bicycles +blue +body +bodyside +bogie +Bogie +Bogie Conditions +bogies +Bogies +bottom +bounce +bounce test +boundary +brake +brake controller +braking +build quality +button +C. +cab +cable +Cabling and Earth Brush +calculation +call +calls +camera +camera location +cameras +cant +capability +capacity +capital spares +car +Car +cars +Cars +case +casting +cat +Category-1b Train +CCTV +CCTV cameras +CCTV system storage +character +chemical substances +clauses +clear +clearances +climate +climate requirements +closing +coefficient of friction +colour +combined +comfort +Commencement +communication +company +comparable +compared +compatible +complete +completely +components +compressed air +Compressed Air Supply +concurrently +condition +condition +conditions +configuration +connections +connectivity +considering +contact +control +control panels +conversely +converters +cores +Coupling Faces +cover +coverage +covers +cow +cows +crane +crew +crew. +Crew +crew cab door +Crew calls +Crew-Only Accessible Panel +critical +Critical Speed +Crush Load +cubic metres +cups +current +curve stability test +cyclists +D. +damage +damper +data +data storage +date +day +days +dB(A) LpAFmax +DCS 1800 Frequency Band +Dead Mass +decals +deficiency +defined +deflated +deflating +degC +degraded +degrees +degrees of freedom +departure +deployment +design +Design +Design Category C-I +design life +Design Life +destination +detail +details +detection +developed +device +devices +diameter +different +differentiate +direction +direct solar heat transmission +dispatch +distance +Distance +dog +door +doors +doorways +downloadable +draught +draught screen +drawings +drinking fountain +drinking fountains +drinks +driver +Driver +drivers ear +drivers workstation +driving +drop down table +drop down tables +dry conditions +DSAPT +DTS Area Numbers +Duggan Method +E. +ears +Earth Brush +Earth Brush +ease +edge +effluent +egress +EIRENE Functional Numbers +electrical +electrical power +Electric Traction and Brake +electro-dynamic +electromotive force +emergency +emergency brake +Emergency Brakes +Emergency Services +EN 14752 +EN 15227 +end +End Detrainment System +engagement +enter +envelope +environmental +environmental conditions +Environmental Conditions +equipment +equivalent +etching +ETCS level 2 operation +evacuation +event +event recorder +events +exceptional +Exceptional Payload +Exceptional Pay Load +existing +existing intercity trains +Existing Tanking Facilities +exposed +exterior +external +external passenger information displays +facilities +facility +factor +failure +failures of self-tests should be recorded in the train-borne recorder +fasteners +fault +faults +film +finishes +fire +fire and smoke detection system (NIF_RSS_460). +first +fish +flexible +flood +flooring +floors +following +Forward call to the driver handportable +forward facing +four +four-hour maintenance window +fourth +frame +freedom +freight +freight traffic +fresh air intake dampers +Fresh Air Intake Dampers +From +fruit +full-duplex +funtional +future +g +gangway +gangways +gap +Gavin +Gearbox +gear hanger bracket +generated +geographical location +glass +grabrails +graffiti +green +ground +groups +GSM-R Train radio equipment +GUS +hail stones +handrails +heights +hello +High Speed Boards +high voltage +holding brake +hook +hooks +hoses +hours +Hunter Rail Car +Hunting +identical +identification +identity +image +images +In +incapacitated +incorporates +index +individuals +information +infrared +initial +Initiate automated request +input +inserting +intercar access doors +inter-car connections +intercar jumper +interchangeable +intercom +interface +interior +intermediate +Intermediate Cars +intermittent noises +internal +internal noise +internal passenger information display +internal tonal noise +international standards +internet +interval +intervention +isolated +items +joints +kg +kg/m2 +kilo +kilograms +kinematic +km +km/h +kN +ladder +ladders +Landing Edge +lateral +Lathe +Leading Edge +legible +legislation. +length +letters +level +levels +life +lifting +lifting points +line +liner(s) +Line Speed +liquid +list +live OHLE +load +location +Location information +locations +lock +logo +Long Distance Train +Long Train +Long Unit +lower deck +lowered +low-level +luggage +luminous transmittance +m2 +magnetic particle testing +Maintainer +Maintainers +maintenance +Maintenance Facility +major +management +manual +manually +manufactured +mass +material +materials +maximum +Maximum +Maximum Design Speed +maximum safe operating speed +Maximum Safe Operating Speed +Maximum Service Speed +MDBF +Mean Comfort Complete Method +mechanical +Mechanical Brakes +medical +medical devices +Medium Electric Outline +member +members +messages +methods +metres +MetroNet Transponder System +minimum +Minimum Operating Standards +minute +minutes +mm +MMT +mobile telecommunication network +mode +More +MOS +Motor Bogie +movements +MTTR +n +name +nearest +network +Network +Network Re-railing facility +new +New +newton +next +night. +NN +noise +nominated MMT tasks +Non-destructive test +non-receptive network +normal +Normal Seats +normal use +NSW Digital Train Radio System (DTRS) +obstruction +occupant +odours +office +OHW Current Draw Limit +OHW Current Limited Zone +OHW Current Return Limit +onboard +one +open +opening +operable +operating +operating speed +operation +operational spares +Operator +OPEX +orange +OSCar +OSCar Motor Bogie +OSCar Trailer Bogie +Other Elastomer components +otherwise +OTR +outlet +output +overhaul +overhead +Overhead Crane +Overhead Power Supply Harmonics +P2 force +pad +pairs +panels +parking brake +passage +passenger +passenger bodyside door +Passenger Bodyside Door +Passenger Bodyside Doors +passenger ears +passenger information system +passenger loading +passengers +passengers ear +passenger services +path +paths +payload +Payload Conditions +Peak Heat Release Rate +performance +performed +permitted +person +persons +photo luminescent +pitch +Plan +planned +platform +platforms +Pneumatic +points +pony bogie +Pony Bogie +portable +portal +position +possible +power +power cable +power distribution panel +practicable +Preparation +pre-recorded +presentation +primary +Primary Controller +Primary Suspension +priority +Priority +procedures +profile +Prohibited Items +protective +proven +provision +psi +public address announcements +public address system +push-button +quality +Quality Assurance system +radio +Radio faults +radius +rail +Rail Emergency Train Recovery Unit +rail network +Rail Safety National Law +rain +raised +rate +ready +real time +real-time +rear +rear pasenger door +recessed region +recorder +recovered +recovery +recovery. +rectification +red +reduce +Reference Masses +reflectance +regenerative mode +rejection +relevant +remain +remote +remotely +removable +required +requirement +requirements +re-railing +reservoir +resonance +restraints +results +RETRU +rheostatic mode +ride +Ride Comfort Index +robust interior fittings +route +rows +running +running times +safe +safe operating speed +Safety Device +Safety Management System +saloon +Scharfenberg Type-10 Coupler +schedule +Schedule of Finishes +scratching +screens +sdfsdf +seat +seated +seating +seats +second +Secondary +seconds +Section 13.3.2.2 of AS 7533.3 +Section-2-1-1-3 +Section 4.1.1.1 of EN 14752 +Section 5.2.1.4 of EN 14752 +Section 6.5 of GM/RT 2100 +Section-8.3 +secure +securing mechanism +Selective Door Operation +separation +service +Serviceable +Service Type B +servicing +shear +shear pad casting +Short Train +Short Unit +side +sides +sign +signage +signs +similar +simultaneous +situations +slip resistant surfaces +slogan +smart card +smart cards +socket +solution +sound +spaces +spare +special tools +specific +specification +speech transmission index +speed +speeding +spreader +spreader beam +spring +stable +staff members +stakeholder +standard +standard toilet +standees +standing +Standing Area +Standing Area Calculation +Standing Passenger Density +startup +static +Static Rolling Stock Outline +station +stationary +status +steps +stiffness +stopping +Stopping Pattern +storage +stove +strategy +strength +stretcher +subsystem +sub-system +sub-systems +suitable +sunlight +super +supplier +Supplier +surface +surface finish +surfing +suspension +Suspension +suspensions +Sustained +swept path +Sydney Trains +Sydney Trains Washplants +synchronised +system +systems +table +tailored +tampering +tangent +tanks +TBD +temperature +Terminal End +termination +test +Test Routes +tests +text +TfNSW +TfNSW +TfNSW External Livery Principles for 'NSW Trains' +TfNSW Internal Decal Approach for 'Trains' or 'NSW Trains' +than +third +third party freight services +through +T HR RS 00100 ST +T HR RS 08001 ST +T HR RS 12001 ST +T HR TE 41001 +T HR TE 41002 +T HR TE 81001 +T HR TE 81002 +time +Timetable +Timetable. +Tip Up Seats +TMS +T MU RS 01000 ST for P-II vehicles +toilet +toilets +tolerances +ton +tonnes +total solar energy rejection +track +Track +track cant deficiency +Track Gauge +traction +traction equipment +Traction Motor +traffic +Trailer Bogie +trailing edge +Trailing Edge +train +train +Train +Train Controller +Train Management System +Train Protection and Security +trains +transmission +transverse +transverse seats +travel +trespasser +Trip Codes +Trip Gear +tunnels +tyjhgdyfhukfhk +ultrasonic testing +underframe +unique car identification +Unit +unloading +unrestricted +update +upper deck +upright +USB socket +use +used +user decisions +user groups +users +UV +VAC +vandalism +vehicle +Vehicle Body +vehicles +vertical +vestibule +vision impairment +visual and audible alarm +volume +warning +warranty spares +washplant +waste +water +weather conditions +weekday +weld +Weld +Welding +weld quality +wet conditions +wheel +Wheel +wheelchair +wheelchairs +wheel-rail adhesion modifiers +wheel slide +wheel slip +width +window +windowr +windows +wire +work +workshop +Workstation +worn +xxxx1 +yaw +year +years +yellow|] + diff --git a/bench/Search.hs b/bench/Search.hs new file mode 100644 --- /dev/null +++ b/bench/Search.hs @@ -0,0 +1,935 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +import Control.DeepSeq +import Criterion.Main +import qualified Data.Attoparsec.Text as A +import qualified Data.RadixTree as R +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Text.QuasiText + +searchNaiive :: [Text] -> Text -> [Text] +searchNaiive src t = go src + where + go [] = [] + go (x:xs) = + if x `T.isInfixOf` t + then x : go xs + else go xs + +main :: IO () +main = defaultMain + [ env (return (source, sourceRadixCompressed, tests0)) $ \ + ~(src, radix, tests) -> + bgroup "search" + [ bench "radixtree" $ + V.foldl' (\() t -> rnf $ A.parseOnly (R.search radix) t) () `nf` tests + , bench "repeated isInfixOf" $ + V.foldl' (\() t -> rnf $ searchNaiive src t) () `nf` tests + ] + ] + +tests0 :: V.Vector Text +tests0 = V.fromList $! T.lines + "acceleration\n\ + \acceleration, braking or coasting\n\ + \axle\n\ + \AAA\n\ + \2+2 seating\n\ + \long thing that doesn't parse\n\ + \z" + +sourceRadixCompressed :: R.CompressedRadixTree +sourceRadixCompressed = + case R.compressBy (T.concat source) sourceRadix of + Just ct -> ct + Nothing -> error "could not compress source" + +sourceRadix :: R.RadixTree +sourceRadix = R.fromFoldable source + +source :: [Text] +source = T.lines [embed| +% ++/- +2+2 seating +A. +AAA +AAR-10A Contoured Coupler +able +able-bodied +AC auxiliary power +accelerating, braking or coasting +acceleration +access +accessible +accessible toilet +accidental operation +accordance +accreditation +accumulate +accuracy +action +activation +active +activities +Adapter Coupling +adjacent +adjust +adverse +air +air pressure +Air Spring +air suspension +aisle +alarm +alerts +aligned +allocated +Alpha-Numeric Trip Codes +alternative +aluminium +announcements +apples +apportioned +appropriate +approval +approved +area calculation +armrests +arrival +ASA standards +asdf +asdff +Asset Information System +assistive listening +attack +audio +Australian +Authorised Crew Member +Authorised Crew Members +authorised personnel +authorised persons +autocoupler electrical connections +automatic +Automatic Coupler +Average +away +axle +Axle Bod +axle box +Axle Box +Axle Load +B. +baby change table +Ballast +Ballast strikes +balr +based +battery +bearings +being +bell +bend +bicycles +blue +body +bodyside +bogie +Bogie +Bogie Conditions +bogies +Bogies +bottom +bounce +bounce test +boundary +brake +brake controller +braking +build quality +button +C. +cab +cable +Cabling and Earth Brush +calculation +call +calls +camera +camera location +cameras +cant +capability +capacity +capital spares +car +Car +cars +Cars +case +casting +cat +Category-1b Train +CCTV +CCTV cameras +CCTV system storage +character +chemical substances +clauses +clear +clearances +climate +climate requirements +closing +coefficient of friction +colour +combined +comfort +Commencement +communication +company +comparable +compared +compatible +complete +completely +components +compressed air +Compressed Air Supply +concurrently +condition +condition +conditions +configuration +connections +connectivity +considering +contact +control +control panels +conversely +converters +cores +Coupling Faces +cover +coverage +covers +cow +cows +crane +crew +crew. +Crew +crew cab door +Crew calls +Crew-Only Accessible Panel +critical +Critical Speed +Crush Load +cubic metres +cups +current +curve stability test +cyclists +D. +damage +damper +data +data storage +date +day +days +dB(A) LpAFmax +DCS 1800 Frequency Band +Dead Mass +decals +deficiency +defined +deflated +deflating +degC +degraded +degrees +degrees of freedom +departure +deployment +design +Design +Design Category C-I +design life +Design Life +destination +detail +details +detection +developed +device +devices +diameter +different +differentiate +direction +direct solar heat transmission +dispatch +distance +Distance +dog +door +doors +doorways +downloadable +draught +draught screen +drawings +drinking fountain +drinking fountains +drinks +driver +Driver +drivers ear +drivers workstation +driving +drop down table +drop down tables +dry conditions +DSAPT +DTS Area Numbers +Duggan Method +E. +ears +Earth Brush +Earth Brush +ease +edge +effluent +egress +EIRENE Functional Numbers +electrical +electrical power +Electric Traction and Brake +electro-dynamic +electromotive force +emergency +emergency brake +Emergency Brakes +Emergency Services +EN 14752 +EN 15227 +end +End Detrainment System +engagement +enter +envelope +environmental +environmental conditions +Environmental Conditions +equipment +equivalent +etching +ETCS level 2 operation +evacuation +event +event recorder +events +exceptional +Exceptional Payload +Exceptional Pay Load +existing +existing intercity trains +Existing Tanking Facilities +exposed +exterior +external +external passenger information displays +facilities +facility +factor +failure +failures of self-tests should be recorded in the train-borne recorder +fasteners +fault +faults +film +finishes +fire +fire and smoke detection system (NIF_RSS_460). +first +fish +flexible +flood +flooring +floors +following +Forward call to the driver handportable +forward facing +four +four-hour maintenance window +fourth +frame +freedom +freight +freight traffic +fresh air intake dampers +Fresh Air Intake Dampers +From +fruit +full-duplex +funtional +future +g +gangway +gangways +gap +Gavin +Gearbox +gear hanger bracket +generated +geographical location +glass +grabrails +graffiti +green +ground +groups +GSM-R Train radio equipment +GUS +hail stones +handrails +heights +hello +High Speed Boards +high voltage +holding brake +hook +hooks +hoses +hours +Hunter Rail Car +Hunting +identical +identification +identity +image +images +In +incapacitated +incorporates +index +individuals +information +infrared +initial +Initiate automated request +input +inserting +intercar access doors +inter-car connections +intercar jumper +interchangeable +intercom +interface +interior +intermediate +Intermediate Cars +intermittent noises +internal +internal noise +internal passenger information display +internal tonal noise +international standards +internet +interval +intervention +isolated +items +joints +kg +kg/m2 +kilo +kilograms +kinematic +km +km/h +kN +ladder +ladders +Landing Edge +lateral +Lathe +Leading Edge +legible +legislation. +length +letters +level +levels +life +lifting +lifting points +line +liner(s) +Line Speed +liquid +list +live OHLE +load +location +Location information +locations +lock +logo +Long Distance Train +Long Train +Long Unit +lower deck +lowered +low-level +luggage +luminous transmittance +m2 +magnetic particle testing +Maintainer +Maintainers +maintenance +Maintenance Facility +major +management +manual +manually +manufactured +mass +material +materials +maximum +Maximum +Maximum Design Speed +maximum safe operating speed +Maximum Safe Operating Speed +Maximum Service Speed +MDBF +Mean Comfort Complete Method +mechanical +Mechanical Brakes +medical +medical devices +Medium Electric Outline +member +members +messages +methods +metres +MetroNet Transponder System +minimum +Minimum Operating Standards +minute +minutes +mm +MMT +mobile telecommunication network +mode +More +MOS +Motor Bogie +movements +MTTR +n +name +nearest +network +Network +Network Re-railing facility +new +New +newton +next +night. +NN +noise +nominated MMT tasks +Non-destructive test +non-receptive network +normal +Normal Seats +normal use +NSW Digital Train Radio System (DTRS) +obstruction +occupant +odours +office +OHW Current Draw Limit +OHW Current Limited Zone +OHW Current Return Limit +onboard +one +open +opening +operable +operating +operating speed +operation +operational spares +Operator +OPEX +orange +OSCar +OSCar Motor Bogie +OSCar Trailer Bogie +Other Elastomer components +otherwise +OTR +outlet +output +overhaul +overhead +Overhead Crane +Overhead Power Supply Harmonics +P2 force +pad +pairs +panels +parking brake +passage +passenger +passenger bodyside door +Passenger Bodyside Door +Passenger Bodyside Doors +passenger ears +passenger information system +passenger loading +passengers +passengers ear +passenger services +path +paths +payload +Payload Conditions +Peak Heat Release Rate +performance +performed +permitted +person +persons +photo luminescent +pitch +Plan +planned +platform +platforms +Pneumatic +points +pony bogie +Pony Bogie +portable +portal +position +possible +power +power cable +power distribution panel +practicable +Preparation +pre-recorded +presentation +primary +Primary Controller +Primary Suspension +priority +Priority +procedures +profile +Prohibited Items +protective +proven +provision +psi +public address announcements +public address system +push-button +quality +Quality Assurance system +radio +Radio faults +radius +rail +Rail Emergency Train Recovery Unit +rail network +Rail Safety National Law +rain +raised +rate +ready +real time +real-time +rear +rear pasenger door +recessed region +recorder +recovered +recovery +recovery. +rectification +red +reduce +Reference Masses +reflectance +regenerative mode +rejection +relevant +remain +remote +remotely +removable +required +requirement +requirements +re-railing +reservoir +resonance +restraints +results +RETRU +rheostatic mode +ride +Ride Comfort Index +robust interior fittings +route +rows +running +running times +safe +safe operating speed +Safety Device +Safety Management System +saloon +Scharfenberg Type-10 Coupler +schedule +Schedule of Finishes +scratching +screens +sdfsdf +seat +seated +seating +seats +second +Secondary +seconds +Section 13.3.2.2 of AS 7533.3 +Section-2-1-1-3 +Section 4.1.1.1 of EN 14752 +Section 5.2.1.4 of EN 14752 +Section 6.5 of GM/RT 2100 +Section-8.3 +secure +securing mechanism +Selective Door Operation +separation +service +Serviceable +Service Type B +servicing +shear +shear pad casting +Short Train +Short Unit +side +sides +sign +signage +signs +similar +simultaneous +situations +slip resistant surfaces +slogan +smart card +smart cards +socket +solution +sound +spaces +spare +special tools +specific +specification +speech transmission index +speed +speeding +spreader +spreader beam +spring +stable +staff members +stakeholder +standard +standard toilet +standees +standing +Standing Area +Standing Area Calculation +Standing Passenger Density +startup +static +Static Rolling Stock Outline +station +stationary +status +steps +stiffness +stopping +Stopping Pattern +storage +stove +strategy +strength +stretcher +subsystem +sub-system +sub-systems +suitable +sunlight +super +supplier +Supplier +surface +surface finish +surfing +suspension +Suspension +suspensions +Sustained +swept path +Sydney Trains +Sydney Trains Washplants +synchronised +system +systems +table +tailored +tampering +tangent +tanks +TBD +temperature +Terminal End +termination +test +Test Routes +tests +text +TfNSW +TfNSW +TfNSW External Livery Principles for 'NSW Trains' +TfNSW Internal Decal Approach for 'Trains' or 'NSW Trains' +than +third +third party freight services +through +T HR RS 00100 ST +T HR RS 08001 ST +T HR RS 12001 ST +T HR TE 41001 +T HR TE 41002 +T HR TE 81001 +T HR TE 81002 +time +Timetable +Timetable. +Tip Up Seats +TMS +T MU RS 01000 ST for P-II vehicles +toilet +toilets +tolerances +ton +tonnes +total solar energy rejection +track +Track +track cant deficiency +Track Gauge +traction +traction equipment +Traction Motor +traffic +Trailer Bogie +trailing edge +Trailing Edge +train +train +Train +Train Controller +Train Management System +Train Protection and Security +trains +transmission +transverse +transverse seats +travel +trespasser +Trip Codes +Trip Gear +tunnels +tyjhgdyfhukfhk +ultrasonic testing +underframe +unique car identification +Unit +unloading +unrestricted +update +upper deck +upright +USB socket +use +used +user decisions +user groups +users +UV +VAC +vandalism +vehicle +Vehicle Body +vehicles +vertical +vestibule +vision impairment +visual and audible alarm +volume +warning +warranty spares +washplant +waste +water +weather conditions +weekday +weld +Weld +Welding +weld quality +wet conditions +wheel +Wheel +wheelchair +wheelchairs +wheel-rail adhesion modifiers +wheel slide +wheel slip +width +window +windowr +windows +wire +work +workshop +Workstation +worn +xxxx1 +yaw +year +years +yellow|] + diff --git a/radixtree.cabal b/radixtree.cabal new file mode 100644 --- /dev/null +++ b/radixtree.cabal @@ -0,0 +1,75 @@ +name: radixtree +version: 0.4.0.0 +description: A prefix-tree parsing library +homepage: https://gitlab.com/transportengineering/radixtree +license: BSD3 +license-file: LICENSE +author: Mike Ledger +maintainer: mike@quasimal.com +copyright: 2018 Mike Ledger +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Data.RadixTree + build-depends: base >= 4.7 && < 5 + , containers >= 0.5 + , vector + , text + , deepseq + , microlens + , parsers >= 0.12 + , store >= 0.4 + , mtl >= 2.0 + default-language: Haskell2010 + +benchmark radixtree-parsing + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Parsing.hs + ghc-options: -O2 + build-depends: base + , radixtree + , text + , QuasiText + , criterion + , attoparsec + , deepseq + , vector + default-language: Haskell2010 + + +benchmark radixtree-search + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Search.hs + ghc-options: -O2 + build-depends: base + , radixtree + , text + , QuasiText + , criterion + , attoparsec + , deepseq + , vector + default-language: Haskell2010 + +test-suite radixtree-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , radixtree + , attoparsec + , smallcheck + , tasty + , tasty-smallcheck + , text + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://gitlab.com/tranpsortengineering/radixtree diff --git a/src/Data/RadixTree.hs b/src/Data/RadixTree.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixTree.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.RadixTree + ( RadixTree (..) + , RadixNode (..) + , CompressedRadixTree + -- * Construction + , fromFoldable + , compressBy + -- * Parsing with radix trees + , RadixParsing (..) + , search + ) where +import Control.Applicative +import Control.DeepSeq +import Data.Data (Data, Typeable) +import Data.Foldable (asum, foldr', toList) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Monoid +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Store () +import Data.Store.TH (makeStore) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Array as TI (Array) +import qualified Data.Text.Internal as TI (Text (..), text) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Lens.Micro +import Text.Parser.Char (CharParsing (anyChar, text)) +import Text.Parser.Combinators (Parsing (try)) + +-------------------------------------------------------------------------------- +-- Stuff to help construct RadixTrees +-- +-- I'm not clever enough to write a function to go directly from a 'Foldable' to +-- a fully-optimised RadixTree. Instead, I generate a prefix-tree using a 'Map' +-- directly ('Trie'), and then gradually compress that ('CompressedTrie') before +-- packing the final result into an efficient structure using 'Text' nodes. +-- +-- TODO: +-- - generate RadixTree directly, instead of going through 'Trie'/'CompressedTrie' +-- - use compact regions? + +data PrefixNode a = Accept !Text !a | Skip !a + deriving (Show, Eq) + +newtype Trie = Trie (PrefixNode (Map Char Trie)) + deriving (Show, Eq) + +newtype CompressedTrie = CompressedTrie (PrefixNode (Map (Seq Char) CompressedTrie)) + deriving (Show, Eq) + +{-# INLINE node #-} +node :: Lens (PrefixNode a) (PrefixNode b) a b +node = lens + (\x -> case x of { Accept _ t -> t; Skip t -> t }) + (\x a -> case x of { Accept l _ -> Accept l a; Skip _ -> Skip a }) + +leaf :: Text -> Text -> Trie +leaf ft t = go (T.unpack t) + where + go (x:xs) = Trie (Skip (M.singleton x (go xs))) + go [] = Trie (Accept ft M.empty) + +insert :: Text -> Text -> Trie -> Trie +insert ft text' (Trie n) = case T.uncons text' of + Just (c, cs) -> Trie ((node %~ + M.insertWith + (\_ orig -> Data.RadixTree.insert ft cs orig) + c + (leaf ft cs)) n) + Nothing -> + Trie (n^.node.to (Accept ft)) + +makeCompressable :: Trie -> CompressedTrie +makeCompressable (Trie n) = CompressedTrie ( + over node (M.map makeCompressable . M.mapKeysMonotonic Seq.singleton) n) + +compress :: Trie -> CompressedTrie +compress = go . makeCompressable + where + go :: CompressedTrie -> CompressedTrie + go (CompressedTrie n) = case n of + Accept l m -> CompressedTrie (Accept l (M.map go m)) + Skip m -> CompressedTrie (Skip (M.foldMapWithKey compress1 m)) + + compress1 :: Seq Char -> CompressedTrie -> Map (Seq Char) CompressedTrie + compress1 k c@(CompressedTrie n) = + case M.size sm of + 0 -> M.singleton k c + 1 | Skip _ <- n -> compress1 (k <> k') sm' + where (k', sm') = M.findMax sm + _ -> M.singleton k (go (n & node .~ sm & CompressedTrie)) + where sm = n^.node + +-------------------------------------------------------------------------------- + +-- | A node in a radixtree. To advance from here a parser must parse the 'Text' +-- (i.e., the prefix) value at this node. +data RadixNode = RadixNode {-# UNPACK #-} !Text !RadixTree + deriving (Eq, Show, Typeable, Data) + +-- | A radixtree. Construct with 'fromFoldable', and use with 'parse'. +data RadixTree + = -- | Can terminate a parser successfully, returning the 'Text' value given. + RadixAccept + {-# UNPACK #-} !Text -- the final value to return + {-# UNPACK #-} !(Vector RadixNode) -- possible subtrees beyond this point + | RadixSkip + {-# UNPACK #-} !(Vector RadixNode) -- possible subtrees beyond this point + deriving (Eq, Show, Typeable, Data) + +instance NFData RadixNode where + {-# INLINE rnf #-} + rnf (RadixNode l t) = rnf l `seq` rnf t + +instance NFData RadixTree where + {-# INLINE rnf #-} + rnf (RadixAccept t v) = t `seq` rnf v + rnf (RadixSkip v) = rnf v + +-- | Compress a totally-unoptimised 'Trie' into a nice and easily-parsable +-- 'RadixTree' +fromTrie :: Trie -> RadixTree +fromTrie = go . compress + where + !z = V.empty + + radixNode :: Seq Char -> CompressedTrie -> RadixNode + radixNode l t = RadixNode (T.pack (toList l)) (go t) + + mapToVector :: Map k a -> Vector (k, a) + mapToVector m = case M.size m of + 0 -> z + sz -> V.fromListN sz (M.toList m) + + go :: CompressedTrie -> RadixTree + go (CompressedTrie n) = case n of + Accept l m -> RadixAccept l . V.map (uncurry radixNode) . mapToVector $! m + Skip m -> RadixSkip . V.map (uncurry radixNode) . mapToVector $! m + +data TextSlice = TextSlice + { tsOffset16 :: {-# UNPACK #-} !Int -- ^ offset (in units of Word16) + , tsLength16 :: {-# UNPACK #-} !Int -- ^ length (in units of Word16) + } + +-- | Probably dangerous magic +-- +-- When the second argument is found to be within the first, we re-use the +-- 'Text' array of the first. This should allow the second argument to be +-- garbage collected. This is to improve locality and memory use. +magicallySaveSpaceSometimes :: Text -> Text -> Maybe TextSlice +magicallySaveSpaceSometimes full s@(TI.Text _ _ slen) = + case T.breakOn s full of + (TI.Text{}, r@(TI.Text _ remoffs _)) + | T.null r -> Nothing + | otherwise -> Just TextSlice{tsOffset16 = remoffs, tsLength16 = slen} + +-- | A normal 'RadixTree' stores a new 'Text' at every node. In contrast, a +-- 'CompressedRadixTree' takes a single corpus 'Text' which is indexed into by +-- nodes. This can save a lot of memory (e.g., using the radix trees from the +-- parsing benchmarks in this package, the 'CompressedRadixTree' version is +-- 254032 bytes, whereas the ordinary 'RadixTree' is a rotund 709904 bytes) at +-- no runtime cost. +data CompressedRadixTree + = CompressedRadixTree {-# UNPACK #-} !TI.Array !CompressedRadixTree1 + +data CompressedRadixTree1 + = CompressedRadixAccept + {-# UNPACK #-} !TextSlice + {-# UNPACK #-} !(Vector CompressedRadixNode) + | CompressedRadixSkip {-# UNPACK #-} !(Vector CompressedRadixNode) + +data CompressedRadixNode + = CompressedRadixNode {-# UNPACK #-} !TextSlice !CompressedRadixTree1 + +instance NFData CompressedRadixNode where + {-# INLINE rnf #-} + rnf (CompressedRadixNode ts t) = ts `seq` rnf t + +instance NFData CompressedRadixTree where + {-# INLINE rnf #-} + rnf (CompressedRadixTree arr v) = arr `seq` rnf v + +instance NFData CompressedRadixTree1 where + {-# INLINE rnf #-} + rnf (CompressedRadixAccept ts v) = ts `seq` rnf v + rnf (CompressedRadixSkip v) = rnf v + +-- | Compress a 'RadixTree' given a corpus. All values in the tree be findable +-- within the corpus, though the corpus does not have to necessarily be the +-- direct source of the tree +compressBy :: Text -> RadixTree -> Maybe CompressedRadixTree +compressBy full@(TI.Text arr _ _) rt = + CompressedRadixTree arr <$> recompressT rt + + where + magic = magicallySaveSpaceSometimes full + + recompressN :: RadixNode -> Maybe CompressedRadixNode + recompressN (RadixNode t tree) = CompressedRadixNode <$> magic t <*> recompressT tree + + recompressT :: RadixTree -> Maybe CompressedRadixTree1 + recompressT (RadixSkip v) = CompressedRadixSkip <$> V.mapM recompressN v + recompressT (RadixAccept t v) = CompressedRadixAccept <$> magic t <*> V.mapM recompressN v + +-- | *Slow* +fromFoldable :: Foldable f => f Text -> RadixTree +fromFoldable = + fromTrie . foldr' (\t -> insert t t) (Trie (Skip M.empty)) + +makeStore ''RadixNode +makeStore ''RadixTree + +-------------------------------------------------------------------------------- +-- Parsers from 'RadixTree's + +class RadixParsing radixtree where + parse :: CharParsing m => radixtree -> m Text + +{-# INLINE search #-} +-- | Find all occurences of the terms in a 'RadixTree' from this point on. This +-- will consume the entire remaining input. Can lazily produce results (but this +-- depends on your parser). +search :: (Monad m, CharParsing m, RadixParsing radixtree) + => radixtree -> m [Text] +search r = go + where + go = + (parse r >>= \x -> (x:) <$> go) <|> + (anyChar >> go) <|> + return [] + +instance RadixParsing RadixTree where + {-# INLINE parse #-} + -- | Parse from a 'RadixTree' + parse :: CharParsing m => RadixTree -> m Text + parse = go + where + go r = case r of + RadixAccept l nodes + | T.null l -> empty + | otherwise -> asum (V.map parseRadixNode nodes) <|> pure l + RadixSkip nodes -> asum (V.map parseRadixNode nodes) + + {-# INLINE parseRadixNode #-} + parseRadixNode (RadixNode prefix tree) + | T.null prefix = go tree + | otherwise = try (text prefix *> go tree) + +instance RadixParsing CompressedRadixTree where + {-# INLINE parse #-} + -- | Parse from a 'RadixTree' + parse :: CharParsing m => CompressedRadixTree -> m Text + parse (CompressedRadixTree arr crt) = go crt + where + fromSlice (TextSlice offs len) = TI.text arr offs len + + go r = case r of + CompressedRadixAccept ts nodes -> case fromSlice ts of + l | T.null l -> empty + | otherwise -> asum (V.map parseRadixNode nodes) <|> pure l + CompressedRadixSkip nodes -> asum (V.map parseRadixNode nodes) + + {-# INLINE parseRadixNode #-} + parseRadixNode (CompressedRadixNode ts tree) = case fromSlice ts of + prefix | T.null prefix -> go tree + | otherwise -> try (text prefix *> go tree) + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +import Data.Attoparsec.Text +import Data.Coerce +import Data.List (sortOn) +import qualified Data.RadixTree as R +import qualified Data.Text as T +import Test.SmallCheck +import Test.SmallCheck.Series +import Test.Tasty +import Test.Tasty.SmallCheck + +sortOnLengthDesc :: [T.Text] -> [T.Text] +sortOnLengthDesc = sortOn (negate . T.length) + +naiiveSameAsRadix :: Monad m => Bool -> Property m +naiiveSameAsRadix doCompress = + forAll $ \(alternativesS :: NonEmpty (NonEmpty Char)) -> + let + alternatives = sortOnLengthDesc (map T.pack (coerce alternativesS)) + rparse + | doCompress = R.parse $! R.fromFoldable alternatives + | otherwise = case R.compressBy (T.concat alternatives) (R.fromFoldable alternatives) of + Just crt -> R.parse $! crt + Nothing -> error "could not compress radixtree!" + + in forAll $ \(textS :: NonEmpty Char) -> + let text = T.pack (coerce textS) + in parseOnly (choice (map string alternatives)) text == + parseOnly rparse text + +main :: IO () +main = defaultMain $ testGroup "radixtree" + [ testProperty "naiive parsing has the same result as radix tree parsing" (naiiveSameAsRadix False) + , testProperty "naiive parsing has the same result as radix tree parsing when compressed" + (naiiveSameAsRadix True) + ]