Merge branch 'perf-polyparse' (early part)

hledger-lib/Hledger/Data/Transaction.hs

@@ -40,7 +40,6 @@ import Data.Time.Calendar
 import Test.HUnit
 import Text.Printf
 import qualified Data.Map as Map
-import Text.Parsec.Pos
 
 import Hledger.Utils
 import Hledger.Data.Types
@@ -56,8 +55,8 @@ instance Show ModifierTransaction where
 instance Show PeriodicTransaction where
     show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t))
 
-nullsourcepos :: SourcePos
-nullsourcepos = initialPos ""
+nullsourcepos :: GenericSourcePos
+nullsourcepos = GenericSourcePos "" 1 1
 
 nulltransaction :: Transaction
 nulltransaction = Transaction {

hledger-lib/Hledger/Data/Types.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving, DeriveGeneric, TypeSynonymInstances, FlexibleInstances #-}
 {-|
 
 Most data types are defined here to avoid import cycles.
@@ -19,6 +19,8 @@ For more detailed documentation on each type, see the corresponding modules.
 
 module Hledger.Data.Types
 where
+import GHC.Generics (Generic)
+import Control.DeepSeq (NFData)
 import Control.Monad.Except (ExceptT)
 import Data.Data
 #ifndef DOUBLE
@@ -29,7 +31,6 @@ import qualified Data.Map as M
 import Data.Time.Calendar
 import Data.Time.LocalTime
 import System.Time (ClockTime(..))
-import Text.Parsec.Pos
 
 import Hledger.Utils.Regex
 
@@ -38,28 +39,29 @@ type SmartDate = (String,String,String)
 
 data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show)
 
-data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Data,Typeable)
+data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Data,Generic,Typeable)
+
+instance NFData DateSpan
 
 data Interval = NoInterval
               | Days Int | Weeks Int | Months Int | Quarters Int | Years Int
               | DayOfMonth Int | DayOfWeek Int
               -- WeekOfYear Int | MonthOfYear Int | QuarterOfYear Int
-                deriving (Eq,Show,Ord,Data,Typeable)
+                deriving (Eq,Show,Ord,Data,Generic,Typeable)
+
+instance NFData Interval
 
 type AccountName = String
 
 data AccountAlias = BasicAlias AccountName AccountName
                   | RegexAlias Regexp Replacement
-  deriving (
-  Eq
-  ,Read
-  ,Show
-  ,Ord
-  ,Data
-  ,Typeable
-  )
+  deriving (Eq, Read, Show, Ord, Data, Generic, Typeable)
 
-data Side = L | R deriving (Eq,Show,Read,Ord,Typeable,Data)
+instance NFData AccountAlias
+
+data Side = L | R deriving (Eq,Show,Read,Ord,Typeable,Data,Generic)
+
+instance NFData Side
 
 type Commodity = String
 
@@ -82,7 +84,9 @@ numberRepresentation = "Decimal"
 
 -- | An amount's price (none, per unit, or total) in another commodity.
 -- Note the price should be a positive number, although this is not enforced.
-data Price = NoPrice | UnitPrice Amount | TotalPrice Amount deriving (Eq,Ord,Typeable,Data)
+data Price = NoPrice | UnitPrice Amount | TotalPrice Amount deriving (Eq,Ord,Typeable,Data,Generic)
+
+instance NFData Price
 
 -- | Display style for an amount.
 data AmountStyle = AmountStyle {
@@ -91,7 +95,9 @@ data AmountStyle = AmountStyle {
       asprecision :: Int,            -- ^ number of digits displayed after the decimal point
       asdecimalpoint :: Maybe Char,  -- ^ character used as decimal point: period or comma. Nothing means "unspecified, use default"
       asdigitgroups :: Maybe DigitGroupStyle -- ^ style for displaying digit groups, if any
-} deriving (Eq,Ord,Read,Show,Typeable,Data)
+} deriving (Eq,Ord,Read,Show,Typeable,Data,Generic)
+
+instance NFData AmountStyle
 
 -- | A style for displaying digit groups in the integer part of a
 -- floating point number. It consists of the character used to
@@ -100,24 +106,34 @@ data AmountStyle = AmountStyle {
 -- the decimal point. The last group size is assumed to repeat. Eg,
 -- comma between thousands is DigitGroups ',' [3].
 data DigitGroupStyle = DigitGroups Char [Int]
-  deriving (Eq,Ord,Read,Show,Typeable,Data)
+  deriving (Eq,Ord,Read,Show,Typeable,Data,Generic)
+
+instance NFData DigitGroupStyle
 
 data Amount = Amount {
       acommodity :: Commodity,
       aquantity :: Quantity,
       aprice :: Price,                -- ^ the (fixed) price for this amount, if any
       astyle :: AmountStyle
-    } deriving (Eq,Ord,Typeable,Data)
+    } deriving (Eq,Ord,Typeable,Data,Generic)
 
-newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Typeable,Data)
+instance NFData Amount
+
+newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Typeable,Data,Generic)
+
+instance NFData MixedAmount
 
 data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting
-                   deriving (Eq,Show,Typeable,Data)
+                   deriving (Eq,Show,Typeable,Data,Generic)
+
+instance NFData PostingType
 
 type Tag = (String, String)  -- ^ A tag name and (possibly empty) value.
 
 data ClearedStatus = Uncleared | Pending | Cleared
-                   deriving (Eq,Ord,Typeable,Data)
+                   deriving (Eq,Ord,Typeable,Data,Generic)
+
+instance NFData ClearedStatus
 
 instance Show ClearedStatus where -- custom show
   show Uncleared = ""             -- a bad idea
@@ -136,15 +152,24 @@ data Posting = Posting {
       pbalanceassertion :: Maybe MixedAmount,  -- ^ optional: the expected balance in the account after this posting
       ptransaction :: Maybe Transaction    -- ^ this posting's parent transaction (co-recursive types).
                                            -- Tying this knot gets tedious, Maybe makes it easier/optional.
-    } deriving (Typeable,Data)
+    } deriving (Typeable,Data,Generic)
+
+instance NFData Posting
 
 -- The equality test for postings ignores the parent transaction's
 -- identity, to avoid infinite loops.
 instance Eq Posting where
     (==) (Posting a1 b1 c1 d1 e1 f1 g1 h1 i1 _) (Posting a2 b2 c2 d2 e2 f2 g2 h2 i2 _) =  a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 && f1==f2 && g1==g2 && h1==h2 && i1==i2
 
+-- | The position of parse errors (eg), like parsec's SourcePos but generic.
+-- File name, 1-based line number and 1-based column number.
+data GenericSourcePos = GenericSourcePos FilePath Int Int
+  deriving (Eq, Read, Show, Ord, Data, Generic, Typeable)
+
+instance NFData GenericSourcePos
+
 data Transaction = Transaction {
-      tsourcepos :: SourcePos,
+      tsourcepos :: GenericSourcePos,
       tdate :: Day,
       tdate2 :: Maybe Day,
       tstatus :: ClearedStatus,
@@ -154,33 +179,45 @@ data Transaction = Transaction {
       ttags :: [Tag], -- ^ tag names and values, extracted from the comment
       tpostings :: [Posting],            -- ^ this transaction's postings
       tpreceding_comment_lines :: String -- ^ any comment lines immediately preceding this transaction
-    } deriving (Eq,Typeable,Data)
+    } deriving (Eq,Typeable,Data,Generic)
+
+instance NFData Transaction
 
 data ModifierTransaction = ModifierTransaction {
       mtvalueexpr :: String,
       mtpostings :: [Posting]
-    } deriving (Eq,Typeable,Data)
+    } deriving (Eq,Typeable,Data,Generic)
+
+instance NFData ModifierTransaction
 
 data PeriodicTransaction = PeriodicTransaction {
       ptperiodicexpr :: String,
       ptpostings :: [Posting]
-    } deriving (Eq,Typeable,Data)
+    } deriving (Eq,Typeable,Data,Generic)
 
-data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data)
+instance NFData PeriodicTransaction
+
+data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data,Generic)
+
+instance NFData TimeLogCode
 
 data TimeLogEntry = TimeLogEntry {
-      tlsourcepos :: SourcePos,
+      tlsourcepos :: GenericSourcePos,
       tlcode :: TimeLogCode,
       tldatetime :: LocalTime,
       tlaccount :: String,
       tldescription :: String
-    } deriving (Eq,Ord,Typeable,Data)
+    } deriving (Eq,Ord,Typeable,Data,Generic)
+
+instance NFData TimeLogEntry
 
 data MarketPrice = MarketPrice {
       mpdate :: Day,
       mpcommodity :: Commodity,
       mpamount :: Amount
-    } deriving (Eq,Ord,Typeable,Data) -- & Show (in Amount.hs)
+    } deriving (Eq,Ord,Typeable,Data,Generic) -- & Show (in Amount.hs)
+
+instance NFData MarketPrice
 
 type Year = Integer
 
@@ -195,10 +232,15 @@ data JournalContext = Ctx {
                                         --   specified with "account" directive(s). Concatenated, these
                                         --   are the account prefix prepended to parsed account names.
     , ctxAliases   :: ![AccountAlias]   -- ^ the current list of account name aliases in effect
-    } deriving (Read, Show, Eq, Data, Typeable)
+    } deriving (Read, Show, Eq, Data, Typeable, Generic)
+
+instance NFData JournalContext
 
 deriving instance Data (ClockTime)
 deriving instance Typeable (ClockTime)
+deriving instance Generic (ClockTime)
+
+instance NFData ClockTime
 
 data Journal = Journal {
       jmodifiertxns :: [ModifierTransaction],
@@ -214,7 +256,9 @@ data Journal = Journal {
                                             -- order encountered.
       filereadtime :: ClockTime,            -- ^ when this journal was last read from its file(s)
       jcommoditystyles :: M.Map Commodity AmountStyle  -- ^ how to display amounts in each commodity
-    } deriving (Eq, Typeable, Data)
+    } deriving (Eq, Typeable, Data, Generic)
+
+instance NFData Journal
 
 -- | A JournalUpdate is some transformation of a Journal. It can do I/O or
 -- raise an error.

hledger-lib/Hledger/Read/CsvReader.hs

@@ -51,7 +51,7 @@ import Text.Printf (hPrintf,printf)
 import Hledger.Data
 import Hledger.Utils.UTF8IOCompat (getContents)
 import Hledger.Utils
-import Hledger.Read.JournalReader (amountp, statusp)
+import Hledger.Read.JournalReader (amountp, statusp, genericSourcePos)
 
 
 reader :: Reader
@@ -643,7 +643,7 @@ transactionFromCsvRecord sourcepos rules record = t
 
     -- build the transaction
     t = nulltransaction{
-      tsourcepos               = sourcepos,
+      tsourcepos               = genericSourcePos sourcepos,
       tdate                    = date',
       tdate2                   = mdate2',
       tstatus                  = status,

hledger-lib/Hledger/Read/JournalReader.hs

@@ -22,6 +22,7 @@ module Hledger.Read.JournalReader (
   reader,
   -- * Parsers used elsewhere
   parseJournalWith,
+  genericSourcePos,
   getParentAccount,
   journal,
   directive,
@@ -97,6 +98,9 @@ parse _ = parseJournalWith journal
 
 -- parsing utils
 
+genericSourcePos :: SourcePos -> GenericSourcePos
+genericSourcePos p = GenericSourcePos (sourceName p) (sourceLine p) (sourceColumn p)
+
 -- | Flatten a list of JournalUpdate's into a single equivalent one.
 combineJournalUpdates :: [JournalUpdate] -> JournalUpdate
 combineJournalUpdates us = liftM (foldl' (\acc new x -> new (acc x)) id) $ sequence us
@@ -366,7 +370,7 @@ periodictransaction = do
 transaction :: ParsecT [Char] JournalContext (ExceptT String IO) Transaction
 transaction = do
   -- ptrace "transaction"
-  sourcepos <- getPosition
+  sourcepos <- genericSourcePos <$> getPosition
   date <- datep <?> "transaction"
   edate <- optionMaybe (secondarydatep date) <?> "secondary date"
   lookAhead (spacenonewline <|> newline) <?> "whitespace or newline"
@@ -481,7 +485,7 @@ datep :: Stream [Char] m t => ParsecT [Char] JournalContext m Day
 datep = do
   -- hacky: try to ensure precise errors for invalid dates
   -- XXX reported error position is not too good
-  -- pos <- getPosition
+  -- pos <- genericSourcePos <$> getPosition
   datestr <- many1 $ choice' [digit, datesepchar]
   let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
   when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr

hledger-lib/Hledger/Read/TimelogReader.hs

@@ -61,7 +61,7 @@ import Hledger.Data
 -- XXX too much reuse ?
 import Hledger.Read.JournalReader (
   directive, marketpricedirective, defaultyeardirective, emptyorcommentlinep, datetimep,
-  parseJournalWith, modifiedaccountname
+  parseJournalWith, modifiedaccountname, genericSourcePos
   )
 import Hledger.Utils
 
@@ -103,7 +103,7 @@ timelogFile = do items <- many timelogItem
 -- | Parse a timelog entry.
 timelogentry :: ParsecT [Char] JournalContext (ExceptT String IO) TimeLogEntry
 timelogentry = do
-  sourcepos <- getPosition
+  sourcepos <- genericSourcePos <$> getPosition
   code <- oneOf "bhioO"
   many1 spacenonewline
   datetime <- datetimep

hledger-lib/hledger-lib.cabal

@@ -57,6 +57,7 @@ library
     , containers
     , csv
     , Decimal
+    , deepseq
     , directory
     , filepath
     , mtl
@@ -128,6 +129,7 @@ test-suite tests
     , containers
     , csv
     , Decimal
+    , deepseq
     , directory
     , filepath
     , mtl

hledger-lib/package.yaml

@@ -55,6 +55,7 @@ dependencies:
   - containers
   - csv
   - Decimal
+  - deepseq
   - directory
   - filepath
   - mtl