web: better ToJSON instances, new FromJSON instances, utilities (#316)

hledger-web/Hledger/Web/Handler/MiscR.hs

@@ -20,13 +20,12 @@ module Hledger.Web.Handler.MiscR
   , getRootR
   ) where
 
-import           Data.Aeson
-import           Data.Decimal
 import qualified Data.Map as M
 import qualified Data.Text as T
 import Yesod.Default.Handlers (getFaviconR, getRobotsR)
 
 import Hledger
+import Hledger.Web.Json ()
 import Hledger.Web.Import
 import Hledger.Web.Widget.Common (journalFile404)
 
@@ -49,47 +48,7 @@ getDownloadR f = do
   addHeader "Content-Disposition" ("attachment; filename=\"" <> T.pack f' <> "\"")
   sendResponse ("text/plain" :: ByteString, toContent txt)
 
--- copied from hledger-api
+-- hledger-web equivalents of hledger-api's handlers
-instance ToJSON Status
-instance ToJSON GenericSourcePos
-instance ToJSON Decimal where toJSON = toJSON . show
-instance ToJSON Amount
-instance ToJSON AmountStyle
-instance ToJSON Side
-instance ToJSON DigitGroupStyle
-instance ToJSON MixedAmount
-instance ToJSON BalanceAssertion
-instance ToJSON Price
-instance ToJSON MarketPrice
-instance ToJSON PostingType
-instance ToJSON Posting where
-  toJSON Posting{..} =
-    object
-    ["pdate"             .= toJSON pdate
-    ,"pdate2"            .= toJSON pdate2
-    ,"pstatus"           .= toJSON pstatus
-    ,"paccount"          .= toJSON paccount
-    ,"pamount"           .= toJSON pamount
-    ,"pcomment"          .= toJSON pcomment
-    ,"ptype"             .= toJSON ptype
-    ,"ptags"             .= toJSON ptags
-    ,"pbalanceassertion" .= toJSON pbalanceassertion
-    ,"ptransactionidx"   .= toJSON (maybe "" (show.tindex) ptransaction)
-    ]
-instance ToJSON Transaction
-instance ToJSON Account where
-  toJSON a =
-    object
-    ["aname"        .= toJSON (aname a)
-    ,"aebalance"    .= toJSON (aebalance a)
-    ,"aibalance"    .= toJSON (aibalance a)
-    ,"anumpostings" .= toJSON (anumpostings a)
-    ,"aboring"      .= toJSON (aboring a)
-    ,"aparentname"  .= toJSON (maybe "" aname $ aparent a)
-    ,"asubs"        .= toJSON (map toJSON $ asubs a)
-    ]
-
--- hledger-web implementations of hledger-api's handlers, keep synced
 
 getAccountnamesR :: Handler TypedContent
 getAccountnamesR = do

hledger-web/Hledger/Web/Json.hs

@@ -0,0 +1,145 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+--{-# LANGUAGE CPP                 #-}
+--{-# LANGUAGE DataKinds           #-}
+--{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveGeneric       #-}
+--{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances   #-}
+--{-# LANGUAGE NamedFieldPuns #-}
+--{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE OverloadedStrings #-}
+--{-# LANGUAGE PolyKinds           #-}
+--{-# LANGUAGE QuasiQuotes         #-}
+--{-# LANGUAGE QuasiQuotes #-}
+--{-# LANGUAGE Rank2Types #-}
+--{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+--{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+--{-# LANGUAGE TemplateHaskell       #-}
+--{-# LANGUAGE TypeFamilies        #-}
+--{-# LANGUAGE TypeOperators       #-}
+
+module Hledger.Web.Json ( 
+  -- * Instances
+  -- * Utilities
+   readJsonFile
+  ,writeJsonFile
+) where
+
+import           Data.Aeson
+--import           Data.Aeson.TH
+import qualified Data.ByteString.Lazy as BL
+import           Data.Decimal
+import           Data.Maybe
+import           GHC.Generics (Generic)
+
+import           Hledger.Data
+
+-- JSON instances. See also hledger-api.
+-- Should they be in hledger-lib Types.hs ?
+
+-- To JSON
+
+instance ToJSON Status
+instance ToJSON GenericSourcePos
+instance ToJSON Decimal
+instance ToJSON Amount
+instance ToJSON AmountStyle
+instance ToJSON Side
+instance ToJSON DigitGroupStyle
+instance ToJSON MixedAmount
+instance ToJSON BalanceAssertion
+instance ToJSON Price
+instance ToJSON MarketPrice
+instance ToJSON PostingType
+instance ToJSON Posting where
+  toJSON Posting{..} = object
+    ["pdate"             .= toJSON pdate
+    ,"pdate2"            .= toJSON pdate2
+    ,"pstatus"           .= toJSON pstatus
+    ,"paccount"          .= toJSON paccount
+    ,"pamount"           .= toJSON pamount
+    ,"pcomment"          .= toJSON pcomment
+    ,"ptype"             .= toJSON ptype
+    ,"ptags"             .= toJSON ptags
+    ,"pbalanceassertion" .= toJSON pbalanceassertion
+    -- To avoid a cycle, show just the parent transaction's index number 
+    -- in a dummy field. When re-parsed, there will be no parent.
+    ,"ptransaction_"     .= toJSON (maybe "" (show.tindex) ptransaction)
+    -- This is probably not wanted in json, we discard it.
+    ,"porigin"           .= toJSON (Nothing :: Maybe Posting) 
+    ]
+instance ToJSON Transaction
+instance ToJSON Account where
+  toJSON a = object
+    ["aname"        .= toJSON (aname a)
+    ,"aebalance"    .= toJSON (aebalance a)
+    ,"aibalance"    .= toJSON (aibalance a)
+    ,"anumpostings" .= toJSON (anumpostings a)
+    ,"aboring"      .= toJSON (aboring a)
+    -- To avoid a cycle, show just the parent account's name 
+    -- in a dummy field. When re-parsed, there will be no parent.
+    ,"aparent_"     .= toJSON (maybe "" aname $ aparent a)
+    -- To avoid a cycle, drop the subaccounts, showing just their names
+    -- in a dummy field. When re-parsed, there will be no subaccounts.
+    ,"asubs"        .= toJSON ([]::[Account])
+    ,"asubs_"       .= toJSON (map aname $ asubs a)
+    ]
+
+-- From JSON
+
+instance FromJSON Status
+instance FromJSON GenericSourcePos
+--
+-- Decimal
+--
+-- https://stackoverflow.com/questions/40331851/haskell-data-decimal-as-aeson-type
+----instance FromJSON Decimal where parseJSON = 
+----  A.withScientific "Decimal" (return . right . eitherFromRational . toRational)
+--
+-- https://github.com/PaulJohnson/Haskell-Decimal/issues/6
+--deriving instance Generic Decimal
+--instance FromJSON Decimal
+deriving instance Generic (DecimalRaw Integer)
+instance FromJSON (DecimalRaw Integer)
+--
+-- https://github.com/bos/aeson/issues/474
+-- http://hackage.haskell.org/package/aeson-1.4.2.0/docs/Data-Aeson-TH.html
+-- $(deriveFromJSON defaultOptions ''Decimal) -- doesn't work
+-- $(deriveFromJSON defaultOptions ''DecimalRaw)  -- works; requires TH, but gives better parse error messages
+--
+instance FromJSON Amount
+instance FromJSON AmountStyle
+instance FromJSON Side
+instance FromJSON DigitGroupStyle
+instance FromJSON MixedAmount
+instance FromJSON BalanceAssertion
+instance FromJSON Price
+instance FromJSON MarketPrice
+instance FromJSON PostingType
+instance FromJSON Posting
+instance FromJSON Transaction
+instance FromJSON AccountDeclarationInfo
+instance FromJSON Account
+
+
+-- Utilities
+
+-- | Read a json from a file and decode/parse it as the target type, if we can.
+-- Example:
+-- >>> readJsonFile "in.json" :: IO MixedAmount
+readJsonFile :: FromJSON a => FilePath -> IO a
+readJsonFile f = do
+  bs <- BL.readFile f
+  let v = fromMaybe (error "could not decode bytestring as json value") (decode bs :: Maybe Value) 
+  case fromJSON v :: FromJSON a => Result a of
+    Error e   -> error e
+    Success t -> return t
+
+-- | Write some to-JSON-convertible haskell value to a json file, if we can.
+-- Example:
+-- >>> writeJsonFile "out.json" nullmixedamt
+writeJsonFile :: ToJSON a => FilePath -> a -> IO ()
+writeJsonFile f v = BL.writeFile f (encode $ toJSON v)

hledger-web/hledger-web.cabal

@@ -139,6 +139,7 @@ library
       Hledger.Web.Handler.RegisterR
       Hledger.Web.Handler.UploadR
       Hledger.Web.Import
+      Hledger.Web.Json
       Hledger.Web.Main
       Hledger.Web.Settings
       Hledger.Web.Settings.StaticFiles

hledger-web/package.yaml

@@ -91,6 +91,7 @@ library:
   - Hledger.Web.Handler.RegisterR
   - Hledger.Web.Handler.UploadR
   - Hledger.Web.Import
+  - Hledger.Web.Json
   - Hledger.Web.Main
   - Hledger.Web.Settings
   - Hledger.Web.Settings.StaticFiles