{-# LANGUAGE TupleSections #-}
module Hcompta.CLI.Args where
-import Control.Monad (Monad(..), liftM)
-import Data.List (map, foldl')
+import Control.Monad (Monad(..))
+import Data.Function ((.))
+import qualified Data.List as List
+import Data.Monoid ((<>))
+import Data.Functor ((<$>))
import Data.String (String)
import qualified Data.Text.Lazy as TL
-import Prelude (($), (.), IO)
import System.Console.GetOpt
( getOpt
, ArgOrder(..)
, OptDescr(..)
)
+import System.IO (IO)
+import qualified Text.WalderLeijen.ANSI.Text as W
import Hcompta.CLI.Context (Context)
import qualified Hcompta.CLI.Write as Write
-import Hcompta.Lib.Leijen ((<>))
-import qualified Hcompta.Lib.Leijen as W
type Options context
= [OptDescr (context -> IO context)]
-> IO (c, [String])
parse c usage options (ctx, args) =
case getOpt RequireOrder (options c) args of
- (parsers, cmds, []) -> do
- liftM (, cmds) $
- Data.List.foldl' (>>=) (return ctx) parsers
- (_, _, errs) -> do
- usage c >>= Write.fatal c .
- (W.vsep (map (W.text . TL.pack) errs) <>) .
+ (parsers, cmds, []) ->
+ (, cmds) <$>
+ List.foldl' (>>=) (return ctx) parsers
+ (_, _, errs) ->
+ usage c >>=
+ Write.fatal c .
+ (W.vsep (W.text . TL.pack <$> errs) <>) .
W.text . TL.pack
import System.Environment (getProgName)
import System.Exit (exitSuccess)
import qualified System.IO as IO
+import qualified Text.WalderLeijen.ANSI.Text as W
import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Command.Balance as Command.Balance
-import qualified Hcompta.CLI.Command.GL as Command.GL
-import qualified Hcompta.CLI.Command.Journal as Command.Journal
+-- import qualified Hcompta.CLI.Command.Balance as Command.Balance
+-- import qualified Hcompta.CLI.Command.GL as Command.GL
+-- import qualified Hcompta.CLI.Command.Journal as Command.Journal
import qualified Hcompta.CLI.Command.Journals as Command.Journals
-import qualified Hcompta.CLI.Command.Stats as Command.Stats
+-- import qualified Hcompta.CLI.Command.Stats as Command.Stats
-- import qualified Hcompta.CLI.Command.Tags as Command.Tags
import qualified Hcompta.CLI.Context as C
import qualified Hcompta.CLI.Lang as Lang
import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Lib.Leijen as W
usage :: C.Context -> IO String
usage c = do
bin <- getProgName
- return $ unlines $
- [ C.translate c Lang.Section_Syntax
- , " "++bin++" "++C.translate c Lang.Help_Synopsis
- , ""
- , usageInfo (C.translate c Lang.Section_Options) (options c)
- , C.translate c Lang.Section_Commands
- , " [bal|balance] "++C.translate c Lang.Help_Command_Balance
- , " [gl|general_ledger] "++C.translate c Lang.Help_Command_General_Ledger
- , " [j|journal] "++C.translate c Lang.Help_Command_Journal
- , " [js|journals] "++C.translate c Lang.Help_Command_Journals
- , " stats "++C.translate c Lang.Help_Command_Stats
- , " tags "++C.translate c Lang.Help_Command_Tags
- ]
+ return $ unlines
+ [ C.translate c Lang.Section_Syntax
+ , " "++bin++" "++C.translate c Lang.Help_Synopsis
+ , ""
+ , usageInfo (C.translate c Lang.Section_Options) (options c)
+ , C.translate c Lang.Section_Commands
+ , " [bal|balance] "++C.translate c Lang.Help_Command_Balance
+ , " [gl|general_ledger] "++C.translate c Lang.Help_Command_General_Ledger
+ , " [j|journal] "++C.translate c Lang.Help_Command_Journal
+ , " [js|journals] "++C.translate c Lang.Help_Command_Journals
+ , " stats "++C.translate c Lang.Help_Command_Stats
+ , " tags "++C.translate c Lang.Help_Command_Tags
+ ]
options :: C.Context -> Args.Options C.Context
options ctx =
"[auto|yes|no]") $
C.translate ctx Lang.Help_Option_Color
, Option "" ["lang"]
- (ReqArg (\lang c -> do
+ (ReqArg (\lang c ->
return $ c{C.lang =
fromMaybe (C.lang c) $
Lang.from_Strings [lang]
run :: C.Context -> String -> [String] -> IO ()
run c cmd args =
case cmd of
- "bal" -> Command.Balance.run c args
- "balance" -> Command.Balance.run c args
- "gl" -> Command.GL.run c args
- "general_ledger" -> Command.GL.run c args
- "j" -> Command.Journal.run c args
- "journal" -> Command.Journal.run c args
- "js" -> Command.Journals.run c args
+ -- "bal" -> Command.Balance.run c args
+ -- "balance" -> Command.Balance.run c args
+ -- "gl" -> Command.GL.run c args
+ -- "general_ledger" -> Command.GL.run c args
+ -- "j" -> Command.Journal.run c args
+ -- "journal" -> Command.Journal.run c args
+ -- "js" -> Command.Journals.run c args
"journals" -> Command.Journals.run c args
- "stats" -> Command.Stats.run c args
+ -- "stats" -> Command.Stats.run c args
-- "tags" -> Command.Tags.run c args
_ -> usage c >>= Write.fatal c .
((C.translate c (Lang.Error_Unkown_command cmd) <> W.line) <>) .
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
import Data.Decimal (Decimal)
import Data.Either (Either(..), partitionEithers)
import Data.Eq (Eq(..))
-import Data.Foldable (Foldable(..), any)
+import Data.Foldable (Foldable)
+import qualified Data.Foldable as Foldable
import Data.Function (($), (.), const, on)
import Data.Functor (Functor(..), (<$>))
-import Data.List ((++), repeat)
+import qualified Data.List as List
-- import Data.List.NonEmpty (NonEmpty(..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
+import Data.Monoid (Monoid(..), (<>))
import Data.Ord (Ord(..), Ordering(..))
import qualified Data.Strict.Maybe as Strict
import Data.String (String)
import Data.Text (Text)
import qualified Data.Time.Clock as Time
+import Data.TreeMap.Strict (TreeMap)
+import qualified Data.TreeMap.Strict as TreeMap
import Data.Tuple (fst, snd)
-import Prelude (Bounded(..), FilePath, IO, Num(..), id, flip, unlines, zipWith)
+import Prelude (Bounded(..), Num(..), unlines, zipWith)
+import Data.Function (id, flip)
import System.Console.GetOpt
( ArgDescr(..)
, OptDescr(..)
, usageInfo
)
-import System.Environment as Env (getProgName)
+import qualified System.Environment as Env
import System.Exit (exitSuccess)
+import System.IO (IO, FilePath)
import qualified System.IO as IO
import qualified Text.Parsec
import Text.Show (Show(..))
+import Text.WalderLeijen.ANSI.Text (ToDoc(..))
+import qualified Text.WalderLeijen.ANSI.Text as W
+
+import qualified Hcompta as H
+import qualified Hcompta.Lib.Strict as Strict
-import Hcompta.Account (Account_Tags)
-import qualified Hcompta.Account as Account
-import qualified Hcompta.Balance as Balance
import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as C
import qualified Hcompta.CLI.Env as CLI.Env
import qualified Hcompta.CLI.Lang as Lang
import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Chart as Chart
-import Hcompta.Date (Date)
-import qualified Hcompta.Date as Date
-import qualified Hcompta.Filter as Filter
-import qualified Hcompta.Filter.Amount as Filter.Amount
-import qualified Hcompta.Filter.Read as Filter.Read
-import qualified Hcompta.Format.JCC as JCC
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Format.Ledger.Read as Ledger
-import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
-import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Lib.Parsec as R
-import Hcompta.Lib.TreeMap (TreeMap)
-import qualified Hcompta.Lib.TreeMap as TreeMap
-import Hcompta.Polarize (Polarized)
-import qualified Hcompta.Polarize as Polarize
-import qualified Hcompta.Posting as Posting
-import qualified Hcompta.Quantity as Quantity
-import Hcompta.Unit (Unit(..))
-
--- type Sum = (Ledger.Unit, Polarize.Polarized Ledger.Quantity)
+import qualified Hcompta.JCC as JCC
+import qualified Hcompta.Ledger as Ledger
+
+import qualified Text.Parsec.Error.Custom as R
+
+-- type Sum = (Ledger.Unit, H.Polarized Ledger.Quantity)
data Context
= Context
- { ctx_filter_transaction :: forall t.
+ { {-ctx_filter_transaction :: forall t.
( Filter.Transaction t
, Filter.Amount_Quantity
(Posting.Posting_Amount
(Filter.Filter_Bool
(Filter.Filter_Balance b))
-- , ctx_filter_posting :: CLI.Format.Filter_Posting
- , ctx_heritage :: Bool
+ ,-} ctx_heritage :: Bool
, ctx_input :: [FilePath]
, ctx_input_format :: Formats
, ctx_output :: [(Write.Mode, FilePath)]
context :: C.Context -> Context
context c =
Context
- { ctx_filter_transaction = Filter.Simplified $ Right True
- , ctx_filter_balance = Filter.Simplified $ Right True
+ { -- ctx_filter_transaction = Filter.Simplified $ Right True
+ -- , ctx_filter_balance = Filter.Simplified $ Right True
-- , ctx_filter_posting = mempty
- , ctx_heritage = True
+ ctx_heritage = True
, ctx_input = []
, ctx_input_format = mempty
, ctx_output = []
bin <- Env.getProgName
return $ unlines $
[ C.translate c Lang.Section_Description
- , " "++C.translate c Lang.Help_Command_Balance
+ , " "<>C.translate c Lang.Help_Command_Balance
, ""
, C.translate c Lang.Section_Syntax
- , " "++bin++" balance ["++C.translate c Lang.Type_Option++"] [...]"++
- " ["++C.translate c Lang.Type_File_Journal++"] [...]"
+ , " "<>bin<>" balance ["<>C.translate c Lang.Type_Option<>"] [...]"<>
+ " ["<>C.translate c Lang.Type_File_Journal<>"] [...]"
, ""
, usageInfo (C.translate c Lang.Section_Options) (options c)
]
options :: C.Context -> Args.Options Context
options c =
- [ Option "b" ["filter-balance"]
+ [ {-Option "b" ["filter-balance"]
(ReqArg (\s ctx -> do
filter <-
R.runParserT_with_Error
}) $
C.translate c Lang.Type_Filter_Balance) $
C.translate c Lang.Help_Option_Filter_Balance
+ -}
{-, Option "p" ["filter-posting"]
(ReqArg (\s ctx -> do
read <- liftIO $ Filter.Read.read Filter.Read.filter_posting s
C.translate c Lang.Type_Filter_Posting) $
C.translate c Lang.Help_Option_Filter_Posting
-}
- , Option "t" ["filter-transaction"]
+ {-, Option "t" ["filter-transaction"]
(ReqArg (\s ctx -> do
filter <-
R.runParserT_with_Error
}) $
C.translate c Lang.Type_Filter_Transaction) $
C.translate c Lang.Help_Option_Filter_Transaction
- , Option "h" ["help"]
+ ,-} Option "h" ["help"]
(NoArg (\_ctx -> do
usage c >>= IO.hPutStr IO.stderr
exitSuccess)) $
[] -> x{ctx_output=[(Write.Mode_Append, "-")]}
_ -> x) <$>
Args.parse c usage options (context c, args)
- input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
+ input_paths <- CLI.Env.paths c $ ctx_input ctx <> inputs
read_journals <- mapM (liftIO . journal_read ctx) input_paths
case partitionEithers read_journals of
(errs@(_:_), _journals) -> Write.fatals c errs
case fst $ ctx_output_format ctx of
Just f -> Format.journal_empty f:journals
Nothing -> journals
- now <- Date.now
+ now <- H.date_epoch
with_color <- Write.with_color c IO.stdout
W.displayIO IO.stdout $
W.renderPretty with_color 1.0 maxBound $
, Leijen.Table.Cell_Line ' ' 0
] . rows_by_unit
else id) $
- repeat []
+ List.repeat []
where
expand
:: Forall_Journal_Balance_by_Account
--- * 'Balance.Balance_by_Account'
+-- * 'H.Balance_by_Account'
-- ** Type 'Format_Balance_by_Account'
-- JCC
type Balance_by_Account_JCC
- = Balance.Balance_by_Account JCC.Account_Section
- JCC.Unit
- (Polarized JCC.Quantity)
+ = H.Balance_by_Account JCC.Account_Section
+ JCC.Unit
+ (H.Polarized JCC.Quantity)
instance Format.Journal (JCC.Journal Balance_by_Account_JCC) where
type Journal_Format (JCC.Journal Balance_by_Account_JCC)
= Format_Journal_Balance_by_Account
-- Ledger
type Balance_by_Account_Ledger
- = Balance.Balance_by_Account Ledger.Account_Section
- Ledger.Unit
- (Polarized Ledger.Quantity)
+ = H.Balance_by_Account Ledger.Account_Section
+ Ledger.Unit
+ (H.Polarized Ledger.Quantity)
instance Format.Journal (Ledger.Journal Balance_by_Account_Ledger) where
type Journal_Format (Ledger.Journal Balance_by_Account_Ledger)
= Format_Journal_Balance_by_Account
mconcat js =
case js of
[] -> mempty
- j:jn -> foldl' mappend j jn
+ j:jn -> List.foldl' mappend j jn
-- ** 'journal_read'
, as ~ Format.Journal_Account_Section j
, Data as
- , Filter.Account (Account_Tags, TreeMap.Path as)
+ {-, Filter.Account (Account_Tags, TreeMap.Path as)-}
, NFData as
, Ord as
, Show as
, q ~ Format.Journal_Quantity j
, Format.Journal_Quantity j ~ Decimal
- , Quantity.Addable q
- , Quantity.Zero q
+ , H.Addable q
+ , H.Zero q
- , Unit u
- ) => Format.Journal_Filter Context j (Balance.Balance_by_Account as u (Polarized q)) where
+ , H.Unit u
+ ) => Format.Journal_Filter Context j (H.Balance_by_Account as u (H.Polarized q)) where
journal_filter ctx j =
case Filter.simplified $ ctx_filter_balance ctx of
Right True | ctx_redundant ctx -> j
(\n _p -> is_worth n) <$> j
Right False -> const mempty <$> j
Left flt ->
+ (<$> j) $
TreeMap.map_Maybe_with_Path_and_Node
- (\node account (Balance.Account_Sum bal) ->
+ (\node account (H.Balance_by_Account_Sum bal) ->
(if is_worth node bal then id else const Strict.Nothing) $
case Map.mapMaybeWithKey
(\unit qty ->
if Filter.test flt
- ( (Chart.account_tags account (Format.journal_chart j), account)
+ ( (H.chart_account_tags account (Format.journal_chart j), account)
, (unit, qty)
)
then Just qty
else Nothing
) bal of
m | Map.null m -> Strict.Nothing
- m -> Strict.Just $ Balance.Account_Sum m
- ) <$> j
+ m -> Strict.Just $ H.Balance_by_Account_Sum m
+ )
where
is_worth
- :: (Ord k0, Foldable t0, Quantity.Addable a0, Quantity.Zero a0)
+ :: (Ord k0, Foldable t0, H.Addable a0, H.Zero a0)
=> TreeMap.Node k0 x0
- -> t0 (Polarized a0)
+ -> t0 (H.Polarized a0)
-> Bool
is_worth _node bal =
ctx_redundant ctx
-- NOTE: worth if no descendant
-- but Account's exclusive
-- has at least a non-zero Amount
- || Data.Foldable.any
- (not . Quantity.quantity_null . Polarize.depolarize)
+ || Foldable.any
+ (not . H.quantity_null . H.depolarize)
bal
instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account) () where
journal_filter ctx
, as ~ Format.Journal_Account_Section j
, Ord as
- , Quantity.Addable (Format.Journal_Quantity j)
+ , H.Addable (Format.Journal_Quantity j)
, Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
- , Balance_Account_Sum amt
- , Balance_Account_Sum_Unit amt ~ Format.Journal_Unit j
- , Balance_Account_Sum_Quantity amt ~ Polarized (Format.Journal_Quantity j)
+ , Balance_by_Account_Sum amt
+ , Balance_by_Account_Sum_Unit amt ~ Format.Journal_Unit j
+ , Balance_by_Account_Sum_Quantity amt ~ H.Polarized (Format.Journal_Quantity j)
) => Format.Journal_Leijen_Table_Cells j (TreeMap as amt) where
journal_leijen_table_cells jnl =
flip (TreeMap.foldr_with_Path
(\account balance rows ->
- let Balance.Account_Sum bal = balance_by_account_sum balance in
+ let H.Balance_by_Account_Sum bal = balance_by_account_sum balance in
Map.foldrWithKey
(\unit qty ->
zipWith (:)
- [ cell_of $ (unit,) <$> Polarize.polarized_positive qty
- , cell_of $ (unit,) <$> Polarize.polarized_negative qty
- , cell_of (unit, Polarize.depolarize qty)
+ [ cell_of $ (unit,) <$> H.polarized_positive qty
+ , cell_of $ (unit,) <$> H.polarized_negative qty
+ , cell_of (unit, H.depolarize qty)
, cell_of account
]
)
(Const (Forall_Journal_Balance_by_Account j)) =
Format.journal_leijen_table_cells j
--- ** Class 'Balance_Account_Sum'
+-- ** Class 'Balance_by_Account_Sum'
--- | A class to get a 'Balance.Account_Sum'
--- when operating on 'Balance.Balance_by_Account'
--- or 'Balance.Expanded' 'Balance.inclusive' field.
-class Balance_Account_Sum amt where
- type Balance_Account_Sum_Unit amt
- type Balance_Account_Sum_Quantity amt
+-- | A class to get a 'H.Balance_Account_Sum'
+-- when operating on 'H.Balance_by_Account'
+-- or 'H.Balance_Expanded' 'Strict.inclusive' field.
+class Balance_by_Account_Sum amt where
+ type Balance_by_Account_Sum_Unit amt
+ type Balance_by_Account_Sum_Quantity amt
balance_by_account_sum
- :: amt -> Balance.Account_Sum (Balance_Account_Sum_Unit amt)
- (Balance_Account_Sum_Quantity amt)
-instance Balance_Account_Sum (Balance.Account_Sum u q) where
- type Balance_Account_Sum_Unit (Balance.Account_Sum u q) = u
- type Balance_Account_Sum_Quantity (Balance.Account_Sum u q) = q
+ :: amt -> H.Balance_by_Account_Sum (Balance_by_Account_Sum_Unit amt)
+ (Balance_by_Account_Sum_Quantity amt)
+instance Balance_by_Account_Sum (H.Balance_by_Account_Sum u q) where
+ type Balance_by_Account_Sum_Unit (H.Balance_by_Account_Sum u q) = u
+ type Balance_by_Account_Sum_Quantity (H.Balance_by_Account_Sum u q) = q
balance_by_account_sum = id
-instance Balance_Account_Sum (Balance.Account_Sum_Expanded u q) where
- type Balance_Account_Sum_Unit (Balance.Account_Sum_Expanded u q) = u
- type Balance_Account_Sum_Quantity (Balance.Account_Sum_Expanded u q) = q
- balance_by_account_sum = Balance.inclusive
-
-
-
+instance Balance_by_Account_Sum (H.Balance_by_Account_Sum_Expanded u q) where
+ type Balance_by_Account_Sum_Unit (H.Balance_by_Account_Sum_Expanded u q) = u
+ type Balance_by_Account_Sum_Quantity (H.Balance_by_Account_Sum_Expanded u q) = q
+ balance_by_account_sum = Strict.inclusive
-
-
-
-
-
-
--- * 'Balance.Expanded'
+-- * 'H.Balance_Expanded'
-- ** Type 'Format_Journal_Balance_by_Account_Expanded'
-- JCC
type Balance_by_Account_Expanded_JCC
- = Balance.Expanded JCC.Account_Section
+ = H.Balance_Expanded JCC.Account_Section
JCC.Unit
- (Polarized JCC.Quantity)
+ (H.Polarized JCC.Quantity)
instance Format.Journal (JCC.Journal Balance_by_Account_Expanded_JCC) where
type Journal_Format (JCC.Journal Balance_by_Account_Expanded_JCC)
= Format_Journal_Balance_by_Account_Expanded
-- Ledger
type Balance_by_Account_Expanded_Ledger
- = Balance.Expanded Ledger.Account_Section
- Ledger.Unit
- (Polarized Ledger.Quantity)
+ = H.Balance_Expanded Ledger.Account_Section
+ Ledger.Unit
+ (H.Polarized Ledger.Quantity)
instance Format.Journal (Ledger.Journal Balance_by_Account_Expanded_Ledger) where
type Journal_Format (Ledger.Journal Balance_by_Account_Expanded_Ledger)
= Format_Journal_Balance_by_Account_Expanded
, Format.Journal_Chart j
, as ~ Format.Journal_Account_Section j
, Data as
- , Filter.Account (Account_Tags, TreeMap.Path as)
+ {-, Filter.Account (Account_Tags, TreeMap.Path as)-}
, NFData as
, Ord as
, Show as
, q ~ Format.Journal_Quantity j
, Format.Journal_Quantity j ~ Decimal
- , Quantity.Addable q
- , Quantity.Zero q
- , Unit u
- ) => Format.Journal_Filter Context j (Balance.Expanded as u (Polarized q)) where
+ , H.Addable q
+ , H.Zero q
+ , H.Unit u
+ ) => Format.Journal_Filter Context j (H.Balance_Expanded as u (H.Polarized q)) where
journal_filter ctx j =
case Filter.simplified $ ctx_filter_balance ctx of
Right True | ctx_redundant ctx -> j
(const . is_worth) <$> j
Right False -> const mempty <$> j
Left flt ->
+ (<$> j) $
TreeMap.map_Maybe_with_Path_and_Node
(\node account bal ->
(if is_worth node bal then id else const Strict.Nothing) $
case Map.mapMaybeWithKey
(\unit qty ->
if Filter.test flt
- ( (Chart.account_tags account (Format.journal_chart j), account)
+ ( (H.chart_account_tags account (Format.journal_chart j), account)
, (unit, qty)
)
then Just qty
else Nothing
- ) (Balance.get_Account_Sum $ Balance.inclusive bal) of
+ ) (H.unBalance_by_Account_Sum $ Strict.inclusive bal) of
m | Map.null m -> Strict.Nothing
- m -> Strict.Just $ bal{Balance.inclusive=Balance.Account_Sum m}
- ) <$> j
+ m -> Strict.Just $ bal{Strict.inclusive=H.Balance_by_Account_Sum m}
+ )
where
is_worth node bal =
let descendants = TreeMap.nodes
-- NOTE: worth if no descendant
-- but Account's inclusive
-- has at least a non-zero Amount
- || (Map.null descendants
- && Data.Foldable.any
- (not . Quantity.quantity_null . Polarize.depolarize)
- (Balance.get_Account_Sum $ Balance.inclusive bal))
+ || (Map.null descendants &&
+ Foldable.any
+ (not . H.quantity_null . H.depolarize)
+ (H.unBalance_by_Account_Sum $ Strict.inclusive bal))
-- NOTE: worth if Account's exclusive
-- has at least a non-zero Amount
- || (Data.Foldable.any
- (not . Quantity.quantity_null . Polarize.depolarize)
- (Balance.get_Account_Sum $ Balance.exclusive bal))
+ || (Foldable.any
+ (not . H.quantity_null . H.depolarize)
+ (H.unBalance_by_Account_Sum $ Strict.exclusive bal))
-- NOTE: worth if Account has at least more than
-- one descendant Account whose inclusive
-- has at least a non-zero Amount
|| Map.size
( Map.filter
( Strict.maybe False
- ( Data.Foldable.any
- (not . Quantity.quantity_null . Polarize.depolarize)
- . Balance.get_Account_Sum
- . Balance.inclusive )
+ ( Foldable.any
+ (not . H.quantity_null . H.depolarize)
+ . H.unBalance_by_Account_Sum
+ . Strict.inclusive )
. TreeMap.node_value )
descendants
) > 1
(Const (Forall_Journal_Balance_by_Account_Expanded j)) =
Format.journal_leijen_table_cells j
--- Instances Balance.Balance_by_Account -> Balance.Expanded
+-- Instances H.Balance_by_Account -> H.Balance_Expanded
instance
( Functor j
- , Journal_Balance_by_Account_Expanded j (Balance.Expanded as u q)
+ , Journal_Balance_by_Account_Expanded j (H.Balance_Expanded as u q)
- -- NOTE: constraints from Balance.expanded
+ -- NOTE: constraints from H.balance_expanded
, Ord as
, Ord u
- , Quantity.Addable q
- ) => Format.Journal_Wrap (j (Balance.Balance_by_Account as u q))
+ , H.Addable q
+ ) => Format.Journal_Wrap (j (H.Balance_by_Account as u q))
Forall_Journal_Balance_by_Account_Expanded where
journal_wrap =
Forall_Journal_Balance_by_Account_Expanded .
- fmap Balance.expanded
+ fmap H.balance_expanded
instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
Forall_Journal_Balance_by_Account_Expanded where
--- * 'Balance.Balance_by_Unit'
+-- * 'H.Balance_by_Unit'
type Format_Journal_Balance_by_Unit
= Format
-- JCC
type Balance_by_Unit_JCC
- = Balance.Balance_by_Unit JCC.Account
- JCC.Unit
- (Polarized JCC.Quantity)
+ = H.Balance_by_Unit JCC.Account
+ JCC.Unit
+ (H.Polarized JCC.Quantity)
instance Format.Journal (JCC.Journal Balance_by_Unit_JCC) where
type Journal_Format (JCC.Journal Balance_by_Unit_JCC)
= Format_Journal_Balance_by_Unit
-- Ledger
type Balance_by_Unit_Ledger
- = Balance.Balance_by_Unit Ledger.Account
- Ledger.Unit
- (Polarized Ledger.Quantity)
+ = H.Balance_by_Unit Ledger.Account
+ Ledger.Unit
+ (H.Polarized Ledger.Quantity)
instance Format.Journal (Ledger.Journal Balance_by_Unit_Ledger) where
type Journal_Format (Ledger.Journal Balance_by_Unit_Ledger)
= Format_Journal_Balance_by_Unit
type Journal_Format Forall_Journal_Balance_by_Unit = Format_Journal_Balance_by_Unit
journal_format (Forall_Journal_Balance_by_Unit j) = Format.journal_format j
--- Instances Balance.Balance_by_Account -> Balance.Balance_by_Unit
+-- Instances H.Balance_by_Account -> H.Balance_by_Unit
instance
( Functor j
- , Journal_Balance_by_Unit j (Balance.Balance_by_Unit (Account.Account_Path as) u q)
+ , Journal_Balance_by_Unit j (H.Balance_by_Unit (H.Account_Path as) u q)
- -- NOTE: constraints from Balance.by_unit_of_by_account
- , Account.Account (Account.Account_Path as)
+ -- NOTE: constraints from H.balance_by_unit_of_by_account
+ , H.Account (H.Account_Path as)
, Ord as
, Ord u
- , Quantity.Addable q
- ) => Format.Journal_Wrap (j (Balance.Balance_by_Account as u q))
+ , H.Addable q
+ ) => Format.Journal_Wrap (j (H.Balance_by_Account as u q))
Forall_Journal_Balance_by_Unit where
journal_wrap =
Forall_Journal_Balance_by_Unit .
- fmap (flip Balance.by_unit_of_by_account mempty)
+ fmap (flip H.balance_by_unit_of_by_account mempty)
instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
Forall_Journal_Balance_by_Unit where
(Forall_Journal_Balance_by_Account j) =
Format.journal_wrap j
--- Instances Balance.Expanded -> Balance.Balance_by_Unit
+-- Instances H.Balance_Expanded -> H.Balance_by_Unit
instance
( Functor j
- , Journal_Balance_by_Unit j (Balance.Balance_by_Unit (Account.Account_Path as) u q)
+ , Journal_Balance_by_Unit j (H.Balance_by_Unit (H.Account_Path as) u q)
- -- NOTE: constraints from Balance.by_unit_of_expanded
- , Account.Account (Account.Account_Path as)
+ -- NOTE: constraints from H.balance_by_unit_of_expanded
+ , H.Account (H.Account_Path as)
, Ord as
, Ord u
- , Quantity.Addable q
- ) => Format.Journal_Wrap (j (Balance.Expanded as u q))
+ , H.Addable q
+ ) => Format.Journal_Wrap (j (H.Balance_Expanded as u q))
Forall_Journal_Balance_by_Unit where
journal_wrap =
Forall_Journal_Balance_by_Unit .
- fmap (flip Balance.by_unit_of_expanded mempty)
+ fmap (flip H.balance_by_unit_of_expanded mempty)
instance Format.Journal_Wrap Forall_Journal_Balance_by_Account_Expanded
Forall_Journal_Balance_by_Unit where
, Journal j
, a ~ Format.Journal_Account j
- , Account.Account a
+ , H.Account a
, u ~ Format.Journal_Unit j
, Ord u
, q ~ Format.Journal_Quantity j
- , Quantity.Addable (Format.Journal_Quantity j)
- ) => Format.Journal_Leijen_Table_Cells j (Balance.Balance_by_Unit a u (Polarized q)) where
+ , H.Addable (Format.Journal_Quantity j)
+ ) => Format.Journal_Leijen_Table_Cells j (H.Balance_by_Unit a u (H.Polarized q)) where
journal_leijen_table_cells jnl acc =
- let Balance.Balance_by_Unit bal = Format.journal_content jnl in
+ let H.Balance_by_Unit bal = Format.journal_content jnl in
Map.foldrWithKey
(\unit amt ->
- let qty = Balance.unit_sum_quantity amt in
+ let qty = H.balance_by_unit_sum_quantity amt in
zipWith (:)
- [ Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> Polarize.polarized_positive qty
- , Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> Polarize.polarized_negative qty
- , Leijen.Table.cell_of_forall_param jnl (unit, Polarize.depolarize qty)
+ [ Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> H.polarized_positive qty
+ , Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> H.polarized_negative qty
+ , Leijen.Table.cell_of_forall_param jnl (unit, H.depolarize qty)
, Leijen.Table.cell
]
) acc bal
class
( Leijen.Table.Cell_of_forall_param j (Format.Journal_Unit j, Format.Journal_Quantity j)
- , W.Leijen_of_forall_param j [Format.Journal_Transaction j]
+ , W.ToDoc1 j [Format.Journal_Transaction j]
) => Journal (j:: * -> *) where
journal_posting
:: forall m. j m
- -> Account.Account_Path (Format.Journal_Account_Section j)
+ -> H.Account_Path (Format.Journal_Account_Section j)
-> Map (Format.Journal_Unit j)
(Format.Journal_Quantity j)
-> [Text] -- ^ Comments
journal_transaction
:: forall m. j m
-> Text -- ^ Wording
- -> (Date, [Date])
- -> Map (Account.Account_Path (Format.Journal_Account_Section j))
+ -> (H.Date, [H.Date])
+ -> Map (H.Account_Path (Format.Journal_Account_Section j))
[Format.Journal_Posting j]
-> Format.Journal_Transaction j
-> C.Context
-> Context
-> Lang.Exercise_OC
- -> Date
+ -> H.Date
-> W.Doc
instance
, quantity ~ Format.Journal_Quantity j
, Ord unit
, Ord quantity
- , Quantity.Zero (Format.Journal_Quantity j)
- , Quantity.Addable (Format.Journal_Quantity j)
+ , H.Zero (Format.Journal_Quantity j)
+ , H.Addable (Format.Journal_Quantity j)
, unit ~ Format.Journal_Unit j
) => Journal_Equilibrium_Transaction
- j (Balance.Balance_by_Account as unit (Polarized quantity)) where
+ j (H.Balance_by_Account as unit (H.Polarized quantity)) where
journal_equilibrium_transaction
j c ctx oc now =
let bal_by_account = Format.journal_content j in
- let Balance.Balance_by_Unit bal_by_unit =
- Balance.by_unit_of_by_account bal_by_account mempty in
+ let H.Balance_by_Unit bal_by_unit =
+ H.balance_by_unit_of_by_account bal_by_account mempty in
let postings =
Map.foldlWithKey
- (\acc unit Balance.Unit_Sum{Balance.unit_sum_quantity} ->
+ (\acc unit H.Balance_by_Unit_Sum{..} ->
let qty =
(case oc of
Lang.Exercise_Closing -> id
Lang.Exercise_Opening -> negate) $
- Polarize.depolarize unit_sum_quantity in
- case Quantity.quantity_sign qty of
+ H.depolarize balance_by_unit_sum_quantity in
+ case H.quantity_sign qty of
LT ->
let account = snd $ ctx_account_equilibrium ctx in
Map.insertWith mappend account
Map.empty
bal_by_unit
in
- W.leijen_of_forall_param j [
+ W.toDoc1 j [
journal_transaction j
(Lang.translate (C.lang c) (Lang.Description_Exercise oc))
(now{Time.utctDayTime=0}, []) $
Map.unionWith mappend postings $
TreeMap.flatten_with_Path
- (\posting_account (Balance.Account_Sum amount_by_unit) ->
+ (\posting_account (H.Balance_by_Account_Sum amount_by_unit) ->
[ journal_posting j posting_account
(flip fmap amount_by_unit $
(case oc of
Lang.Exercise_Closing -> negate
Lang.Exercise_Opening -> id)
- . Polarize.depolarize)
+ . H.depolarize)
[]
]
)
--- /dev/null
+../HLint.hs
\ No newline at end of file
-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
module Hcompta.CLI.Command.Journals where
import Control.Arrow ((+++))
-import Control.Monad (Monad(..), liftM, mapM)
+import Control.Monad (Monad(..), mapM)
import Control.Monad.IO.Class (liftIO)
import Data.Either (Either(..), partitionEithers)
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), const)
+import Data.Functor ((<$>))
import Data.List ((++))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..), (<>))
import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Context as C
import qualified Hcompta.CLI.Env as CLI.Env
+
import qualified Hcompta.CLI.Format as Format
import Hcompta.CLI.Format (Format(..), Formats)
import Hcompta.CLI.Format.Ledger ()
import Hcompta.CLI.Format.JCC ()
import qualified Hcompta.CLI.Lang as Lang
import qualified Hcompta.CLI.Write as Write
+
+
-- import qualified Hcompta.Lib.Parsec as R
-import qualified Hcompta.Format.JCC as JCC
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Lib.Leijen as W
+import qualified Hcompta.JCC as JCC
+import qualified Hcompta.Ledger as Ledger
+import qualified Text.WalderLeijen.ANSI.Text as W
data Context
= Context
exitSuccess)) $
C.translate c Lang.Help_Option_Help
, Option "i" ["input"]
- (ReqArg (\s ctx -> do
+ (ReqArg (\s ctx ->
return $ ctx{ctx_input=s:ctx_input ctx}) $
C.translate c Lang.Type_File_Journal) $
C.translate c Lang.Help_Option_Input
- , Option "if" ["input-format"]
+ , Option "f" ["input-format"]
(OptArg (\arg ctx -> do
ctx_input_format <- case arg of
Nothing -> return $ Format_JCC ()
(errs@(_:_), _journals) -> Write.fatals c errs
([], journals) -> do
with_color <- Write.with_color c IO.stdout
- W.displayIO IO.stdout $ do
- W.renderPretty with_color 1.0 maxBound $
- W.toDoc () $
- mconcat journals
+ W.displayIO IO.stdout $
+ W.renderPretty with_color 1.0 maxBound $
+ W.toDoc () $
+ mconcat journals
-- * Class 'Journal'
-- JCC
instance Journal JCC.Journal Journals_JCC where
- journal_files j = [JCC.journal_file j]
+ journal_files = JCC.journal_files
-- Ledger
instance Journal Ledger.Journal Journals_Ledger where
Format.journal_fold journals_cons j mempty in
let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
= const () in
- liftM ((+++) Format.Message wrap) .
+ (((+++) Format.Message wrap) <$>) .
Format.journal_read cons
Format_Ledger () ->
let wrap (j::Ledger.Journal Journals_Ledger) =
Format.journal_fold journals_cons j mempty in
let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
= const () in
- liftM ((+++) Format.Message wrap) .
+ (((+++) Format.Message wrap) <$>) .
Format.journal_read cons
journals_cons :: Journal j m => j m -> Journals -> Journals
-journals_cons j !(Journals files) =
+journals_cons j (Journals files) =
Journals (journal_files j ++ files)
--- /dev/null
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hcompta.CLI.Convert where
+
+import Control.Applicative (Const(..))
+import Data.Bool (Bool(..), not)
+import qualified Data.Char as Char
+import Data.Decimal (Decimal)
+import Data.Function (($), (.), id)
+import Data.Functor (Functor(..), (<$>))
+import qualified Data.List as List
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (Maybe(..))
+import Data.Monoid (Monoid(..))
+import Data.Ord (Ord(..))
+import Data.Sequence (Seq)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.TreeMap.Strict (TreeMap)
+import qualified Data.TreeMap.Strict as TreeMap
+
+import qualified Hcompta as H
+import qualified Hcompta.JCC as JCC
+import qualified Hcompta.Ledger as Ledger
+
+import qualified Hcompta.Lib.Strict as Strict
+
+-- * Class 'Convert'
+
+-- | Generic class dedicated to transform any type
+-- into another one encoding more or less
+-- the same data.
+class Convert from to where
+ convert :: from -> to
+
+instance Convert () () where
+ convert = id
+
+-- Journal
+instance
+ ( Convert ledger jcc
+ , Monoid jcc
+ , Monoid ledger
+ )
+ => Convert (Ledger.Journal ledger) (JCC.Journal jcc) where
+ convert Ledger.Journal{..} =
+ JCC.Journal
+ { JCC.journal_amount_styles = convert journal_amount_styles
+ , JCC.journal_chart = convert journal_chart
+ , JCC.journal_files
+ , JCC.journal_includes = convert <$> journal_includes
+ , JCC.journal_last_read_time
+ , JCC.journal_content = convert journal_content
+ }
+instance
+ ( Convert jcc ledger
+ , Monoid jcc
+ , Monoid ledger
+ )
+ => Convert (JCC.Journal jcc) (Ledger.Journal ledger) where
+ convert JCC.Journal{..} =
+ Ledger.Journal
+ { Ledger.journal_amount_styles = convert journal_amount_styles
+ , Ledger.journal_chart = convert journal_chart
+ , Ledger.journal_files
+ , Ledger.journal_includes = convert <$> journal_includes
+ , Ledger.journal_last_read_time
+ , Ledger.journal_content = convert journal_content
+ }
+instance Convert ledger jcc
+ => Convert
+ (H.Journal ledger)
+ (H.Journal jcc)
+ where
+ convert (H.Journal j) =
+ H.Journal $
+ convert <$>
+ Map.mapKeysMonotonic convert j
+
+-- Unit
+instance Convert Ledger.Unit JCC.Unit where
+ convert (Ledger.Unit u) =
+ JCC.Unit $
+ Text.map
+ (\c -> case Char.generalCategory c of
+ Char.CurrencySymbol -> c
+ Char.LowercaseLetter -> c
+ Char.ModifierLetter -> c
+ Char.OtherLetter -> c
+ Char.TitlecaseLetter -> c
+ Char.UppercaseLetter -> c
+ _ -> '_') u
+instance Convert JCC.Unit Ledger.Unit where
+ convert (JCC.Unit u) =
+ Ledger.Unit u
+
+-- Account
+instance Convert H.Account_Anchor H.Account_Anchor where
+ convert = id
+instance Convert H.Account_Tags H.Account_Tags where
+ convert = id
+
+-- Amount Style
+instance Convert Ledger.Amount_Styles JCC.Amount_Styles where
+ convert (Ledger.Amount_Styles sty) =
+ JCC.Amount_Styles $ convert sty
+instance Convert JCC.Amount_Styles Ledger.Amount_Styles where
+ convert (JCC.Amount_Styles sty) =
+ Ledger.Amount_Styles $ convert sty
+instance Convert Ledger.Amount_Style JCC.Amount_Style where
+ convert Ledger.Amount_Style{..} =
+ JCC.Amount_Style
+ { JCC.amount_style_fractioning
+ , JCC.amount_style_grouping_integral =
+ (<$> amount_style_grouping_integral) $
+ \(Ledger.Amount_Style_Grouping c l) ->
+ JCC.Amount_Style_Grouping c l
+ , JCC.amount_style_grouping_fractional =
+ (<$> amount_style_grouping_fractional) $
+ \(Ledger.Amount_Style_Grouping c l) ->
+ JCC.Amount_Style_Grouping c l
+ , JCC.amount_style_unit_side =
+ (<$> amount_style_unit_side) $ \s ->
+ case s of
+ Ledger.Amount_Style_Side_Left -> JCC.Amount_Style_Side_Left
+ Ledger.Amount_Style_Side_Right -> JCC.Amount_Style_Side_Right
+ , JCC.amount_style_unit_spaced
+ }
+instance Convert JCC.Amount_Style Ledger.Amount_Style where
+ convert JCC.Amount_Style{..} =
+ Ledger.Amount_Style
+ { Ledger.amount_style_fractioning
+ , Ledger.amount_style_grouping_integral =
+ (<$> amount_style_grouping_integral) $
+ \(JCC.Amount_Style_Grouping c l) ->
+ Ledger.Amount_Style_Grouping c l
+ , Ledger.amount_style_grouping_fractional =
+ (<$> amount_style_grouping_fractional) $
+ \(JCC.Amount_Style_Grouping c l) ->
+ Ledger.Amount_Style_Grouping c l
+ , Ledger.amount_style_unit_side =
+ (<$> amount_style_unit_side) $ \s ->
+ case s of
+ JCC.Amount_Style_Side_Left -> Ledger.Amount_Style_Side_Left
+ JCC.Amount_Style_Side_Right -> Ledger.Amount_Style_Side_Right
+ , Ledger.amount_style_unit_spaced
+ }
+
+-- Transaction
+instance Convert Ledger.Transaction JCC.Transaction where
+ convert Ledger.Transaction{..} =
+ JCC.Transaction
+ { JCC.transaction_anchors = mempty
+ , JCC.transaction_comments =
+ List.filter (not . Text.all Char.isSpace) $
+ Ledger.comments_without_tags $
+ mappend
+ transaction_comments_before
+ transaction_comments_after
+ , JCC.transaction_dates
+ , JCC.transaction_postings = (convert <$>) <$> transaction_postings
+ , JCC.transaction_sourcepos
+ , JCC.transaction_tags =
+ (case transaction_code of
+ t | Text.null t -> id
+ t -> H.transaction_tag_cons (H.transaction_tag ("Code":|[]) t)
+ ) $
+ if transaction_status
+ then H.transaction_tag_cons
+ (H.transaction_tag ("Status":|[]) "")
+ transaction_tags
+ else transaction_tags
+ , JCC.transaction_wording
+ }
+instance Convert JCC.Transaction Ledger.Transaction where
+ convert JCC.Transaction{..} =
+ let H.Transaction_Tags (H.Tags tags) = transaction_tags in
+ Ledger.Transaction
+ { Ledger.transaction_code = mconcat $ Map.findWithDefault [""] ("Code":|[]) tags
+ , Ledger.transaction_comments_after = mempty
+ , Ledger.transaction_comments_before = transaction_comments
+ , Ledger.transaction_dates
+ , Ledger.transaction_postings = (convert <$>) <$> transaction_postings
+ , Ledger.transaction_sourcepos
+ , Ledger.transaction_status =
+ case Map.lookup ("Status":|[]) tags of
+ Nothing -> False
+ Just _ -> True
+ , Ledger.transaction_tags =
+ H.Transaction_Tags $ H.Tags $
+ Map.delete ("Code":|[]) $
+ Map.delete ("Status":|[]) $
+ tags
+ , Ledger.transaction_wording
+ }
+
+-- Posting
+instance Convert Ledger.Posting JCC.Posting where
+ convert Ledger.Posting{..} =
+ JCC.Posting
+ { JCC.posting_account
+ , JCC.posting_account_anchor = Nothing
+ , JCC.posting_amounts =
+ convert <$>
+ Map.mapKeysMonotonic convert posting_amounts
+ , JCC.posting_anchors = mempty
+ , JCC.posting_comments =
+ List.filter (not . Text.all Char.isSpace) $
+ Ledger.comments_without_tags posting_comments
+ , JCC.posting_dates
+ , JCC.posting_sourcepos
+ , JCC.posting_tags =
+ if posting_status
+ then H.posting_tag_cons
+ (H.Posting_Tag $ H.tag ("Status":|[]) "")
+ posting_tags
+ else posting_tags
+ }
+instance Convert JCC.Posting Ledger.Posting where
+ convert JCC.Posting{..} =
+ let H.Posting_Tags (H.Tags tags) = posting_tags in
+ Ledger.Posting
+ { Ledger.posting_account
+ , Ledger.posting_amounts =
+ convert <$>
+ Map.mapKeysMonotonic convert posting_amounts
+ , Ledger.posting_comments
+ , Ledger.posting_dates
+ , Ledger.posting_status =
+ case Map.lookup ("Status":|[]) tags of
+ Nothing -> False
+ Just _ -> True
+ , Ledger.posting_sourcepos
+ , Ledger.posting_tags =
+ H.Posting_Tags $ H.Tags $
+ Map.delete ("Status":|[]) $
+ tags
+ }
+
+-- Chart
+instance Convert JCC.Chart Ledger.Chart where
+ convert JCC.Chart{..} =
+ Ledger.Chart
+ { Ledger.chart_accounts = chart_accounts
+ }
+instance Convert Ledger.Chart JCC.Chart where
+ convert Ledger.Chart{..} =
+ JCC.Chart
+ { JCC.chart_accounts = chart_accounts
+ , JCC.chart_anchors = mempty
+ }
+{-
+instance Convert (Chart.Chart x) (Chart.Chart x) where
+ convert = id
+instance
+ ( Convert (Chart.Chart a0) (Chart.Chart a1)
+ , Convert x y
+ ) => Convert (Chart.Charted a0 x) (Chart.Charted a1 y) where
+ convert (Chart.Charted a x) =
+ Chart.Charted (convert a) (convert x)
+-}
+{-
+instance Convert (Chart.Chart JCC.Account) (Chart.Chart Ledger.Account) where
+ convert Chart.Chart
+ { Chart.chart_accounts
+ , Chart.chart_anchors
+ } =
+ Chart.Chart
+ { Chart.chart_accounts = convert chart_accounts
+ , Chart.chart_anchors = convert chart_anchors
+ }
+-}
+
+instance Convert x y => Convert (JCC.Charted x) (Ledger.Charted y) where
+ convert (JCC.Charted c x) =
+ Ledger.Charted (convert c) (convert x)
+
+instance Convert x y => Convert (Ledger.Charted x) (JCC.Charted y) where
+ convert (Ledger.Charted c x) =
+ JCC.Charted (convert c) (convert x)
+
+-- Balance
+instance
+ ( Convert unit unit_
+ , Convert quantity quantity_
+ ) => Convert (H.Balance_by_Account_Sum unit quantity)
+ (H.Balance_by_Account_Sum unit_ quantity_) where
+ convert (H.Balance_by_Account_Sum m) =
+ H.Balance_by_Account_Sum $
+ convert <$>
+ Map.mapKeysMonotonic convert m
+
+-- * GL
+
+-- ** Class 'GL'
+class
+ ( Convert (H.Account_Section (H.Posting_Account (H.Transaction_Posting x)))
+ (H.Account_Section (H.Posting_Account (H.Transaction_Posting y)))
+ ) => GL x y
+instance GL JCC.Transaction Ledger.Transaction
+instance GL Ledger.Transaction JCC.Transaction
+
+instance GL ( JCC.Charted JCC.Transaction)
+ (Ledger.Charted Ledger.Transaction)
+instance GL (Ledger.Charted Ledger.Transaction)
+ (JCC.Charted JCC.Transaction)
+
+instance
+ ( GL x y
+ , GL_Line x y
+ , H.GL_Transaction x
+ , H.GL_Transaction y
+ , Convert x y
+ ) => Convert (H.GL x)
+ (H.GL y) where
+ convert (H.GL m)
+ = H.GL $ TreeMap.map_monotonic convert (convert <$>) m
+ -- NOTE: Date does not need to be converted,
+ -- thus avoid a useless Map.mapKeysMonotonic
+ -- from the Convert instance on Map.
+
+-- *** Class 'GL_Line'
+
+class
+ ( Convert (H.GL_Transaction_Line x)
+ (H.GL_Transaction_Line y)
+ , Convert (H.Transaction_Posting x)
+ (H.Transaction_Posting y)
+ , Convert (H.GL_Posting_Quantity (H.Transaction_Posting x))
+ (H.GL_Posting_Quantity (H.Transaction_Posting y))
+ ) => GL_Line x y
+instance GL_Line JCC.Transaction Ledger.Transaction
+instance GL_Line Ledger.Transaction JCC.Transaction
+
+instance GL_Line ( JCC.Charted JCC.Transaction)
+ (Ledger.Charted Ledger.Transaction)
+instance GL_Line (Ledger.Charted Ledger.Transaction)
+ (JCC.Charted JCC.Transaction)
+
+instance
+ ( GL_Line x y
+ , H.GL_Transaction x
+ , H.GL_Transaction y
+ , Convert x y
+ ) => Convert (H.GL_Line x)
+ (H.GL_Line y) where
+ convert H.GL_Line{..} =
+ H.GL_Line
+ { H.gl_line_transaction = convert gl_line_transaction
+ , H.gl_line_posting = convert gl_line_posting
+ , H.gl_line_sum = convert gl_line_sum
+ }
+
+-- Class 'GL_Expanded'
+
+instance
+ ( GL x y
+ , GL_Line x y
+ , H.GL_Transaction x
+ , H.GL_Transaction y
+ , Convert x y
+ ) => Convert (H.GL_Expanded x)
+ (H.GL_Expanded y) where
+ convert (H.GL_Expanded m)
+ = H.GL_Expanded $ convert m
+
+-- Class 'GL_Line_Expanded'
+
+instance
+ Convert x y
+ => Convert (Strict.Clusive x)
+ (Strict.Clusive y) where
+ convert Strict.Clusive{..} =
+ Strict.Clusive
+ { Strict.exclusive = convert exclusive
+ , Strict.inclusive = convert inclusive
+ }
+
+-- Const
+instance Convert x y
+ => Convert (Const x w) (Const y w_) where
+ convert (Const x) = Const $ convert x
+
+-- Polarized
+instance
+ Convert x y
+ => Convert (H.Polarized x)
+ (H.Polarized y) where
+ convert = (convert <$>)
+
+-- Date
+instance Convert H.Date H.Date where
+ convert = id
+
+-- Quantity
+instance Convert Decimal Decimal where
+ convert = id
+
+-- Text
+instance Convert Text Text where
+ convert = id
+
+-- List
+instance Convert x y => Convert [x] [y] where
+ convert = fmap convert
+instance Convert x y => Convert (NonEmpty x) (NonEmpty y) where
+ convert = fmap convert
+
+-- TreeMap
+
+instance (Convert kx ky, Convert x y, Ord kx, Ord ky)
+ => Convert (TreeMap kx x) (TreeMap ky y) where
+ convert = TreeMap.map_monotonic convert convert
+
+-- Map
+instance (Convert kx ky, Convert x y, Ord kx)
+ => Convert (Map kx x) (Map ky y) where
+ convert = Map.mapKeysMonotonic convert . fmap convert
+
+-- Seq
+instance Convert x y => Convert (Seq x) (Seq y) where
+ convert = fmap convert
+
+-- * Stats
+
+-- ** Class 'Stats'
+class
+ ( Convert (H.Posting_Account (H.Transaction_Posting x))
+ (H.Posting_Account (H.Transaction_Posting y))
+ , Convert (H.Amount_Unit (H.Posting_Amount (H.Transaction_Posting x)))
+ (H.Amount_Unit (H.Posting_Amount (H.Transaction_Posting y)))
+ ) => Stats x y
+
+instance Stats JCC.Transaction Ledger.Transaction
+instance Stats Ledger.Transaction JCC.Transaction
+
+instance Stats ( JCC.Charted JCC.Transaction)
+ (Ledger.Charted Ledger.Transaction)
+instance Stats (Ledger.Charted Ledger.Transaction)
+ (JCC.Charted JCC.Transaction)
+
+instance
+ ( Stats x y
+ , H.Stats_Transaction x
+ , H.Stats_Transaction y
+ ) => Convert (H.Stats x) (H.Stats y) where
+ convert s@H.Stats{..} =
+ s
+ { H.stats_accounts = Map.mapKeysMonotonic convert stats_accounts
+ , H.stats_units = Map.mapKeysMonotonic convert stats_units
+ }
-- * or the one in HCOMPTA_JOURNAL environment variable if any,
paths :: C.Context -> [FilePath] -> IO [FilePath]
paths c [] = do
- tryJust (guard . isDoesNotExistError) $ Env.getEnv "HCOMPTA_JOURNAL"
- >>= \x -> case x of
+ x <- tryJust (guard . isDoesNotExistError) $
+ Env.getEnv "HCOMPTA_JOURNAL"
+ case x of
Right ok -> return [ok]
Left _ko -> Write.fatal c Lang.Error_No_input_file_given
paths _c ps = return ps
{-# LANGUAGE TypeFamilies #-}
module Hcompta.CLI.Format where
-import Control.Applicative (Const(..))
import Control.Monad.Trans.Except (runExceptT)
-import Data.Bool (Bool(..), not)
-import qualified Data.Char as Char
-import Data.Decimal (Decimal)
import Data.Either (Either(..))
-import Data.Function (($), (.), id)
-import Data.Functor (Functor(..), (<$>))
-import qualified Data.List as List
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.Map.Strict as Map
-import Data.Map.Strict (Map)
-import Data.Maybe (Maybe(..))
+import Data.Function (($), (.))
+import Data.Functor (Functor, (<$>))
import Data.Monoid (Monoid(..))
-import Data.Ord (Ord(..))
-import Data.Sequence (Seq)
-import qualified Data.Text as Text
-import Data.Text (Text)
import System.IO (FilePath, IO)
import Text.Show (Show)
+import qualified Text.Parsec.Error.Custom as R
import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Lib.TreeMap as TreeMap
-import Hcompta.Lib.TreeMap (TreeMap)
-import qualified Hcompta.Journal as Journal
-import qualified Hcompta.Tag as Tag
-import qualified Hcompta.Balance as Balance
-import qualified Hcompta.GL as GL
-import qualified Hcompta.Stats as Stats
-import qualified Hcompta.Chart as Chart
-import qualified Hcompta.Account as Account
-import qualified Hcompta.Posting as Posting
-import qualified Hcompta.Transaction as Transaction
--- import qualified Hcompta.Filter.Read as Filter.Read
-import Hcompta.Date (Date)
-import qualified Hcompta.Polarize as Polarize
-import qualified Hcompta.Format.JCC as JCC
-import qualified Hcompta.Format.JCC.Journal as JCC.Journal
-import qualified Hcompta.Format.JCC.Read as JCC.Read
-import qualified Hcompta.Format.JCC.Amount.Style as JCC.Amount.Style
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Format.Ledger.Read as Ledger
-import qualified Hcompta.Lib.Parsec as R
+import qualified Text.WalderLeijen.ANSI.Text as W
+
+import qualified Hcompta.JCC as JCC
+import qualified Hcompta.Ledger as Ledger
+
import Hcompta.Lib.Consable (Consable)
import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
+import Hcompta.CLI.Convert
+
-- * Type 'Format'
data Format jcc ledger
- = Format_JCC jcc
- | Format_Ledger ledger
+ = Format_JCC jcc
+ | Format_Ledger ledger
deriving (Show)
type Formats = Format () ()
class Journal_Files j where
journal_files :: forall m. j m -> [FilePath]
instance Journal_Files JCC.Journal where
- journal_files j = [JCC.journal_file j] -- FIXME: JCC.journal_files
+ journal_files = JCC.journal_files
instance Journal_Files Ledger.Journal where
journal_files = Ledger.journal_files
-> IO (Either (Journal_Read_Error j) (j m))
instance Journal_Read JCC.Journal where
type Journal_Read_Error JCC.Journal
- = [R.Error JCC.Read.Error]
+ = [R.Error JCC.Error_Read]
type Journal_Read_Transaction JCC.Journal
= JCC.Charted JCC.Transaction
journal_read cons =
- runExceptT . JCC.Read.file
- (JCC.Read.context cons JCC.journal)
+ runExceptT . JCC.read_file
+ (JCC.context_read cons JCC.journal)
instance Journal_Read Ledger.Journal where
type Journal_Read_Error Ledger.Journal
- = [R.Error Ledger.Read_Error]
+ = [R.Error Ledger.Error_Read]
type Journal_Read_Transaction Ledger.Journal
= Ledger.Charted Ledger.Transaction
journal_read cons =
- runExceptT . Ledger.read
- (Ledger.read_context cons Ledger.journal)
+ runExceptT . Ledger.read_file
+ (Ledger.context_read cons Ledger.journal)
+{-
-- * Class 'Journal_Chart'
class Journal_Chart (j:: * -> *) where
journal_chart = JCC.journal_chart
instance Journal_Chart Ledger.Journal where
journal_chart = Ledger.journal_chart
+-}
-- * Class 'Journal_Monoid'
journal_flatten :: j -> j
journal_fold :: (j -> a -> a) -> j -> a -> a
instance Monoid m => Journal_Monoid (JCC.Journal m) where
- journal_flatten = JCC.Journal.flatten
- journal_fold = JCC.Journal.fold
+ journal_flatten = JCC.journal_flatten
+ journal_fold = JCC.journal_fold
instance Monoid m => Journal_Monoid (Ledger.Journal m) where
journal_flatten = Ledger.journal_flatten
journal_fold = Ledger.journal_fold
class Journal_Functor x y where
journal_functor_map :: x -> y
journal_fmap :: forall j. Functor j => j x -> j y
- journal_fmap = fmap journal_functor_map
+ journal_fmap = (journal_functor_map <$>)
-- * Class 'Journal_Table'
data Message w = forall msg. Lang.Translate msg w => Message msg
instance Lang.Translate (Message W.Doc) W.Doc where
translate lang (Message x) = Lang.translate lang x
-
--- * Class 'Convert'
-
--- | Generic class dedicated to transform any type
--- into another one encoding more or less
--- the same data.
-class Convert from to where
- convert :: from -> to
-
-instance Convert () () where
- convert = id
-
--- Journal
-instance
- ( Convert ledger jcc
- , Monoid jcc
- , Monoid ledger
- )
- => Convert (Ledger.Journal ledger) (JCC.Journal jcc) where
- convert Ledger.Journal
- { Ledger.journal_amount_styles
- , Ledger.journal_chart = chart
- , Ledger.journal_files=jf
- , Ledger.journal_includes
- , Ledger.journal_last_read_time
- , Ledger.journal_content = content
- } = JCC.Journal
- { JCC.journal_amount_styles = convert journal_amount_styles
- , JCC.journal_chart = chart
- , JCC.journal_file = List.head jf -- FIXME: JCC.journal_files
- , JCC.journal_includes = fmap convert $ journal_includes
- , JCC.journal_last_read_time
- , JCC.journal_content = convert content
- }
-instance
- ( Convert jcc ledger
- , Monoid jcc
- , Monoid ledger
- )
- => Convert (JCC.Journal jcc) (Ledger.Journal ledger) where
- convert JCC.Journal
- { JCC.journal_amount_styles
- , JCC.journal_chart = chart
- , JCC.journal_file
- , JCC.journal_includes
- , JCC.journal_last_read_time
- , JCC.journal_content = content
- } = Ledger.Journal
- { Ledger.journal_amount_styles = convert journal_amount_styles
- , Ledger.journal_chart = chart
- , Ledger.journal_files = [journal_file] -- FIXME: JCC.journal_files
- , Ledger.journal_includes = fmap convert $ journal_includes
- , Ledger.journal_last_read_time
- , Ledger.journal_content = convert content
- }
-instance Convert ledger jcc
- => Convert
- (Journal.Journal ledger)
- (Journal.Journal jcc)
- where
- convert (Journal.Journal j) =
- Journal.Journal $
- fmap convert $
- Map.mapKeysMonotonic convert j
-
--- Unit
-instance Convert Ledger.Unit JCC.Unit where
- convert (Ledger.Unit u) =
- JCC.Unit $
- Text.map
- (\c -> case Char.generalCategory c of
- Char.CurrencySymbol -> c
- Char.LowercaseLetter -> c
- Char.ModifierLetter -> c
- Char.OtherLetter -> c
- Char.TitlecaseLetter -> c
- Char.UppercaseLetter -> c
- _ -> '_') u
-instance Convert JCC.Unit Ledger.Unit where
- convert (JCC.Unit u) =
- Ledger.Unit u
-
--- Account
-instance Convert Account.Account_Anchor Account.Account_Anchor where
- convert = id
-instance Convert Account.Account_Tags Account.Account_Tags where
- convert = id
-
--- Amount Style
-instance Convert Ledger.Amount_Styles JCC.Styles where
- convert (Ledger.Amount_Styles sty) =
- JCC.Amount.Style.Styles $ convert sty
-instance Convert JCC.Styles Ledger.Amount_Styles where
- convert (JCC.Amount.Style.Styles sty) =
- Ledger.Amount_Styles $ convert sty
-instance Convert Ledger.Amount_Style JCC.Style where
- convert Ledger.Amount_Style
- { Ledger.amount_style_fractioning=f
- , Ledger.amount_style_grouping_integral=gi
- , Ledger.amount_style_grouping_fractional=gf
- , Ledger.amount_style_unit_side=unit_side
- , Ledger.amount_style_unit_spaced=unit_spaced
- } = JCC.Amount.Style.Style
- { JCC.Amount.Style.fractioning=f
- , JCC.Amount.Style.grouping_integral =
- fmap (\(Ledger.Amount_Style_Grouping c l) ->
- JCC.Amount.Style.Grouping c l) gi
- , JCC.Amount.Style.grouping_fractional =
- fmap (\(Ledger.Amount_Style_Grouping c l) ->
- JCC.Amount.Style.Grouping c l) gf
- , JCC.Amount.Style.unit_side =
- fmap (\s ->
- case s of
- Ledger.Amount_Style_Side_Left -> JCC.Amount.Style.Side_Left
- Ledger.Amount_Style_Side_Right -> JCC.Amount.Style.Side_Right
- ) unit_side
- , JCC.Amount.Style.unit_spaced
- }
-instance Convert JCC.Style Ledger.Amount_Style where
- convert JCC.Amount.Style.Style
- { JCC.Amount.Style.fractioning=f
- , JCC.Amount.Style.grouping_integral=gi
- , JCC.Amount.Style.grouping_fractional=gf
- , JCC.Amount.Style.unit_side=unit_side
- , JCC.Amount.Style.unit_spaced=unit_spaced
- } = Ledger.Amount_Style
- { Ledger.amount_style_fractioning=f
- , Ledger.amount_style_grouping_integral =
- fmap (\(JCC.Amount.Style.Grouping c l) ->
- Ledger.Amount_Style_Grouping c l) gi
- , Ledger.amount_style_grouping_fractional =
- fmap (\(JCC.Amount.Style.Grouping c l) ->
- Ledger.Amount_Style_Grouping c l) gf
- , Ledger.amount_style_unit_side =
- fmap
- (\s ->
- case s of
- JCC.Amount.Style.Side_Left -> Ledger.Amount_Style_Side_Left
- JCC.Amount.Style.Side_Right -> Ledger.Amount_Style_Side_Right
- ) unit_side
- , Ledger.amount_style_unit_spaced=unit_spaced
- }
-
--- Transaction
-instance Convert Ledger.Transaction JCC.Transaction where
- convert Ledger.Transaction
- { Ledger.transaction_code
- , Ledger.transaction_comments_after
- , Ledger.transaction_comments_before
- , Ledger.transaction_dates
- , Ledger.transaction_postings
- , Ledger.transaction_sourcepos
- , Ledger.transaction_status
- , Ledger.transaction_tags
- , Ledger.transaction_wording
- } = JCC.Transaction
- { JCC.transaction_anchors = mempty
- , JCC.transaction_comments =
- List.filter (not . Text.all Char.isSpace) $
- Ledger.comments_without_tags $
- mappend
- transaction_comments_before
- transaction_comments_after
- , JCC.transaction_dates
- , JCC.transaction_postings = fmap (fmap convert) transaction_postings
- , JCC.transaction_sourcepos
- , JCC.transaction_tags =
- (case transaction_code of
- t | Text.null t -> id
- t -> Transaction.tag_cons (Transaction.tag ("Code":|[]) t)
- ) $
- case transaction_status of
- True -> Transaction.tag_cons
- (Transaction.tag ("Status":|[]) "")
- transaction_tags
- False -> transaction_tags
- , JCC.transaction_wording
- }
-instance Convert JCC.Transaction Ledger.Transaction where
- convert JCC.Transaction
- { JCC.transaction_anchors=_transaction_anchors
- , JCC.transaction_comments
- , JCC.transaction_dates
- , JCC.transaction_postings
- , JCC.transaction_sourcepos
- , JCC.transaction_tags = Transaction.Transaction_Tags (Tag.Tags tags)
- , JCC.transaction_wording
- } = Ledger.Transaction
- { Ledger.transaction_code = mconcat $ Map.findWithDefault [""] ("Code":|[]) tags
- , Ledger.transaction_comments_after = mempty
- , Ledger.transaction_comments_before = transaction_comments
- , Ledger.transaction_dates
- , Ledger.transaction_postings = fmap (fmap convert) transaction_postings
- , Ledger.transaction_sourcepos
- , Ledger.transaction_status =
- case Map.lookup ("Status":|[]) tags of
- Nothing -> False
- Just _ -> True
- , Ledger.transaction_tags =
- Transaction.Transaction_Tags $ Tag.Tags $
- Map.delete ("Code":|[]) $
- Map.delete ("Status":|[]) $
- tags
- , Ledger.transaction_wording
- }
-
--- Posting
-instance Convert Ledger.Posting JCC.Posting where
- convert Ledger.Posting
- { Ledger.posting_account
- , Ledger.posting_amounts
- , Ledger.posting_comments
- , Ledger.posting_dates
- , Ledger.posting_status
- , Ledger.posting_sourcepos
- , Ledger.posting_tags
- } = JCC.Posting
- { JCC.posting_account
- , JCC.posting_account_anchor = Nothing
- , JCC.posting_amounts =
- fmap convert $
- Map.mapKeysMonotonic convert $
- posting_amounts
- , JCC.posting_anchors = mempty
- , JCC.posting_comments =
- List.filter (not . Text.all Char.isSpace) $
- Ledger.comments_without_tags posting_comments
- , JCC.posting_dates
- , JCC.posting_sourcepos
- , JCC.posting_tags =
- case posting_status of
- True -> Posting.tag_cons
- (Posting.tag ("Status":|[]) "")
- posting_tags
- False -> posting_tags
- }
-instance Convert JCC.Posting Ledger.Posting where
- convert JCC.Posting
- { JCC.posting_account
- , JCC.posting_account_anchor=_
- , JCC.posting_amounts
- , JCC.posting_anchors = _posting_anchors
- , JCC.posting_comments
- , JCC.posting_dates
- , JCC.posting_sourcepos
- , JCC.posting_tags = Posting.Posting_Tags (Tag.Tags tags)
- } = Ledger.Posting
- { Ledger.posting_account
- , Ledger.posting_amounts =
- fmap convert $
- Map.mapKeysMonotonic convert $
- posting_amounts
- , Ledger.posting_comments
- , Ledger.posting_dates
- , Ledger.posting_status =
- case Map.lookup ("Status":|[]) tags of
- Nothing -> False
- Just _ -> True
- , Ledger.posting_sourcepos
- , Ledger.posting_tags =
- Posting.Posting_Tags $ Tag.Tags $
- Map.delete ("Status":|[]) $
- tags
- }
-
--- Chart
-instance Convert (Chart.Chart x) (Chart.Chart x) where
- convert = id
-{-
-instance Convert (Chart.Chart JCC.Account) (Chart.Chart Ledger.Account) where
- convert Chart.Chart
- { Chart.chart_accounts
- , Chart.chart_anchors
- } =
- Chart.Chart
- { Chart.chart_accounts = convert chart_accounts
- , Chart.chart_anchors = convert chart_anchors
- }
--}
-
-instance
- ( Convert (Chart.Chart a0) (Chart.Chart a1)
- , Convert x y
- ) => Convert (Chart.Charted a0 x) (Chart.Charted a1 y) where
- convert (Chart.Charted a x) =
- Chart.Charted (convert a) (convert x)
-
--- Balance
-instance
- ( Convert unit unit_
- , Convert quantity quantity_
- ) => Convert (Balance.Account_Sum unit quantity)
- (Balance.Account_Sum unit_ quantity_) where
- convert (Balance.Account_Sum m) =
- Balance.Account_Sum $
- fmap convert $
- Map.mapKeysMonotonic convert m
-
--- * GL
-
--- ** Class 'GL'
-class
- ( Convert (Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting x)))
- (Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting y)))
- ) => GL x y
-instance GL JCC.Transaction Ledger.Transaction
-instance GL Ledger.Transaction JCC.Transaction
-
-instance GL ( JCC.Charted JCC.Transaction)
- (Ledger.Charted Ledger.Transaction)
-instance GL (Ledger.Charted Ledger.Transaction)
- (JCC.Charted JCC.Transaction)
-
-instance
- ( GL x y
- , GL_Line x y
- , GL.Transaction x
- , GL.Transaction y
- , Convert x y
- ) => Convert (GL.GL x)
- (GL.GL y) where
- convert (GL.GL m)
- = GL.GL $ TreeMap.map_monotonic convert (fmap convert) m
- -- NOTE: Date does not need to be converted,
- -- thus avoid a useless Map.mapKeysMonotonic
- -- from the Convert instance on Map.
-
--- *** Class 'GL_Line'
-
-class
- ( Convert (GL.Transaction_Line x)
- (GL.Transaction_Line y)
- , Convert (GL.Transaction_Posting x)
- (GL.Transaction_Posting y)
- , Convert (GL.Posting_Quantity (GL.Transaction_Posting x))
- (GL.Posting_Quantity (GL.Transaction_Posting y))
- ) => GL_Line x y
-instance GL_Line JCC.Transaction Ledger.Transaction
-instance GL_Line Ledger.Transaction JCC.Transaction
-
-instance GL_Line ( JCC.Charted JCC.Transaction)
- (Ledger.Charted Ledger.Transaction)
-instance GL_Line (Ledger.Charted Ledger.Transaction)
- (JCC.Charted JCC.Transaction)
-
-instance
- ( GL_Line x y
- , GL.Transaction x
- , GL.Transaction y
- , Convert x y
- ) => Convert (GL.GL_Line x)
- (GL.GL_Line y) where
- convert GL.GL_Line
- { GL.gl_line_transaction
- , GL.gl_line_posting
- , GL.gl_line_sum
- } = GL.GL_Line
- { GL.gl_line_transaction = convert gl_line_transaction
- , GL.gl_line_posting = convert gl_line_posting
- , GL.gl_line_sum = convert gl_line_sum
- }
-
--- Class 'GL_Expanded'
-
-instance
- ( GL x y
- , GL_Line x y
- , GL.Transaction x
- , GL.Transaction y
- , Convert x y
- ) => Convert (GL.Expanded x)
- (GL.Expanded y) where
- convert (GL.Expanded m)
- = GL.Expanded $ convert m
-
--- Class 'GL_Line_Expanded'
-
-instance
- ( GL_Line x y
- , GL.Transaction x
- , GL.Transaction y
- , Convert x y
- ) => Convert (GL.GL_Line_Expanded x)
- (GL.GL_Line_Expanded y) where
- convert GL.GL_Line_Expanded
- { GL.exclusive
- , GL.inclusive
- } = GL.GL_Line_Expanded
- { GL.exclusive = convert <$> exclusive
- , GL.inclusive = convert <$> inclusive
- }
-
--- Const
-instance Convert x y
- => Convert (Const x w) (Const y w_) where
- convert (Const x) = Const $ convert x
-
--- Polarized
-instance Convert x y
- => Convert (Polarize.Polarized x)
- (Polarize.Polarized y) where
- convert = fmap convert
-
--- Date
-instance Convert Date Date where
- convert = id
-
--- Quantity
-instance Convert Decimal Decimal where
- convert = id
-
--- Text
-instance Convert Text Text where
- convert = id
-
--- List
-instance Convert x y => Convert [x] [y] where
- convert = fmap convert
-instance Convert x y => Convert (NonEmpty x) (NonEmpty y) where
- convert = fmap convert
-
--- TreeMap
-
-instance (Convert kx ky, Convert x y, Ord kx, Ord ky)
- => Convert (TreeMap kx x) (TreeMap ky y) where
- convert = TreeMap.map_monotonic convert convert
-
--- Map
-instance (Convert kx ky, Convert x y, Ord kx)
- => Convert (Map kx x) (Map ky y) where
- convert = Map.mapKeysMonotonic convert . fmap convert
-
--- Seq
-instance Convert x y => Convert (Seq x) (Seq y) where
- convert = fmap convert
-
--- * Stats
-
--- ** Class 'Stats'
-class
- ( Convert (Stats.Posting_Account (Stats.Transaction_Posting x))
- (Stats.Posting_Account (Stats.Transaction_Posting y))
- , Convert (Stats.Posting_Unit (Stats.Transaction_Posting x))
- (Stats.Posting_Unit (Stats.Transaction_Posting y))
- ) => Stats x y
-
-instance Stats JCC.Transaction Ledger.Transaction
-instance Stats Ledger.Transaction JCC.Transaction
-
-instance Stats ( JCC.Charted JCC.Transaction)
- (Ledger.Charted Ledger.Transaction)
-instance Stats (Ledger.Charted Ledger.Transaction)
- (JCC.Charted JCC.Transaction)
-
-instance
- ( Stats x y
- , Stats.Transaction x
- , Stats.Transaction y
- ) => Convert (Stats.Stats x) (Stats.Stats y) where
- convert s@Stats.Stats
- { Stats.stats_accounts
- , Stats.stats_units
- } = s
- { Stats.stats_accounts = Map.mapKeysMonotonic convert stats_accounts
- , Stats.stats_units = Map.mapKeysMonotonic convert stats_units
- }
--- /dev/null
+../HLint.hs
\ No newline at end of file
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.CLI.Format.JCC where
--- import Control.DeepSeq (NFData)
--- import Control.Monad.Trans.Except (ExceptT(..))
import Data.Foldable (Foldable(..))
-import Data.Function ((.))
+import Data.Function (($), (.))
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
-import Prelude (($))
--- import System.IO (IO)
import Text.Show (Show(..))
+import Text.WalderLeijen.ANSI.Text (ToDoc(..))
+import qualified Text.WalderLeijen.ANSI.Text as W
+
+import qualified Hcompta as H
+import qualified Hcompta.JCC as JCC
-import Hcompta.Date (Date)
-import qualified Hcompta.Balance as Balance
--- import qualified Hcompta.CLI.Format as CLI.Format
--- import Hcompta.CLI.Format (Format(..))
import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.Format.JCC as JCC
-import qualified Hcompta.Format.JCC.Amount as JCC.Amount
-import qualified Hcompta.Format.JCC.Amount.Write as JCC.Amount.Write
-import qualified Hcompta.Format.JCC.Read as JCC.Read
-import qualified Hcompta.Format.JCC.Write as JCC.Write
--- import Hcompta.Lib.Consable (Consable)
-import Hcompta.Lib.Leijen (ToDoc(..))
-import qualified Hcompta.Lib.Leijen as W
--- import qualified Hcompta.Lib.Parsec as Parsec
-import qualified Hcompta.Polarize as Polarize
import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
-instance Lang.Translate JCC.Read.Error W.Doc where
+
+instance Lang.Translate JCC.Error_Read W.Doc where
translate lang err =
case err of
- JCC.Read.Error_date date -> toDoc lang date
- JCC.Read.Error_transaction_not_equilibrated styles tr unit_sums ->
+ JCC.Error_Read_date date -> toDoc lang date
+ JCC.Error_Read_transaction_not_equilibrated styles tr unit_sums ->
i18n_transaction_not_equilibrated styles tr unit_sums
Lang.Error_Transaction_The_following_transaction_is_not_equilibrated_because
- JCC.Read.Error_reading_file file_path exn ->
+ JCC.Error_Read_reading_file file_path exn ->
W.vsep $
[ Lang.translate lang $ Lang.Error_Failed_to_read_file file_path
, W.text $ TL.pack $ show exn
]
- JCC.Read.Error_including_file file_path errs ->
+ JCC.Error_Read_including_file file_path errs ->
W.vsep $
[ Lang.translate lang $ Lang.Error_Failed_to_include_file file_path
, Lang.translate lang errs
]
- JCC.Read.Error_account_anchor_unknown pos anchor ->
+ JCC.Error_Read_account_anchor_unknown pos anchor ->
Lang.translate lang $ Lang.Error_Account_Anchor_unknown pos anchor
- JCC.Read.Error_account_anchor_not_unique pos anchor ->
+ JCC.Error_Read_account_anchor_not_unique pos anchor ->
Lang.translate lang $ Lang.Error_Account_Anchor_is_not_unique pos anchor
where
i18n_transaction_not_equilibrated styles tr unit_sums msg =
W.vsep $
[ Lang.translate lang msg
, W.vsep $ List.map
- (\(unit, Balance.Unit_Sum{Balance.unit_sum_quantity}) ->
+ (\(unit, H.Balance_by_Unit_Sum{..}) ->
Lang.translate lang $
Lang.Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount unit $
- JCC.Amount.style styles $
+ JCC.amount_styled styles $
JCC.Amount unit $
- Polarize.depolarize unit_sum_quantity
+ H.depolarize balance_by_unit_sum_quantity
) unit_sums
, W.space
- , JCC.Write.transaction styles tr
+ , JCC.write_transaction styles tr
]
-instance Leijen.Table.Cell_of_forall_param JCC.Journal Date where
+instance Leijen.Table.Cell_of_forall_param JCC.Journal H.Date where
cell_of_forall_param _ctx date =
Leijen.Table.cell
- { Leijen.Table.cell_content = JCC.Write.date date
- , Leijen.Table.cell_width = JCC.Write.date_length date
+ { Leijen.Table.cell_content = JCC.write_date date
+ , Leijen.Table.cell_width = JCC.write_date_length date
}
instance Leijen.Table.Cell_of_forall_param JCC.Journal JCC.Account where
cell_of_forall_param _ctx account =
Leijen.Table.cell
- { Leijen.Table.cell_content = JCC.Write.account account
- , Leijen.Table.cell_width = JCC.Write.account_length account
+ { Leijen.Table.cell_content = JCC.write_account account
+ , Leijen.Table.cell_width = JCC.write_account_length account
}
instance Leijen.Table.Cell_of_forall_param JCC.Journal (JCC.Unit, JCC.Quantity) where
cell_of_forall_param j (unit, qty) =
let sty = JCC.journal_amount_styles j in
- let amt = JCC.Amount.Amount unit qty in
- let sa = JCC.Amount.style sty amt in
+ let amt = JCC.Amount unit qty in
+ let sa = JCC.amount_styled sty amt in
Leijen.Table.cell
- { Leijen.Table.cell_content = JCC.Amount.Write.amount sa
- , Leijen.Table.cell_width = JCC.Amount.Write.amount_length sa
+ { Leijen.Table.cell_content = JCC.write_amount sa
+ , Leijen.Table.cell_width = JCC.write_amount_length sa
}
instance Leijen.Table.Cell_of_forall_param JCC.Journal JCC.Wording where
cell_of_forall_param _j w =
, Leijen.Table.cell_width = Text.length w
}
-instance Foldable f => W.Leijen_of_forall_param JCC.Journal (f JCC.Transaction) where
- leijen_of_forall_param =
- JCC.Write.transactions .
+instance Foldable f => W.ToDoc1 JCC.Journal (f JCC.Transaction) where
+ toDoc1 =
+ JCC.write_transactions .
JCC.journal_amount_styles
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.CLI.Format.Ledger where
--- import Control.Monad.Trans.Except (ExceptT(..))
import Data.Foldable (Foldable(..))
-import Data.Function ((.))
+import Data.Function (($), (.))
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
--- import Control.DeepSeq (NFData)
-import Prelude (($))
--- import System.IO (IO)
import Text.Show (Show(..))
+import Text.WalderLeijen.ANSI.Text (ToDoc(..))
+import qualified Text.WalderLeijen.ANSI.Text as W
+
+import qualified Hcompta as H
+import qualified Hcompta.Ledger as Ledger
-import Hcompta.Date (Date)
-import qualified Hcompta.Balance as Balance
--- import qualified Hcompta.CLI.Format as CLI.Format
--- import Hcompta.CLI.Lang (Lang)
import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Format.Ledger.Read as Ledger
-import qualified Hcompta.Format.Ledger.Write as Ledger
--- import Hcompta.Lib.Consable (Consable)
-import Hcompta.Lib.Leijen (ToDoc(..))
-import qualified Hcompta.Lib.Leijen as W
--- import qualified Hcompta.Lib.Parsec as Parsec
-import qualified Hcompta.Polarize as Polarize
import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
-instance Lang.Translate Ledger.Read_Error W.Doc where
+instance Lang.Translate Ledger.Error_Read W.Doc where
translate lang err =
case err of
- Ledger.Read_Error_date date -> toDoc lang date
- Ledger.Read_Error_transaction_not_equilibrated styles tr unit_sums ->
+ Ledger.Error_Read_date date -> toDoc lang date
+ Ledger.Error_Read_transaction_not_equilibrated styles tr unit_sums ->
i18n_transaction_not_equilibrated styles tr unit_sums
Lang.Error_Transaction_The_following_transaction_is_not_equilibrated_because
- Ledger.Read_Error_virtual_transaction_not_equilibrated styles tr unit_sums ->
+ Ledger.Error_Read_virtual_transaction_not_equilibrated styles tr unit_sums ->
i18n_transaction_not_equilibrated styles tr unit_sums
Lang.Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because
- Ledger.Read_Error_reading_file file_path exn ->
+ Ledger.Error_Read_reading_file file_path exn ->
W.vsep $
[ Lang.translate lang $ Lang.Error_Failed_to_read_file file_path
, W.text $ TL.pack $ show exn
]
- Ledger.Read_Error_including_file file_path errs ->
+ Ledger.Error_Read_including_file file_path errs ->
W.vsep $
[ Lang.translate lang $ Lang.Error_Failed_to_include_file file_path
, Lang.translate lang errs
W.vsep $
[ Lang.translate lang msg
, W.vsep $ List.map
- (\(unit, Balance.Unit_Sum{Balance.unit_sum_quantity}) ->
+ (\(unit, H.Balance_by_Unit_Sum{..}) ->
Lang.translate lang $
Lang.Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount unit $
Ledger.amount_styled styles $
Ledger.Amount unit $
- Polarize.depolarize unit_sum_quantity
+ H.depolarize balance_by_unit_sum_quantity
) unit_sums
, W.space
, Ledger.write_transaction styles tr
]
-instance Leijen.Table.Cell_of_forall_param Ledger.Journal Date where
+instance Leijen.Table.Cell_of_forall_param Ledger.Journal H.Date where
cell_of_forall_param _ctx date =
Leijen.Table.cell
{ Leijen.Table.cell_content = Ledger.write_date date
, Leijen.Table.cell_width = Text.length w
}
-instance Foldable f => W.Leijen_of_forall_param Ledger.Journal (f Ledger.Transaction) where
- leijen_of_forall_param =
+instance Foldable f => W.ToDoc1 Ledger.Journal (f Ledger.Transaction) where
+ toDoc1 =
Ledger.write_transactions .
Ledger.journal_amount_styles
--- /dev/null
+../HLint.hs
\ No newline at end of file
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.CLI.Lang where
-import Control.Monad (liftM)
-import qualified Data.List
+import qualified Data.List as List
import Data.Maybe (catMaybes, fromMaybe)
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
+import Data.Monoid ((<>))
import Prelude hiding (error)
-import System.Environment (getEnvironment)
-import System.IO.Memoize (once)
+import qualified System.Environment as Env
+import qualified System.IO.Memoize as IO
import qualified Text.Parsec as Parsec
import qualified Text.Parsec.Error as Parsec.Error
+import qualified Text.Parsec.Error.Custom as Parsec
-import Hcompta.Account (Account_Anchor)
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Format.Ledger.Write as Ledger
-import qualified Hcompta.Format.JCC as JCC
-import qualified Hcompta.Format.JCC.Amount as JCC.Amount
-import qualified Hcompta.Format.JCC.Amount.Write as JCC.Amount.Write
-import qualified Hcompta.Format.JCC.Date.Write as JCC.Date.Write
-import qualified Hcompta.Format.JCC.Write as JCC.Write
-import Hcompta.Date (Date)
-import qualified Hcompta.Filter.Date.Read as Date.Read
-import qualified Hcompta.Filter.Read as Filter.Read
-import Hcompta.Lib.Leijen (ToDoc(..), (<>))
-import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Lib.Parsec as Lib.Parsec
-import Hcompta.Transaction (Transaction_Anchor(..))
-import qualified Hcompta.Unit as Unit
+import qualified Hcompta as H
+import qualified Hcompta.Ledger as Ledger
+import qualified Hcompta.JCC as JCC
+
+import Text.WalderLeijen.ANSI.Text (ToDoc(..))
+import qualified Text.WalderLeijen.ANSI.Text as W
-- * Type 'Lang'
data Lang
translate _lang = id
-- TODO: check that this is expected behavior
--- and portability issues
+-- and portability issues.
from_Env :: IO Lang
from_Env = do
- once getEnvironment
- >>= liftM (\env ->
+ io_env <- IO.once Env.getEnvironment
+ (<$> io_env) $ \env ->
fromMaybe EN $ from_Strings $
- Data.List.concatMap
- ((\lang ->
- let short = takeWhile (/= '_') lang in
- if short == lang
- then [lang]
- else [lang, short])
- . Data.List.takeWhile (/= '.') ) $
- catMaybes
- [ Data.List.lookup "LC_ALL" env
- , Data.List.lookup "LC_CTYPE" env
- , Data.List.lookup "LANG" env
- ])
+ List.concatMap
+ ((\lang ->
+ let short = takeWhile (/= '_') lang in
+ if short == lang
+ then [lang]
+ else [lang, short])
+ . List.takeWhile (/= '.') ) $
+ catMaybes
+ [ List.lookup "LC_ALL" env
+ , List.lookup "LC_CTYPE" env
+ , List.lookup "LANG" env
+ ]
from_Strings :: [String] -> Maybe Lang
from_Strings s =
instance ToDoc () Integer where
toDoc _ = W.integer
instance ToDoc () JCC.Unit where
- toDoc _ = JCC.Amount.Write.unit
-instance ToDoc () Account_Anchor where
- toDoc _ = JCC.Write.account_anchor
-instance ToDoc () Transaction_Anchor where
- toDoc _ = JCC.Write.transaction_anchor
-instance ToDoc () (JCC.Amount.Styled JCC.Amount) where
- toDoc _ = JCC.Amount.Write.amount
+ toDoc _ = JCC.write_unit
+instance ToDoc () H.Account_Anchor where
+ toDoc _ = JCC.write_account_anchor
+instance ToDoc () H.Transaction_Anchor where
+ toDoc _ = JCC.write_transaction_anchor
+instance ToDoc () (JCC.Amount_Styled JCC.Amount) where
+ toDoc _ = JCC.write_amount
instance ToDoc () Ledger.Unit where
toDoc _ = Ledger.write_unit
instance ToDoc () (Ledger.Amount_Styled Ledger.Amount) where
toDoc _ = Ledger.write_amount
-instance ToDoc () Date where
- toDoc _ = JCC.Date.Write.date
-instance ToDoc Lang Date.Read.Error where
+instance ToDoc () H.Date where
+ toDoc _ = JCC.write_date
+instance ToDoc Lang JCC.Error_Read_Date where
toDoc FR e =
case e of
- Date.Read.Error_year_or_day_is_missing ->
+ JCC.Error_Read_Date_year_or_day_is_missing ->
"l’année ou le jour est manquant·e"
- Date.Read.Error_invalid_date (year, month, day) ->
+ JCC.Error_Read_Date_invalid_date (year, month, day) ->
"date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
- Date.Read.Error_invalid_time_of_day (hour, minute, second) ->
+ JCC.Error_Read_Date_invalid_time_of_day (hour, minute, second) ->
"heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
toDoc EN e =
case e of
- Date.Read.Error_year_or_day_is_missing ->
+ JCC.Error_Read_Date_year_or_day_is_missing ->
"year or day is missing"
- Date.Read.Error_invalid_date (year, month, day) ->
+ JCC.Error_Read_Date_invalid_date (year, month, day) ->
"invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
- Date.Read.Error_invalid_time_of_day (hour, minute, second) ->
+ JCC.Error_Read_Date_invalid_time_of_day (hour, minute, second) ->
"invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
+instance ToDoc Lang Ledger.Error_Read_Date where
+ toDoc FR e =
+ case e of
+ Ledger.Error_Read_Date_year_or_day_is_missing ->
+ "l’année ou le jour est manquant·e"
+ Ledger.Error_Read_Date_invalid_date (year, month, day) ->
+ "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
+ Ledger.Error_Read_Date_invalid_time_of_day (hour, minute, second) ->
+ "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
+ toDoc EN e =
+ case e of
+ Ledger.Error_Read_Date_year_or_day_is_missing ->
+ "year or day is missing"
+ Ledger.Error_Read_Date_invalid_date (year, month, day) ->
+ "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
+ Ledger.Error_Read_Date_invalid_time_of_day (hour, minute, second) ->
+ "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
+{-
instance Translate Filter.Read.Error W.Doc where
translate lang@FR err =
case err of
Filter.Read.Error_Filter_Date d -> toDoc lang d
Filter.Read.Error_Filter_Date_Interval (l, h) ->
"wrong interval: (" <> toDoc () l <> ", " <> toDoc () h <> ")"
+-}
-- * Type 'Account'
+
data Account
= Account_Equilibrium
instance Translate Account Ledger.Account where
Account_Equilibrium -> Ledger.account "Équilibre" []
-- * Type 'Comment'
+
data Comment
= Comment_Equilibrium
instance Translate Comment Text where
Comment_Equilibrium -> "Mouvement d’équilibre"
-- * Type 'Description'
+
data Description
= Description_Exercise Exercise_OC
data Exercise_OC
-- * Type 'Error'
data Error
- = Error_Account_Anchor_is_not_unique Parsec.SourcePos Account_Anchor
- | Error_Account_Anchor_unknown Parsec.SourcePos Account_Anchor
+ = Error_Account_Anchor_is_not_unique Parsec.SourcePos H.Account_Anchor
+ | Error_Account_Anchor_unknown Parsec.SourcePos H.Account_Anchor
| Error_Failed_to_include_file FilePath
| Error_Failed_to_read_file FilePath
| Error_No_input_file_given
| Error_Option_Equilibrium_Debit
| Error_Option_Tags_Tree
| Error_Option_Verbosity
- | Error_Transaction_Anchor_unknown Parsec.SourcePos Transaction_Anchor
- | Error_Transaction_Anchor_is_not_unique Parsec.SourcePos Transaction_Anchor
+ | Error_Transaction_Anchor_unknown Parsec.SourcePos H.Transaction_Anchor
+ | Error_Transaction_Anchor_is_not_unique Parsec.SourcePos H.Transaction_Anchor
| Error_Transaction_Invalid_date Integer Int Int
| Error_Transaction_Invalid_time_of_day Int Int Integer
| Error_Transaction_The_following_transaction_is_not_equilibrated_because
| Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because
- | Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount JCC.Unit (JCC.Amount.Styled JCC.Amount)
+ | Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount JCC.Unit (JCC.Amount_Styled JCC.Amount)
| Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount Ledger.Unit (Ledger.Amount_Styled Ledger.Amount)
| Error_Transaction_Year_or_day_is_missing
| Error_Unkown_command String
"the following virtual transaction is not equilibrated, because:"
Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount unit amount ->
" - " <>
- (if Text.null $ Unit.unit_text unit
+ (if Text.null $ H.unit_text unit
then "empty unit"
else "unit " <> (#)unit) <>
" sums up to the non-null amount: " <> (#)amount
Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount unit amount ->
" - " <>
- (if Text.null $ Unit.unit_text unit
+ (if Text.null $ H.unit_text unit
then "empty unit"
else "unit " <> (#)unit) <>
" sums up to the non-null amount: " <> (#)amount
"la transaction virtuelle suivante n’est pas équilibrée, car :"
Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount unit amount ->
" - l’unité " <>
- (if Text.null $ Unit.unit_text unit
+ (if Text.null $ H.unit_text unit
then "vide"
else (#)unit) <>
" a le solde non-nul : " <> (#)amount
Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount unit amount ->
" - l’unité " <>
- (if Text.null $ Unit.unit_text unit
+ (if Text.null $ H.unit_text unit
then "vide"
else (#)unit) <>
" a le solde non-nul : " <> (#)amount
"" -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ")"
path -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ") dans : " <> (#)path
instance Translate e W.Doc
- => Translate [Lib.Parsec.Error e] W.Doc where
+ => Translate [Parsec.Error e] W.Doc where
translate lang errors =
- W.vsep $ do
- (flip map) errors $ (\error ->
+ W.vsep $
+ (<$> errors) $ \error ->
case error of
- Lib.Parsec.Error_At pos errs -> W.vsep $
+ Parsec.Error_At pos errs -> W.vsep $
[ translate lang pos
, translate lang errs
]
- Lib.Parsec.Error_Parser err ->
+ Parsec.Error_Parser err ->
W.vsep $
[ translate lang (Parsec.errorPos err)
, showErrorMessages
(Parsec.Error.errorMessages err)
]
- Lib.Parsec.Error_Custom pos err -> W.vsep $
+ Parsec.Error_Custom pos err -> W.vsep $
[ translate lang pos
, translate lang err
]
- )
where
showErrorMessages :: [Parsec.Error.Message] -> W.Doc
showErrorMessages msgs
commasOr [m] = W.bold $ W.dullblack $ W.text $ TL.pack m
commasOr ms = commaSep (init ms)
<> (W.space <> toDoc lang Error_Parsec_Or <> W.space)
- <> (W.bold $ W.dullblack $ W.text $ TL.pack $ last ms)
+ <> W.bold (W.dullblack $ W.text $ TL.pack $ last ms)
commaSep = W.intercalate (W.comma <> W.space)
(W.bold . W.dullblack . W.text . TL.pack)
. clean
- clean = Data.List.nub . filter (not . null)
+ clean = List.nub . filter (not . null)
-- * Type 'Header'
data Header
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+../HLint.hs
\ No newline at end of file
import Data.Bool
import Data.Char (Char)
-import Data.Foldable (Foldable(..))
-import Data.Foldable (any)
+import qualified Data.Foldable as Foldable
import qualified Data.List
import Data.List (map, replicate)
-import Data.Maybe (Maybe(..), maybe)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Data.Monoid ((<>))
import Data.Ord (Ord(..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import Prelude (($), (.), Int, Integral(..), Num(..), fromIntegral, id, zipWith)
-import qualified Hcompta.Lib.Leijen as W
-import Hcompta.Lib.Leijen ((<>), toDoc, ToDoc(..))
+import Text.WalderLeijen.ANSI.Text (ToDoc(..))
+import qualified Text.WalderLeijen.ANSI.Text as W
-- * Type 'Table'
, column_rows :: [Cell]
}
instance ToDoc () [Column] where
- toDoc _m cols = do
- let rows = Data.List.transpose $ map column_rows cols
- let has_title = any (not . Text.null . column_title) cols
+ toDoc _m cols =
+ let rows = Data.List.transpose $ map column_rows cols in
+ let has_title = Foldable.any (not . Text.null . column_title) cols in
let titles =
W.intercalate (W.bold $ W.dullblack $ W.char '|')
(\col@Column{column_title} -> do
W.text $ TL.pack $ replicate len '_'
align (Just pad) col
Cell{cell_width, cell_content, cell_align=Just Align_Center}
- ) cols
+ ) cols in
W.vsep (
(if has_title then (:) titles else id) $
map
- ( W.intercalate (W.space <> do W.bold $ W.dullblack $ W.char '|') id
+ ( W.intercalate (W.space <> W.bold (W.dullblack $ W.char '|')) id
. map (W.space <>)
. zipWith toDoc cols
) rows
- ) <> do
+ ) <>
(case cols of { [] -> W.empty; _ -> W.line })
column :: Text -> Align -> [Cell] -> Column
column column_title column_align column_rows =
Column
{ column_title
, column_width = max (Text.length column_title) $
- foldr (max . cell_width) 0 column_rows
+ Foldable.foldr (max . cell_width) 0 column_rows
, column_align
, column_rows
}
{-# LANGUAGE TupleSections #-}
module Main (main) where
+import Control.Monad (Monad(..))
+import Data.Function ((.))
+import Data.Monoid ((<>))
import qualified Data.Text.Lazy as TL
-import Prelude
-import System.Environment (getArgs)
+import qualified System.Environment as Env
+import System.IO (IO)
+import qualified Text.WalderLeijen.ANSI.Text as W
import qualified Hcompta.CLI.Args as Args
import qualified Hcompta.CLI.Command as Command
import qualified Hcompta.CLI.Context as C
import qualified Hcompta.CLI.Lang as Lang
import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Lib.Leijen as W
-import Hcompta.Lib.Leijen ((<>))
main :: IO ()
main = do
(c, cmds) <- do
c <- C.context
- getArgs >>= Args.parse c Command.usage Command.options . (c,)
+ Env.getArgs >>= Args.parse c Command.usage Command.options . (c,)
case cmds of
cmd:args -> Command.run c cmd args
[] -> Command.usage c
import Data.Foldable (Foldable, forM_)
import Data.List (concat)
import Data.Maybe (Maybe(..))
+import Data.Monoid ((<>))
import Data.Ord (Ord(..))
import Data.String (String)
import Prelude (($), Bounded(..), IO)
import System.Exit (exitWith, ExitCode(..))
import qualified System.IO as IO
import Text.Show (Show)
+import qualified Text.WalderLeijen.ANSI.Text as W
import qualified Hcompta.CLI.Context as C
import qualified Hcompta.CLI.Lang as Lang
-import Hcompta.Lib.Leijen ((<>))
-import qualified Hcompta.Lib.Leijen as W
+
with_color :: C.Context -> IO.Handle -> IO Bool
with_color c h =
Just b -> return b
debug :: C.Context -> String -> IO ()
-debug c msg = do
+debug c msg =
case C.verbosity c of
v | v >= C.Verbosity_Debug -> do
color <- with_color c IO.stderr
_ -> return ()
error :: Lang.Translate msg W.Doc => C.Context -> msg -> IO ()
-error c msg = do
+error c msg =
case C.verbosity c of
v | v >= C.Verbosity_Error -> do
color <- with_color c IO.stderr
else W.renderCompact True doc
let wrt h = do
color <- with_color context h
- case color of
- True -> W.displayIO h out_colored
- False -> W.displayIO h out
- Data.Foldable.forM_ files $ \(mode, path) ->
+ if color
+ then W.displayIO h out_colored
+ else W.displayIO h out
+ forM_ files $ \(mode, path) ->
case path of
"-" -> wrt IO.stdout
_ ->
--- /dev/null
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+-- {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Hcompta.Expr.Bool where
+
+import Data.Bool
+-- import Data.Either (Either(..))
+-- import Data.Function (($), (.))
+-- import Data.Maybe (Maybe(..))
+-- import Data.Monoid ((<>))
+-- import Data.Proxy (Proxy(..))
+-- import Data.String (String)
+-- import Data.Type.Equality ((:~:)(Refl))
+-- import Text.Show (Show(..))
+
+import Hcompta.Expr.Dup
+-- import Hcompta.Expr.Fun
+-- import Hcompta.Expr.Lit
+
+-- * Class 'Expr_Bool'
+
+-- | /Tagless-final symantics/ for usual logical boolean operators.
+class Expr_Bool repr where
+ neg :: repr Bool -> repr Bool
+ and :: repr Bool -> repr Bool -> repr Bool
+ or :: repr Bool -> repr Bool -> repr Bool
+ xor :: repr Bool -> repr Bool -> repr Bool
+ xor x y = (x `or` y) `and` neg (x `and` y)
+
+instance -- Expr_Bool Dup
+ ( Expr_Bool r1
+ , Expr_Bool r2
+ ) => Expr_Bool (Dup r1 r2) where
+ neg (x1 `Dup` x2) = neg x1 `Dup` neg x2
+ and (x1 `Dup` x2) (y1 `Dup` y2) = and x1 y1 `Dup` and x2 y2
+ or (x1 `Dup` x2) (y1 `Dup` y2) = or x1 y1 `Dup` or x2 y2
+
+{-
+instance -- Expr_from Tree
+ ( Expr_Bool repr
+ , Type_from Tree next
+ , Expr_from Tree repr next (Type_Lit Bool repr next)
+ ) => Expr_from Tree repr (Type_Lit Bool repr next)
+ (Type_Fun_Lit Bool repr next) where
+ expr_from _pty pvar ctx (Raw "And" [raw_x, raw_y]) k =
+ expr_from pvar pvar ctx raw_x $ \ty_x (x::Repr_HO repr _ctx _h_x) ->
+ expr_from pvar pvar ctx raw_y $ \ty_y (y::Repr_HO repr _ctx _h_y) ->
+ case (ty_x, ty_y) of
+ ( Type_Fun_Next Type_Int
+ , Type_Fun_Next Type_Int ) ->
+ k (Type_Fun_Next Type_Int) $ \c -> and (x c) (y c)
+ _ -> Left "Error: And: at least one operand is not an Int"
+ expr_from _pty pvar ctx raw k =
+ expr_from (Proxy::Proxy next) pvar ctx raw k
+-}
+
+{-
+-- * Type 'Type_Bool'
+
+-- | GADT for boolean type:
+--
+-- * singleton (bijective mapping between Haskell type @h@ and the GADT's terms),
+-- * and extensible (through @next@).
+data Type_Bool (next:: * -> *) h where
+ Type_Bool :: Type_Bool next Bool
+ Type_Bool_Next :: next h -> Type_Bool next h
+type Type_Fun_Lit_Bool repr next = Type_Fun repr (Type_Bool next)
+type Type_Fun_Lit_Bool_End repr = Type_Fun_Lit_Bool repr Type_Bool_End
+
+instance -- Type_Eq
+ Type_Eq next =>
+ Type_Eq (Type_Bool next) where
+ type_eq Type_Bool
+ Type_Bool = Just Refl
+ type_eq (Type_Bool_Next x)
+ (Type_Bool_Next y) = x `type_eq` y
+ type_eq _ _ = Nothing
+instance -- Type_from Tree
+ Type_from Tree next =>
+ Type_from Tree (Type_Bool next) where
+ type_from (Tree "Bool" []) k = k Type_Bool
+ type_from raw k = type_from raw $ k . Type_Bool_Next
+instance -- From_Type String
+ From_Type String next =>
+ From_Type String (Type_Bool next) where
+ from_type Type_Bool = "Bool"
+ from_type (Type_Bool_Next t) = from_type t
+--instance -- Show
+-- From_Type String next =>
+-- Show (Type_Bool next h) where
+-- show = from_type
+
+-- ** Type 'Type_Bool_End'
+
+data Type_Bool_End h where
+ Type_Bool_End :: Type_Bool_End ()
+
+instance -- Type_Eq
+ Type_Eq Type_Bool_End where
+ type_eq Type_Bool_End
+ Type_Bool_End = Just Refl
+instance -- Type_from Tree
+ Type_from Tree Type_Bool_End where
+ type_from _ k = k Type_Bool_End
+instance -- Expr_from Tree
+ Show raw =>
+ Expr_from raw repr Type_Bool_End (Type_Fun_Lit_Bool repr Type_Bool_End) where
+ expr_from _pty _pvar _ctx raw _k =
+ Left $ "Error: invalid: " <> show raw
+
+
+fun_lit_bool_from
+ :: forall next raw repr ret.
+ ( Expr_from raw repr (Type_Fun_Lit_Bool repr next) (Type_Fun_Lit_Bool repr next)
+ -- , Expr_from raw repr next (Type_Fun_Lit_Bool repr next)
+ , Expr_Fun repr
+ , Expr_Lit repr
+ , Type_from raw next
+ )
+ => Proxy next
+ -> raw
+ -> (forall h. Type_Fun_Lit_Bool repr next h -> repr h -> Either Error_Type ret)
+ -> Either Error_Type ret
+fun_lit_bool_from _pty raw k =
+ expr_from
+ (Proxy::Proxy (Type_Fun_Lit_Bool repr next))
+ (Proxy::Proxy (Type_Fun_Lit_Bool repr next))
+ Context_Type_Empty raw $ \ty repr ->
+ k ty $ repr Context_Type_Empty
+-}
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Expr.Bool.Test where
+
+import Data.Bool (Bool(..))
+import Data.Function (($))
+
+import Hcompta.Expr.Lit
+import Hcompta.Expr.Bool
+import Hcompta.Expr.Trans
+import Hcompta.Trans.Bool.Const
+import Hcompta.Repr
+
+e1 = lit True `and` lit False
+e2 = (lit True `and` lit False) `or` (lit True `and` lit True)
+e3 = (lit True `or` lit False) `and` (lit True `or` lit True)
+e4 = lit True `and` neg (lit False)
+e5 = lit True `and` neg x
+e6 = x `xor` y
+e7 = (x `xor` y) `xor` z
+e8 = x `xor` (y `xor` lit True)
+
+-- * Class 'Expr_Bool_Vars'
+
+-- | A few boolean variables.
+class Expr_Bool_Vars repr where
+ x :: repr Bool
+ y :: repr Bool
+ z :: repr Bool
+instance -- Trans_Boo_Const
+ ( Expr_Bool_Vars repr
+ , Expr_Lit repr
+ ) => Expr_Bool_Vars (Trans_Bool_Const repr) where
+ x = trans_lift x
+ y = trans_lift y
+ z = trans_lift z
+instance Expr_Bool_Vars Repr_Text_Write where
+ x = Repr_Text_Write $ \_p _v -> "x"
+ y = Repr_Text_Write $ \_p _v -> "y"
+ z = Repr_Text_Write $ \_p _v -> "z"
--- /dev/null
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Hcompta.Expr.Dup where
+
+-- | Data type to duplicate an expression
+-- in order to evaluate it with different interpreters.
+data Dup repr1 repr2 a
+ = Dup
+ { dup1 :: repr1 a
+ , dup2 :: repr2 a
+ }
+
+
+{-
+-- * Whenever we use a value, we have to duplicate it first,
+-- to leave the other copy for different interpreters
+dup_consume ev x =
+ print (ev x1) >> return x2
+ where (x1, x2) = duplicate x
+-}
--- /dev/null
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Expr.Dup.Test where
+
+import Data.Bool (Bool(..))
+import Data.Function (($))
+
+import Hcompta.Expr.Lit
+import Hcompta.Expr.Bool
+import Hcompta.Expr.Fun
+
+-- e1 :: (Boo repr, Lit repr) => repr Bool
+e1 = lit True `and` neg (lit True `and` lit True)
+e2 = let_val (lit True) $ \x -> lit True `and` x
+
--- /dev/null
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Hcompta.Expr.Eq where
+
+import Data.Bool
+import Data.Eq (Eq(..))
+
+import Hcompta.Expr.Dup
+
+-- * Class 'Expr_Eq'
+
+class Expr_Eq repr where
+ eq :: Eq a => repr a -> repr a -> repr Bool
+
+instance (Expr_Eq r1, Expr_Eq r2) => Expr_Eq (Dup r1 r2) where
+ eq (x1 `Dup` x2) (y1 `Dup` y2) = eq x1 y1 `Dup` eq x2 y2
--- /dev/null
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+module Hcompta.Expr.Fun where
+
+import Control.Monad (Monad(..))
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.Bool
+-- import Data.Either (Either(..))
+-- import Data.Eq (Eq(..))
+import Data.Function (($), (.), id)
+import Data.IORef
+-- import Data.Maybe (Maybe(..))
+-- import Data.Monoid ((<>))
+-- import Data.Proxy (Proxy(..))
+-- import Data.String (String)
+-- import Data.Type.Equality ((:~:)(Refl))
+-- import Text.Show (Show(..))
+
+import Hcompta.Expr.Dup
+
+-- * Class 'Expr_Fun'
+
+-- | /Tagless-final symantics/ for /lambda abstraction/
+-- in /higher-order abstract syntax/ (HOAS),
+-- and with argument @arg@ and result @res@ of functions @(->)@ inside 'repr',
+-- wrapped into 'repr': to control the calling.
+class Expr_Fun repr where
+ default app :: Monad repr => repr (repr arg -> repr res) -> repr arg -> repr res
+
+ default inline :: Monad repr => (repr arg -> repr res) -> repr (repr arg -> repr res)
+ default val :: Monad repr => (repr arg -> repr res) -> repr (repr arg -> repr res)
+ default lazy :: MonadIO repr => (repr arg -> repr res) -> repr (repr arg -> repr res)
+
+ default let_inline :: Monad repr => repr arg -> (repr arg -> repr res) -> repr res
+ default let_val :: Monad repr => repr arg -> (repr arg -> repr res) -> repr res
+ default let_lazy :: MonadIO repr => repr arg -> (repr arg -> repr res) -> repr res
+
+ app :: repr (repr arg -> repr res) -> repr arg -> repr res
+ app x y = x >>= ($ y)
+
+ -- | /call-by-name/ lambda
+ inline :: (repr arg -> repr res) -> repr (repr arg -> repr res)
+ inline = return
+ -- | /call-by-value/ lambda
+ val :: (repr arg -> repr res) -> repr (repr arg -> repr res)
+ val f = return (>>= f . return)
+ -- | /call-by-need/ lambda (aka. /lazyness/): lazy shares its argument, no matter what.
+ lazy :: (repr arg -> repr res) -> repr (repr arg -> repr res)
+ lazy f = return ((>>= f) . expr_fun_lazy_share)
+
+ -- | Convenient 'inline' wrapper.
+ let_inline :: repr arg -> (repr arg -> repr res) -> repr res
+ let_inline x y = inline y `app` x
+ -- | Convenient 'val' wrapper.
+ let_val :: repr arg -> (repr arg -> repr res) -> repr res
+ let_val x y = val y `app` x
+ -- | Convenient 'lazy' wrapper.
+ let_lazy :: repr arg -> (repr arg -> repr res) -> repr res
+ let_lazy x y = lazy y `app` x
+
+ ident :: repr a -> repr a
+ ident = id
+
+-- | Utility for storing arguments of 'lazy' into an 'IORef'.
+expr_fun_lazy_share :: MonadIO m => m a -> m (m a)
+expr_fun_lazy_share m = do
+ r <- liftIO $ newIORef (False, m)
+ return $ do
+ (already_evaluated, m') <- liftIO $ readIORef r
+ if already_evaluated
+ then m'
+ else do
+ v <- m'
+ liftIO $ writeIORef r (True, return v)
+ return v
+
+instance -- Expr_Fun Dup
+ ( Expr_Fun r1
+ , Expr_Fun r2
+ , Monad r1
+ , Monad r2
+ ) => Expr_Fun (Dup r1 r2) where
+ app (r1_f `Dup` r2_f) (x1 `Dup` x2) =
+ app (return $ \r1_a -> do
+ f <- r1_f
+ a <- r1_a
+ dup1 $ f (r1_a `Dup` return a)) x1
+ `Dup`
+ app (return $ \r2_a -> do
+ f <- r2_f
+ a <- r2_a
+ dup2 $ f (return a `Dup` r2_a)) x2
+ inline f = dup1 (inline f) `Dup` dup2 (inline f)
+ val f = dup1 (val f) `Dup` dup2 (val f)
+ lazy f = dup1 (lazy f) `Dup` dup2 (lazy f)
+ let_inline (x1 `Dup` x2) in_ =
+ let_inline x1 (\r1_a -> do
+ a <- r1_a
+ dup1 $ in_ $ r1_a `Dup` return a)
+ `Dup`
+ let_inline x2 (\r2_a -> do
+ a <- r2_a
+ dup2 $ in_ $ return a `Dup` r2_a)
+ let_val (x1 `Dup` x2) in_ =
+ let_val x1 (\r1_a -> do
+ a <- r1_a
+ dup1 $ in_ $ r1_a `Dup` return a)
+ `Dup`
+ let_val x2 (\r2_a -> do
+ a <- r2_a
+ dup2 $ in_ $ return a `Dup` r2_a)
+ let_lazy (x1 `Dup` x2) in_ =
+ let_lazy x1 (\r1_a -> do
+ a <- r1_a
+ dup1 $ in_ $ r1_a `Dup` return a)
+ `Dup`
+ let_lazy x2 (\r2_a -> do
+ a <- r2_a
+ dup2 $ in_ $ return a `Dup` r2_a)
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Expr.Fun.Test where
+
+import Data.Bool (Bool(..))
+import Data.Function (($), id)
+
+import Hcompta.Expr.Lit
+import Hcompta.Expr.Bool
+import Hcompta.Expr.Fun
+
+e1 = val $ \x -> val $ \y -> (x `or` y) `and` neg (x `and` y)
+e2 = val $ \x -> val $ \y -> (x `and` neg y) `or` (neg x `and` y)
+e3 = let_val (lit True) $ \x -> x `and` x
+e4 = let_val (val $ \x -> x `and` x) $ \f -> f `app` lit True
+e5 = val $ \x0 -> val $ \x1 -> x0 `and` x1
+e6 = let_val (lit True) id `and` lit False
+e7 = val $ \f -> and (f `app` lit True) (lit False)
+e8 = val $ \f -> f `app` and (lit True) (lit False)
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Hcompta.Expr.If where
+
+import Control.Monad (Monad(..), when)
+import Data.Bool
+
+import Hcompta.Expr.Dup
+
+-- * Class 'Expr_If'
+
+class Expr_If repr where
+ default if_ :: Monad repr => repr Bool -> repr a -> repr a -> repr a
+ default when_ :: Monad repr => repr Bool -> repr () -> repr ()
+
+ if_ :: repr Bool -> repr a -> repr a -> repr a
+ if_ m ok ko = do
+ m' <- m
+ if m' then ok else ko
+
+ when_ :: repr Bool -> repr () -> repr ()
+ when_ m ok = do
+ m' <- m
+ when m' ok
+
+instance -- Expr_If Dup
+ ( Expr_If r1
+ , Expr_If r2
+ ) => Expr_If (Dup r1 r2) where
+ if_ (c1 `Dup` c2) (ok1 `Dup` ok2) (ko1 `Dup` ko2) =
+ if_ c1 ok1 ko1 `Dup`
+ if_ c2 ok2 ko2
+ when_ (c1 `Dup` c2) (ok1 `Dup` ok2) =
+ when_ c1 ok1 `Dup`
+ when_ c2 ok2
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Expr.If.Test where
+
+import Data.Bool (Bool(..))
+
+import Hcompta.Expr.Lit
+import Hcompta.Expr.Bool
+import Hcompta.Expr.If
+
+e1 = if_ (lit True) (lit False) (lit True)
+e2 = if_ (lit True `and` lit True) (lit False) (lit True)
--- /dev/null
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hcompta.Expr.Lit where
+
+-- import Control.Applicative (Applicative(..))
+-- import Control.Monad (Monad(..))
+-- import Control.Monad.Trans.State.Strict as ST
+-- import Data.Bool
+-- import Data.Either (Either(..))
+-- import Data.Eq (Eq(..))
+-- import Data.Function (($), (.))
+-- import Data.Functor (Functor(..))
+-- import Data.Maybe (Maybe(..))
+-- import Data.Monoid ((<>))
+-- import Data.Proxy (Proxy(..))
+-- import Data.String (IsString(..))
+-- import Data.Text (Text)
+-- import qualified Data.Text as Text
+import Data.Text.Buildable (Buildable(..))
+-- import Data.Type.Equality ((:~:)(Refl))
+-- import GHC.Exts (IsList(..))
+-- import Prelude (undefined)
+-- import Text.Read (Read, reads)
+import Text.Show (Show(..))
+
+-- import Hcompta.Lib.Control.Monad
+-- import qualified Hcompta.Lib.Control.Monad.Classes as MC
+-- import qualified Hcompta.Lib.Data.Text.Buildable as Build
+
+import Hcompta.Expr.Dup
+-- import Hcompta.Expr.Fun
+
+-- * Class 'Expr_Lit'
+
+-- | /Tagless-final symantics/ to inject a meta-level term
+-- into and object-level expression.
+class Expr_Lit repr where
+ lit :: (Buildable a, Show a) => a -> repr a
+
+instance -- Expr_Lit Dup
+ ( Expr_Lit r1
+ , Expr_Lit r2
+ ) => Expr_Lit (Dup r1 r2) where
+ lit x = lit x `Dup` lit x
+
+{-
+-- * Type 'Type_Lit'
+
+-- | GADT for boolean type:
+--
+-- * singleton (bijective mapping between Haskell type @h@ and the GADT's terms),
+-- * and extensible (through @next@).
+data Type_Lit lit (next:: * -> *) h where
+ Type_Lit :: Type_Lit lit next lit
+ Type_Lit_Next :: next h -> Type_Lit lit next h
+type Type_Fun_Lit lit repr next = Type_Fun repr (Type_Lit lit next)
+type Type_Fun_Lit_End lit repr = Type_Fun_Lit lit repr Type_Lit_End
+
+instance -- Type_Eq
+ Type_Eq next =>
+ Type_Eq (Type_Lit lit next) where
+ type_eq Type_Lit
+ Type_Lit = Just Refl
+ type_eq (Type_Lit_Next x)
+ (Type_Lit_Next y) = x `type_eq` y
+ type_eq _ _ = Nothing
+instance -- Type_from Tree
+ ( Type_from Tree next
+ , Buildable (Type_Lit_Name lit)
+ ) => Type_from Tree (Type_Lit lit next) where
+ type_from (Tree raw_lit []) k
+ | raw_lit == Build.text (Type_Lit_Name::Type_Lit_Name lit)
+ = k Type_Lit
+ type_from raw k = type_from raw $ k . Type_Lit_Next
+instance -- From_Type Text
+ ( From_Type Text next
+ , Buildable (Type_Lit_Name lit)
+ ) => From_Type Text (Type_Lit lit next) where
+ from_type Type_Lit = Build.text (Type_Lit_Name::Type_Lit_Name lit)
+ from_type (Type_Lit_Next t) = from_type t
+instance -- Expr_from Tree
+ ( Expr_Lit repr
+ , Type_from Tree next
+ , Expr_from Tree repr next (Type_Fun_Lit lit repr next)
+ , Read lit
+ , Show lit
+ , Buildable lit
+ , Buildable (Type_Lit_Name lit)
+ ) => Expr_from Tree repr (Type_Lit lit next) (Type_Fun_Lit lit repr next) where
+ expr_from _pty _pvar _ctx (Tree lit_name [Tree raw_lit []]) k
+ | lit_name == Build.text (Type_Lit_Name::Type_Lit_Name lit) = do
+ l <- repr_lit_read raw_lit
+ k (Type_Fun_Next Type_Lit) $ \_c -> lit l
+ expr_from _pty pvar ctx raw k =
+ expr_from (Proxy::Proxy next) pvar ctx raw k
+
+repr_lit_read :: Read a => Text -> Either Error_Type a
+repr_lit_read t =
+ let s = Text.unpack t in
+ case reads s of
+ [(a, "")] -> Right a
+ _ -> Left $ "Read error: " <> s
+
+instance Monad m => Expr_Lit (ST.StateT s m) where
+ lit = return
+instance Monad m => Expr_Lit (MC.WriterT w m) where
+ lit = return
+
+-- * Type 'Type_Lit_Name'
+
+-- | Data type to get a name from a Haskell type-level literal type.
+data Type_Lit_Name lit = Type_Lit_Name
+instance Buildable (Type_Lit_Name Bool) where
+ build _ = "Bool"
+
+-- * Type 'Type_Lit_End'
+
+-- | Data type to finalize a type at 'Type_Fun_Lit'.
+data Type_Lit_End h where
+ Type_Lit_End :: Type_Lit_End ()
+
+instance -- Type_Eq
+ Type_Eq Type_Lit_End where
+ type_eq Type_Lit_End
+ Type_Lit_End = Just Refl
+instance -- Type_from Tree
+ Type_from Tree Type_Lit_End where
+ type_from _ k = k Type_Lit_End
+instance -- Expr_from Tree
+ Buildable (Type_Lit_Name lit)
+ => Expr_from Tree repr Type_Lit_End (Type_Fun_Lit lit repr Type_Lit_End) where
+ expr_from _pty _pvar _ctx raw _k =
+ Left $ "Error: invalid Type_Lit: "
+ <> Build.string (Type_Lit_Name::Type_Lit_Name lit) <> ": "
+ <> show raw
+-}
+
+{-
+class Literal from to where
+ literal :: from -> to
+instance Applicative repr => Literal a (repr a) where
+ literal = pure
+instance (Applicative repr, IsString a) => Literal String (repr a) where
+ literal = pure . fromString
+instance (Applicative repr, IsString a) => Literal [String] (repr [a]) where
+ literal = pure . (fromString <$>)
+instance Applicative repr => Literal [a] (repr [a]) where
+ literal = pure
+instance Monad repr => Literal [repr a] (repr [a]) where
+ literal = sequence
+instance Literal a a where
+ literal a = a
+-}
+
+{-
+-- * Class 'List'
+class Monad repr => List repr where
+ list :: [repr a] -> repr [a]
+ list = sequence
+instance Monad m => List (ST.StateT s m)
+instance Monad m => List (WriterT w m)
+
+instance (Monad m, Monad (repr m)) => List (repr (m:: * -> *)) where
+ list = sequence
+-}
+-- instance IsList ([a])
+
+{-
+-- Orphan instances for overloading
+instance (IsList a, List (repr m)) => IsList (repr (m:: * -> *) [a]) where
+ type Item (repr m [a]) = repr m a
+ fromList = list
+ toList = undefined
+-}
+
+
+{- NOTE: conflicts with specific instance in Data.DList
+instance (IsList a, List repr) => IsList (repr [a]) where
+ type Item (repr [a]) = repr a
+ fromList = list
+ toList = undefined
+-}
+{-
+instance (Monad repr, IsString a) => IsString (repr a) where
+ fromString = return . fromString
+-}
--- /dev/null
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+module Hcompta.Expr.Log where
+
+import Control.Applicative (Applicative(..))
+import Control.Monad (Monad(..))
+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..))
+import qualified Control.Monad.Classes as MC
+import qualified Control.Monad.Classes.Proxied as MC
+import qualified Control.Monad.Classes.Run as MC
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.Function (($), (.))
+import Data.Functor (Functor(..))
+import Data.Int (Int)
+import Data.Monoid ((<>))
+import Data.Ord (Ord(..))
+import Data.String (IsString(..))
+import Data.Text (Text)
+import Data.Text.Buildable (Buildable(..))
+import qualified Data.Time.LocalTime as Time
+import Prelude (truncate)
+
+import Hcompta.Lib.Data.Monoid (Monoid1)
+
+-- * Type 'Log'
+
+data Log a
+ = Log
+ { log_time :: Time.ZonedTime
+ , log_facility :: Log_Facility
+ , log_data :: a
+ } deriving (Functor)
+instance Buildable x => Buildable (Log x) where
+ build Log{..} =
+ let Time.TimeOfDay h m s =
+ Time.localTimeOfDay $
+ Time.zonedTimeToLocalTime log_time in
+ "[" <> int2 h <>
+ ":" <> int2 m <>
+ ":" <> int2 (truncate s::Int) <>
+ "] " <>
+ build log_facility <> ": " <>
+ build log_data
+ where
+ int2 i = (if i < 10 then "0" else "") <> build i
+
+-- ** Type 'Log_Facility'
+data Log_Facility
+ = Debug
+ | Info
+ | Warn
+instance Buildable Log_Facility where
+ build Debug = "debug"
+ build Info = "info"
+ build Warn = "warn"
+
+log ::
+ ( MC.MonadWriter (Log a) m
+ , MonadIO m
+ ) => Log_Facility -> a -> m ()
+log log_facility log_data = do
+ log_time <- liftIO Time.getZonedTime
+ MC.tell Log
+ { log_time
+ , log_facility
+ , log_data
+ }
+
+-- * Type 'LogT'
+
+-- | A 'Monad' transformer to handle different log data types,
+-- eventually embedded (through class instances) into a single data type
+-- put in the 'Monad' stack with 'MC.MonadWriter'.
+newtype LogT w m a = LogT (MC.CustomWriterT' (Log w) m m a)
+ deriving
+ ( Functor, Applicative, Monoid1
+ , Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)
+
+evalLogWith
+ :: forall w m a . (Log w -> m ())
+ -> LogT w m a
+ -> m a
+evalLogWith tellFn a =
+ MC.reify tellFn $ \px ->
+ case a of
+ LogT (MC.CustomWriterT (MC.Proxied a')) -> a' px
+
+-- ** Type 'Log_Message'
+
+newtype Log_Message = Log_Message Text
+instance Buildable Log_Message where
+ build (Log_Message x) = build x
+instance IsString Log_Message where
+ fromString = Log_Message . fromString
--- /dev/null
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Hcompta.Expr.Maybe where
+
+import Data.Maybe (Maybe(..))
+import Control.Monad (Monad(..))
+import Data.Function (($))
+
+import Hcompta.Expr.Dup
+
+-- * Class 'Expr_Maybe'
+
+class Expr_Maybe repr where
+ default may
+ :: Monad repr
+ => repr (Maybe a)
+ -> repr b
+ -> repr ((->) (repr a) (repr b))
+ -> repr b
+ default nothing
+ :: Monad repr
+ => repr (Maybe a)
+ default just
+ :: Monad repr
+ => repr a
+ -> repr (Maybe a)
+
+ may
+ :: repr (Maybe a)
+ -> repr b
+ -> repr ((->) (repr a) (repr b))
+ -> repr b
+ may r_m r_n r_j = do
+ m <- r_m
+ case m of
+ Nothing -> r_n
+ Just x -> do
+ j <- r_j
+ j (return x)
+ nothing :: repr (Maybe a)
+ nothing = return Nothing
+ just :: repr a -> repr (Maybe a)
+ just r_a = do
+ a <- r_a
+ return $ Just a
+
+instance -- Expr_Maybe Dup
+ ( Expr_Maybe r1
+ , Expr_Maybe r2
+ , Monad r1
+ , Monad r2
+ ) => Expr_Maybe (Dup r1 r2) where
+ may (m1 `Dup` m2) (n1 `Dup` n2) (r1_j `Dup` r2_j) =
+ may m1 n1 (return $ \r1_a -> do
+ j <- r1_j
+ a <- r1_a
+ dup1 $ j $ r1_a `Dup` return a)
+ `Dup`
+ may m2 n2 (return $ \r2_a -> do
+ j <- r2_j
+ a <- r2_a
+ dup2 $ j $ return a `Dup` r2_a)
+ nothing = nothing `Dup` nothing
+ just (a1 `Dup` a2) = just (a1 `Dup` a2)
--- /dev/null
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Hcompta.Expr.Ord where
+
+import Data.Bool
+import Data.Ord (Ord(..))
+
+import Hcompta.Expr.Bool
+import Hcompta.Expr.Eq
+import Hcompta.Expr.Dup
+
+-- * Class 'Expr_Ord'
+
+class
+ ( Expr_Bool repr
+ , Expr_Eq repr
+ ) => Expr_Ord repr where
+ lt :: Ord a => repr a -> repr a -> repr Bool
+
+ le :: Ord a => repr a -> repr a -> repr Bool
+ le x y = (x `lt` y) `or` (x `eq` y)
+
+ ge :: Ord a => repr a -> repr a -> repr Bool
+ ge x y = neg (x `lt` y)
+
+ gt :: Ord a => repr a -> repr a -> repr Bool
+ gt x y = neg (x `le` y)
+
+instance -- Expr_Ord Dup
+ ( Expr_Ord r1
+ , Expr_Ord r2
+ ) => Expr_Ord (Dup r1 r2) where
+ lt (x1 `Dup` x2) (y1 `Dup` y2) = lt x1 y1 `Dup` lt x2 y2
+ le (x1 `Dup` x2) (y1 `Dup` y2) = le x1 y1 `Dup` le x2 y2
+ ge (x1 `Dup` x2) (y1 `Dup` y2) = ge x1 y1 `Dup` ge x2 y2
+ gt (x1 `Dup` x2) (y1 `Dup` y2) = gt x1 y1 `Dup` gt x2 y2
--- /dev/null
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Hcompta.Expr.Set where
+
+import Hcompta.Expr.Dup
+
+-- * Class 'Expr_Set'
+
+class Expr_Set repr where
+ complement :: repr a -> repr a
+ intersection :: repr a -> repr a -> repr a
+ union :: repr a -> repr a -> repr a
+
+instance -- Expr_Set Dup
+ ( Expr_Set r1
+ , Expr_Set r2
+ ) => Expr_Set (Dup r1 r2) where
+ complement (x1 `Dup` x2) = complement x1 `Dup` complement x2
+ intersection (x1 `Dup` x2) (y1 `Dup` y2) = intersection x1 y1 `Dup` intersection x2 y2
+ union (x1 `Dup` x2) (y1 `Dup` y2) = union x1 y1 `Dup` union x2 y2
--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Hcompta.Expr.Trans where
+
+import Data.Function ((.))
+
+-- |
+-- * 'trans_lift' is generally not /surjective/
+-- * 'trans_apply' is not /injective/
+-- * 'trans_apply' . 'trans_lift' == 'id'
+-- * 'trans_lift' . 'trans_apply' /= 'id'
+class Trans trans repr where
+ trans_lift :: repr a -> trans repr a
+ trans_apply :: trans repr a -> repr a
+
+ trans_map1 :: (repr a -> repr b) -> (trans repr a -> trans repr b)
+ trans_map1 f = trans_lift . f . trans_apply
+
+ trans_map2
+ :: (repr a -> repr b -> repr c)
+ -> (trans repr a -> trans repr b -> trans repr c)
+ trans_map2 f e1 e2 = trans_lift (f (trans_apply e1) (trans_apply e2))
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+module Hcompta.Lib.Control.Monad where
+
+import Control.Applicative (Applicative(..))
+import Control.Monad (Monad(..), (=<<), liftM2, liftM3, liftM4, join)
+import Data.Bool
+import Data.Maybe (Maybe(..), maybe)
+
+-- * 'Monad'ic utilities
+
+-- | Perform some operation on 'Just', given the field inside the 'Just'.
+whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
+whenJust mg f = maybe (pure ()) f mg
+
+-- | Like 'when', but where the test can be 'Monad'-ic.
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM b t = ifM b t (return ())
+
+-- | Like 'unless', but where the test can be 'Monad'-ic.
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM b = ifM b (return ())
+
+-- | Like @if@, but where the test can be 'Monad'-ic.
+ifM :: Monad m => m Bool -> m a -> m a -> m a
+ifM b t f = do b' <- b; if b' then t else f
+
+-- | Like 'liftM' but 'join' the result of the lifted function.
+liftMJoin :: Monad m => (a -> m b) -> m a -> m b
+liftMJoin = (=<<)
+
+-- | Like 'liftM2' but 'join' the result of the lifted function.
+liftM2Join :: Monad m => (a -> b -> m c) -> m a -> m b -> m c
+liftM2Join f ma mb = join (liftM2 f ma mb)
+
+-- | Like 'liftM3' but 'join' the result of the lifted function.
+liftM3Join :: Monad m => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d
+liftM3Join f ma mb mc = join (liftM3 f ma mb mc)
+
+-- | Like 'liftM3' but 'join' the result of the lifted function.
+liftM4Join :: Monad m => (a -> b -> c -> d -> m e) -> m a -> m b -> m c -> m d -> m e
+liftM4Join f ma mb mc md = join (liftM4 f ma mb mc md)
--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hcompta.Lib.Control.Monad.Classes where
+
+import Control.Monad (Monad(..))
+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..))
+import qualified Control.Monad.Classes.Proxied as MC
+import qualified Control.Monad.Classes.Run as MC
+import Data.Function (($))
+
+-- * Type @Control.Monad.Classes.Writer.@'CustromWriterT' (orphan instances)
+
+-- | Type synonym to @Control.Monad.Classes.Writer.@'MC.CustomWriterT'', /eta-reduced/.
+type WriterT w m = MC.CustomWriterT' w m m
+deriving instance (Monad m, MonadThrow m) => MonadThrow (WriterT w m)
+deriving instance (Monad m, MonadCatch m) => MonadCatch (WriterT w m)
+deriving instance (Monad m, MonadMask m) => MonadMask (WriterT w m)
+
+-- * Type @Control.Monad.Classes.Proxied.@'MC.Proxied' (orphan instances)
+
+instance MonadThrow m => MonadThrow (MC.Proxied x m) where
+ -- throwM :: Exception e => e -> m a
+ throwM e = MC.Proxied (\_px -> throwM e)
+
+instance MonadCatch m => MonadCatch (MC.Proxied x m) where
+ -- catch :: Exception e => m a -> (e -> m a) -> m a
+ catch (MC.Proxied f) h =
+ MC.Proxied $ \px ->
+ f px `catch` \e ->
+ case h e of
+ MC.Proxied f' -> f' px
+
+-- newtype Proxied x m a = Proxied (forall (q :: *). R.Reifies q x => Proxy# q -> m a)
+instance (MonadCatch m, MonadMask m) => MonadMask (MC.Proxied x m) where
+ -- mask :: MonadMask m => ((forall a. m a -> m a) -> m b) -> m b
+ mask restore =
+ MC.Proxied $ \px ->
+ mask $ \r ->
+ case restore (\(MC.Proxied f) -> MC.Proxied $ \px' -> r (f px')) of
+ MC.Proxied f -> f px
+ -- uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
+ uninterruptibleMask restore =
+ MC.Proxied $ \px ->
+ uninterruptibleMask $ \r ->
+ case restore (\(MC.Proxied f) -> MC.Proxied $ \px' -> r (f px')) of
+ MC.Proxied f -> f px
--- /dev/null
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+module Hcompta.Lib.Data.Default where
+
+-- * Class 'Default'
+
+class Default a where
+ def :: a
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hcompta.Lib.Data.Monoid where
+
+import Control.Monad (Monad(..), liftM2)
+import Control.Monad.Trans.State.Strict as ST
+import Data.Monoid (Monoid(..))
+import qualified Hcompta.Lib.Control.Monad.Classes as MC
+import System.IO (IO)
+
+-- * Class 'Monoid1' (contain orphan instances)
+
+-- | 'Monoid' lifted to unary type constructor.
+class Monoid1 expr where
+ mempty1 :: Monoid a => expr a
+ mappend1 :: Monoid a => expr a -> expr a -> expr a
+instance Monoid1 IO where
+ mempty1 = mempty
+ mappend1 = mappend
+instance (Monoid1 m, Monad m) => Monoid1 (ST.StateT s m) where
+ mempty1 = mempty
+ mappend1 = mappend
+instance (Monad m, Monoid a) => Monoid (ST.StateT s m a) where
+ mempty = return mempty
+ mappend = liftM2 mappend
+instance Monoid a => Monoid (IO a) where
+ mempty = return mempty
+ mappend = liftM2 mappend
+instance (Monoid1 m, Monad m) => Monoid1 (MC.WriterT w m) where
+ mempty1 = mempty
+ mappend1 = mappend
+instance (Monad m, Monoid a) => Monoid (MC.WriterT w m a) where
+ mempty = return mempty
+ mappend = liftM2 mappend
+
--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hcompta.Lib.Data.Text where
+
+import Data.Char (Char)
+import Data.Eq (Eq(..))
+import qualified Data.List as List
+import Data.Maybe (Maybe(..))
+import Data.String (String)
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+-- * Class 'SplitOnChar'
+
+class SplitOnChar t where
+ splitOnChar :: Char -> t -> [t]
+instance SplitOnChar Text where
+ splitOnChar sep t =
+ case Text.uncons t of
+ Nothing -> []
+ Just (x, xs) ->
+ if x == sep
+ then splitOnChar sep xs
+ else
+ let (chunk, rest) = Text.break (== sep) t in
+ chunk:splitOnChar sep rest
+instance SplitOnChar String where
+ splitOnChar sep t =
+ case t of
+ [] -> []
+ x:xs ->
+ if x == sep
+ then splitOnChar sep xs
+ else
+ let (chunk, rest) = List.break (== sep) t in
+ chunk:splitOnChar sep rest
+
+-- * Class 'SplitOnCharWithEmpty'
+
+class SplitOnCharWithEmpty t where
+ splitOnCharWithEmpty :: Char -> t -> [t]
+instance SplitOnCharWithEmpty Text where
+ splitOnCharWithEmpty sep t =
+ case Text.break (== sep) t of
+ (chunk, Text.uncons -> Just (_, rest)) -> chunk : splitOnCharWithEmpty sep rest
+ (chunk, _) -> [chunk]
+instance SplitOnCharWithEmpty String where
+ splitOnCharWithEmpty sep t =
+ case List.break (== sep) t of
+ (chunk, _:rest) -> chunk : splitOnCharWithEmpty sep rest
+ (chunk, []) -> [chunk]
--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hcompta.Lib.Data.Text.Buildable where
+import Data.Function (($), (.))
+import Data.Functor ((<$>))
+import Data.Foldable (Foldable(..))
+import Data.Monoid (Monoid(..), (<>))
+import qualified Data.List as List
+import Data.String (String)
+import Data.Text (Text)
+import Data.Eq (Eq(..))
+import qualified Data.Text as Text
+import Data.Text.Buildable (Buildable(..))
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as Build
+import Data.Text.Lazy.Builder (Builder)
+
+string :: Buildable a => a -> String
+string = TL.unpack . Build.toLazyText . build
+
+text :: Buildable a => a -> Text
+text = TL.toStrict . Build.toLazyText . build
+
+tuple :: (Foldable f, Buildable a) => f a -> Builder
+tuple f = "(" <> mconcat (List.intersperse ", " $ foldr ((:) . build) [] f) <> ")"
+
+list :: (Foldable f, Buildable a) => f a -> Builder
+list f = "[" <> mconcat (List.intersperse ", " $ foldr ((:) . build) [] f) <> "]"
+
+words :: (Foldable f, Buildable a) => f a -> Builder
+words f = mconcat (List.intersperse " " $ foldr ((:). build) [] f)
+
+words_quoted :: (Foldable f, Buildable a) => f a -> Builder
+words_quoted f =
+ mconcat (List.intersperse " " $
+ foldr ((:) . quote) [] f)
+ where quote a =
+ let t = text a in
+ if Text.any (== ' ') t
+ then "'"<>build t<>"'"
+ else build t
+
+unlines :: (Foldable f, Buildable a) => f a -> Builder
+unlines = mconcat . List.intersperse "\n" . foldr ((:) . build) []
+
+indent :: Buildable a => Builder -> a -> Builder
+indent prefix =
+ mconcat . List.intersperse "\n" .
+ ((prefix <>) . build <$>) . TL.lines .
+ Build.toLazyText . build
+
+parens :: Buildable a => a -> Builder
+parens a = "(" <> build a <> ")"
+
+{-
+instance Buildable a => Buildable [a] where
+ build = list
+-}
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Hadmin.Lib.System.File.Path where
+
+import Data.Foldable (foldMap)
+import Data.Function (($), (.))
+import Data.Functor (Functor(..), (<$>))
+import qualified Data.List as List
+import Data.Maybe (Maybe(..))
+import Data.Monoid (Monoid(..), (<>))
+import Data.String (IsString(..))
+import Data.Text (Text)
+import Data.Text.Buildable (Buildable(..))
+import GHC.Exts (IsList(..))
+import Prelude (undefined)
+import qualified System.FilePath.Posix as FP
+
+import Hadmin.Lib.Data.Text
+
+-- * Type 'Path'
+type Path pos a = InPos pos (InDir a)
+
+-- * Type 'Position'
+data Position = Absolute | Relative
+
+-- ** Type 'SPos'
+-- | Singleton type for 'Position'.
+data SPos pos where
+ Abs :: SPos 'Absolute
+ Rel :: SPos 'Relative
+
+-- ** Type 'IPos'
+
+-- | Implicit class for 'Position'.
+class IPos pos where
+ pos :: SPos pos
+instance IPos 'Absolute where pos = Abs
+instance IPos 'Relative where pos = Rel
+
+-- ** Type 'InPos'
+data InPos pos a = InPos (SPos pos) a
+ deriving (Functor)
+instance Buildable a => Buildable (InPos pos a) where
+ build (InPos Abs a) = build FP.pathSeparator <> build a
+ build (InPos Rel a) = build a
+instance (IsString a, IPos pos) => IsString (InPos pos a) where
+ fromString = InPos pos . fromString
+
+-- ** Type 'PosOf'
+type family PosOf x :: Position
+type instance PosOf (InPos pos a) = pos
+
+-- * Type 'Dir'
+
+newtype Dir = Dir [Dir_Seg]
+ deriving (Monoid)
+type Dir_Seg = Text
+type AbsDir = InPos 'Absolute Dir
+type RelDir = InPos 'Relative Dir
+instance IsString Dir where
+ fromString = Dir . (fromString <$>) . splitOnChar FP.pathSeparator
+instance IsList Dir where
+ type Item Dir = Dir_Seg
+ fromList = Dir . foldMap (splitOnChar FP.pathSeparator)
+ toList (Dir d) = toList d
+instance Buildable Dir where
+ build (Dir []) = "."
+ build (Dir p) =
+ mconcat $
+ List.intersperse
+ (build FP.pathSeparator)
+ (build <$> p)
+
+{-
+absDir :: InPos pos a -> InPos 'Absolute a
+absDir (InPos _p a) = InPos Abs a
+
+relDir :: InPos pos a -> InPos 'Relative a
+relDir (InPos _p a) = InPos Rel a
+-}
+
+-- ** Type 'InDir'
+data InDir a = InDir Dir a
+ deriving (Functor)
+instance IsString (a -> InDir a) where
+ fromString = InDir . fromString
+instance IsString a => IsString (InDir a) where
+ fromString s =
+ case splitOnChar FP.pathSeparator s of
+ [] -> InDir (Dir []) $ fromString ""
+ l -> InDir (Dir $ fromString <$> List.init l) $ fromString (List.last l)
+instance IsList (a -> InDir a) where
+ type Item (a -> InDir a) = Dir_Seg
+ fromList = InDir . fromList
+ toList = undefined
+instance Buildable a => Buildable (InDir a) where
+ build (InDir d a) = build d <> build FP.pathSeparator <> build a
+
+-- ** Class 'Dir_Parent'
+
+-- | Return the parent 'Dir' of given 'Dir'
+class Dir_Parent d where
+ type Dir_Parent_Dir d
+ dir_parent :: d -> Maybe (Dir_Parent_Dir d)
+
+instance Dir_Parent Dir where
+ type Dir_Parent_Dir Dir = Dir
+ dir_parent (Dir p) =
+ case p of
+ [] -> Nothing
+ _ -> Just $ Dir (List.init p)
+instance Dir_Parent a => Dir_Parent (InPos pos a) where
+ type Dir_Parent_Dir (InPos pos a) = InPos pos (Dir_Parent_Dir a)
+ dir_parent (InPos p a) = InPos p <$> dir_parent a
+instance Dir_Parent (InDir a) where
+ type Dir_Parent_Dir (InDir a) = Dir
+ dir_parent (InDir d _a) = Just d
+{-
+instance Dir_Parent File where
+ type Dir_Parent_Dir File = Dir
+ dir_parent (File _f) = Just $ Dir []
+-}
+
+-- ** Class 'Dir_Ancestors'
+
+-- | Return self and parents 'Dir' of given 'Dir', in topological order.
+class Dir_Ancestors d where
+ type Dir_Ancestors_Dir d
+ dir_ancestors :: d -> [Dir_Parent_Dir d]
+
+instance Dir_Ancestors Dir where
+ type Dir_Ancestors_Dir Dir = Dir
+ dir_ancestors (Dir p) =
+ List.reverse $
+ List.foldl' (\acc seg ->
+ case acc of
+ [] -> [Dir [seg]]
+ Dir d:_ -> Dir (d<>[seg]):acc
+ ) [Dir []] p
+instance Dir_Ancestors a => Dir_Ancestors (InPos pos a) where
+ type Dir_Ancestors_Dir (InPos pos a) = InPos pos (Dir_Ancestors_Dir a)
+ dir_ancestors (InPos p a) = InPos p <$> dir_ancestors a
+instance Dir_Ancestors (InDir a) where
+ type Dir_Ancestors_Dir (InDir a) = Dir
+ dir_ancestors (InDir d _a) = dir_ancestors d
+{-
+instance Dir_Ancestors File where
+ type Dir_Ancestors_Dir File = Dir
+ dir_ancestors (File _f) = [Dir []]
+-}
+
+-- ** Class 'Dir_Append'
+class Dir_Append p q where
+ type Dir_Append_Dir p q
+ (</>) :: p -> q -> Dir_Append_Dir p q
+instance Dir_Append (InPos p Dir) (InPos 'Relative Dir) where
+ type Dir_Append_Dir (InPos p Dir) (InPos 'Relative Dir) = InPos p Dir
+ (</>) (InPos p x) (InPos _q y) = InPos p (x <> y)
+instance Dir_Append (InPos p Dir) File where
+ type Dir_Append_Dir (InPos p Dir) File = InPos p (InDir File)
+ (</>) (InPos p d) f = InPos p (InDir d f)
+instance Dir_Append (InPos p Dir) (InPos 'Relative (InDir a)) where
+ type Dir_Append_Dir (InPos p Dir) (InPos 'Relative (InDir a)) = InPos p (InDir a)
+ (</>) (InPos p x) (InPos _q (InDir y a)) = InPos p (InDir (x <> y) a)
+
+-- * Type 'File'
+newtype File = File [Text]
+instance IsString File where
+ fromString = File . (fromString <$>) . splitOnCharWithEmpty FP.extSeparator
+instance Buildable File where
+ build (File p) =
+ mconcat $
+ List.intersperse
+ (build FP.extSeparator)
+ (build <$> p)
+
+type RelFile = InPos 'Relative (InDir File)
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NoIncoherentInstances #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoUndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Hcompta.Repr.Meta where
+
+import Control.Applicative (Applicative(..))
+-- import Control.Exception.Safe (MonadThrow, MonadCatch, MonadMask)
+-- import qualified Control.Exception.Safe as Exn
+import Control.Monad (Monad(..))
+-- import qualified Control.Monad.Classes as MC
+-- import qualified Control.Monad.Classes.Write as MC
+import Control.Monad.IO.Class (MonadIO(..))
+-- import Control.Monad.Trans.Class
+-- import Control.Monad.Trans.State.Strict as ST
+import Data.Bool
+-- import Data.Either (Either(..))
+import Data.Eq (Eq(..))
+-- import Data.Foldable (asum)
+import Data.Function (($), (.))
+import Data.Functor (Functor(..))
+-- import Data.Int (Int)
+-- import qualified Data.List as List
+-- import Data.Maybe (Maybe(..), fromMaybe)
+-- import Data.Monoid ((<>))
+-- import Data.Ord (Ord(..))
+-- import Data.Text (Text)
+-- import qualified Data.Text as Text
+-- import Data.Text.Buildable (Buildable(..))
+-- import qualified Data.Text.Lazy.Builder as TL (Builder)
+-- import Prelude (pred, succ)
+-- import Text.Show (Show(..))
+
+import Hcompta.Expr
+import Hcompta.Lib.Control.Monad
+-- import Hcompta.Lib.Data.Monoid (Monoid1)
+-- import Hcompta.Lib.Data.Text as Text
+
+-- * Type 'Write'
+
+-- | Meta-circular /tagless-final interpreter/,
+-- producing an Haskell term of type @h@.
+newtype Meta m h
+ = Meta
+ { unMeta :: m h }
+ deriving (Applicative, Functor, Monad, MonadIO)
+
+run :: Meta m h -> m h
+run = unMeta
+
+instance Monad m => Expr_Lit (Meta m) where
+ lit = Meta . return
+instance Monad m => Expr_Bool (Meta m) where
+ and = liftM2Join $ \x y -> Meta $ return $ x && y
+ or = liftM2Join $ \x y -> Meta $ return $ x || y
+ neg = liftMJoin $ \x -> Meta $ return $ not x
+instance Monad m => Expr_Eq (Meta m) where
+ eq = liftM2Join $ \x y -> Meta $ return $ x == y
+instance MonadIO m => Expr_Fun (Meta m)
--- /dev/null
+module Repr.Test where
+
+import Test.Tasty
+import qualified Repr.Tree.Test as Text
+import qualified Repr.Text.Test as Tree
+
+tests :: TestTree
+tests =
+ testGroup "Repr"
+ [ Text.tests
+ , Tree.tests
+ ]
--- /dev/null
+module Hcompta.Repr.Text
+ ( module Hcompta.Repr.Text.Write
+ ) where
+
+import Hcompta.Repr.Text.Write
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+module Repr.Text.Test where
+
+import Test.Tasty
+import qualified Repr.Text.Write.Test as Write
+
+tests :: TestTree
+tests =
+ testGroup "Text"
+ [ Write.tests
+ ]
--- /dev/null
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+-- {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NoIncoherentInstances #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoUndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Hcompta.Repr.Text.Write where
+
+import Data.Eq (Eq(..))
+import Data.Function (($), (.))
+import Data.Int (Int)
+import Data.Monoid ((<>))
+import Data.Ord (Ord(..))
+import Data.Text.Buildable (Buildable(..))
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TL
+import Prelude (pred, succ)
+import Text.Show (Show(..))
+
+import Hcompta.Expr
+
+-- * Type 'Repr_Text_Write'
+
+-- | /Tagless-final interpreter/
+-- to evaluate an expression to a 'TL.Builder'.
+newtype Repr_Text_Write h
+ = Repr_Text_Write
+ { unRepr_Text_Write
+ :: Precedence -> Var_Depth -- inherited attributes
+ -> TL.Builder -- synthetised attributes
+ }
+{-
+data Write_Inh
+ = Write_Inh
+ { Write_Precedence :: Precedence
+ , Write_Var_Depth :: Var_Depth
+ }
+data Write_Syn
+ = Write_Syn
+ { Write_Syn_Text :: TL.Builder
+ }
+-}
+type Var_Depth = Int
+
+repr_text_write :: Repr_Text_Write a -> TL.Builder
+repr_text_write x = unRepr_Text_Write x precedence_Toplevel 0
+instance Show (Repr_Text_Write a) where
+ show = TL.unpack . TL.toLazyText . repr_text_write
+
+instance Expr_Lit Repr_Text_Write where
+ lit a = Repr_Text_Write $ \_p _v -> build a
+instance Expr_Bool Repr_Text_Write where
+ and (Repr_Text_Write x) (Repr_Text_Write y) =
+ Repr_Text_Write $ \p v ->
+ let p' = precedence_And in
+ paren p p' $ x p' v <> " & " <> y p' v
+ or (Repr_Text_Write x) (Repr_Text_Write y) =
+ Repr_Text_Write $ \p v ->
+ let p' = precedence_Or in
+ paren p p' $ x p' v <> " | " <> y p' v
+ neg (Repr_Text_Write x) =
+ Repr_Text_Write $ \p v ->
+ let p' = precedence_Neg in
+ paren p p' $ "!" <> x (precedence_succ p') v
+instance Expr_Fun Repr_Text_Write where
+ app (Repr_Text_Write f) (Repr_Text_Write x) = Repr_Text_Write $ \p v ->
+ let p' = precedence_App in
+ paren p p' $
+ f p' v <> " " <> x p' v
+ lazy = repr_text_write_fun "~"
+ val = repr_text_write_fun ""
+ inline = repr_text_write_fun "!"
+ let_lazy = repr_text_write_let "~"
+ let_val = repr_text_write_let ""
+ let_inline = repr_text_write_let "!"
+
+-- ** Instance 'Fun' helpers
+repr_text_write_fun :: TL.Builder -> (Repr_Text_Write a2 -> Repr_Text_Write a1) -> Repr_Text_Write a
+repr_text_write_fun mode e =
+ Repr_Text_Write $ \p v ->
+ let p' = precedence_Fun in
+ let x = "x" <> build v in
+ paren p p' $
+ "\\" <> mode <> x <> " -> " <>
+ unRepr_Text_Write (e (Repr_Text_Write $ \_p _v -> x)) p' (succ v)
+repr_text_write_let
+ :: TL.Builder
+ -> Repr_Text_Write a1
+ -> (Repr_Text_Write a3 -> Repr_Text_Write a2)
+ -> Repr_Text_Write a
+repr_text_write_let mode e in_ =
+ Repr_Text_Write $ \p v ->
+ let p' = precedence_Let in
+ let x = "x" <> build v in
+ paren p p' $
+ "let" <> mode <> " " <> x <> " = " <> unRepr_Text_Write e p (succ v) <> " in " <>
+ unRepr_Text_Write (in_ (Repr_Text_Write $ \_p _v -> x)) p (succ v)
+
+instance Expr_If Repr_Text_Write where
+ if_
+ (Repr_Text_Write cond)
+ (Repr_Text_Write ok)
+ (Repr_Text_Write ko) =
+ Repr_Text_Write $ \p v ->
+ let p' = precedence_If in
+ paren p p' $
+ "if " <> cond p' v <>
+ " then " <> ok p' v <>
+ " else " <> ko p' v
+ when_ (Repr_Text_Write cond) (Repr_Text_Write ok) =
+ Repr_Text_Write $ \p v ->
+ let p' = precedence_If in
+ paren p p' $
+ "when " <> cond p' v <>
+ " " <> ok p' v
+
+-- ** Type 'Precedence'
+
+-- TODO: use an Enum?
+newtype Precedence = Precedence Int
+ deriving (Eq, Ord, Show)
+precedence_pred :: Precedence -> Precedence
+precedence_pred (Precedence p) = Precedence (pred p)
+precedence_succ :: Precedence -> Precedence
+precedence_succ (Precedence p) = Precedence (succ p)
+paren :: Precedence -> Precedence -> TL.Builder -> TL.Builder
+paren prec prec' x =
+ if prec >= prec'
+ then "(" <> x <> ")"
+ else x
+
+precedence_Toplevel :: Precedence
+precedence_Toplevel = Precedence 0
+precedence_Fun :: Precedence
+precedence_Fun = Precedence 1
+precedence_Let :: Precedence
+precedence_Let = Precedence 2
+precedence_If :: Precedence
+precedence_If = Precedence 3
+precedence_Or :: Precedence
+precedence_Or = Precedence 4
+precedence_And :: Precedence
+precedence_And = Precedence 5
+precedence_App :: Precedence
+precedence_App = Precedence 6
+precedence_Neg :: Precedence
+precedence_Neg = Precedence 7
+precedence_Atomic :: Precedence
+precedence_Atomic = Precedence 8
--- /dev/null
+{-# LANGUAGE OverloadedStrings #-}
+
+module Repr.Text.Write.Test where
+
+import Data.Function (($))
+import Data.Text.Lazy.Builder as Build
+import qualified Data.Text.Lazy as Text
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import qualified Expr.Fun.Test as Fun
+import qualified Expr.If.Test as If
+import qualified Expr.Bool.Test as Bool
+import Hcompta.Repr
+
+tests :: TestTree
+tests = testGroup "Write" $
+ let (==>) expr expected =
+ testCase (Text.unpack expected) $
+ Build.toLazyText (repr_text_write expr) @?=
+ expected
+ in
+ [ testGroup "Bool"
+ [ Bool.e1 ==> "True & False"
+ , Bool.e2 ==> "True & False | True & True"
+ , Bool.e3 ==> "(True | False) & (True | True)"
+ , Bool.e4 ==> "True & !False"
+ , Bool.e5 ==> "True & !x"
+ , Bool.e6 ==> "(x | y) & !(x & y)"
+ , Bool.e7 ==> "((x | y) & !(x & y) | z) & !(((x | y) & !(x & y)) & z)"
+ , Bool.e8 ==> "(x | (y | True) & !(y & True)) & !(x & ((y | True) & !(y & True)))"
+ ]
+ , testGroup "Fun"
+ [ Fun.e1 ==> "\\x0 -> (\\x1 -> (x0 | x1) & !(x0 & x1))"
+ , Fun.e2 ==> "\\x0 -> (\\x1 -> x0 & !x1 | !x0 & x1)"
+ , Fun.e3 ==> "let x0 = True in x0 & x0"
+ , Fun.e4 ==> "let x0 = \\x1 -> x1 & x1 in x0 True"
+ , Fun.e5 ==> "\\x0 -> (\\x1 -> x0 & x1)"
+ , Fun.e6 ==> "(let x0 = True in x0) & False"
+ , Fun.e7 ==> "\\x0 -> x0 True & False"
+ , Fun.e8 ==> "\\x0 -> x0 (True & False)"
+ ]
+ , testGroup "If"
+ [ If.e1 ==> "if True then False else True"
+ , If.e2 ==> "if True & True then False else True"
+ ]
+ ]
+
--- /dev/null
+module Hcompta.Repr.Tree
+ ( module Hcompta.Repr.Tree.Read
+ ) where
+
+import Hcompta.Repr.Tree.Read
--- /dev/null
+module Hcompta.Repr.Tree.Read where
--- /dev/null
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE NoPolyKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+module Repr.Tree.Read.Test where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import Control.Monad (Monad(..))
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Applicative (Applicative(..), Const(..))
+import Data.Bool (Bool(..))
+import Data.Either (Either(..))
+import Data.Eq (Eq(..))
+import Data.Function (($), (.), id)
+import Data.Functor (Functor(..), (<$>))
+import Data.Monoid ((<>))
+import Data.String (String)
+import Data.Int (Int)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Text.Buildable (Buildable(..))
+import Data.Text.Lazy.Builder as Build
+import Text.Read (Read, reads)
+import Text.Show (Show(..))
+import Prelude (error, print, IO, undefined, succ)
+import GHC.Prim (Constraint)
+import Data.Proxy (Proxy(..))
+
+import Hcompta.Expr.Lit
+import Hcompta.Expr.Bool
+import Hcompta.Expr.Fun
+import Hcompta.Expr.Dup
+import qualified Expr.Dup.Test as Dup
+import Hcompta.Repr
+import Hcompta.Type
+
+tests :: TestTree
+tests = testGroup "Read" $
+ {-let (==>) (tree::Tree) expected@(text::Text) =
+ fun_lit_bool_from (Proxy::Proxy (Type_Fun_Lit_Bool_End repr)) tree $ \ty repr ->
+ case ty of
+ Type_Fun_Next (Type_Litkkk)
+ case of
+ Left err -> testCase (show expected) $ "" @?= "Error: " <> err
+ Right (expr_write {-`Dup` expr_meta-}) ->
+ testGroup (show expected)
+ [ testCase "Text" $ Build.toLazyText (repr_text_write expr_write) @?= text
+ -- , testCase "Meta" $ repr_meta expr_meta >>= (@?= meta)
+ ] in
+ [ Tree "And" [Tree "Bool" [Tree "True"], Tree "Bool" [Tree "False"]]
+ ==> "True & False"
+ ]-}
+ []
+{-
+ let (==>) tree expected@(text, meta) =
+ case fromTree tree of
+ Left err -> testCase (show expected) $ "" @?= "Error: " <> err
+ Right (expr_write `Dup` expr_meta) ->
+ testGroup (show expected)
+ [ testCase "text" $ Build.toLazyText (repr_text_write expr_write) @?= text
+ , testCase "meta" $ repr_meta expr_meta >>= (@?= meta)
+ ] in
+ [ testGroup "Dup"
+ [ Dup.e1 ==> ("True & !(True & True)", False)
+ -- , Dup.e2 ==> ("", False)
+ ]
+ ]
+-}
+
--- /dev/null
+module Repr.Tree.Test where
+
+import Test.Tasty
+import qualified Repr.Tree.Read.Test as Read
+
+tests :: TestTree
+tests =
+ testGroup "Tree"
+ [ Read.tests
+ ]
--- /dev/null
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Test where
+
+import Data.Function (($))
+import System.IO (IO)
+import Test.Tasty
+
+import qualified Repr.Test as Repr
+import qualified Trans.Test as Trans
+
+main :: IO ()
+main =
+ defaultMain $
+ testGroup "Hcompta"
+ [ Repr.tests
+ , Trans.tests
+ ]
--- /dev/null
+module Hcompta.Trans.Bool
+ ( module Hcompta.Trans.Bool.Const
+ ) where
+
+import Hcompta.Trans.Bool.Const
--- /dev/null
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Hcompta.Trans.Bool.Const where
+
+import Data.Bool
+import Data.Function (($))
+import Data.Text.Buildable (Buildable(..))
+import Text.Show (Show)
+
+import Hcompta.Expr.Trans
+import Hcompta.Expr.Lit
+import Hcompta.Expr.Bool
+
+-- * Type 'Trans_Bool_Const'
+
+-- * Annotation to propagate constants.
+data Trans_Bool_Const repr h
+ = Trans_Bool_Const_Unk (repr h)
+ | (Buildable h, Show h)
+ => Trans_Bool_Const_Lit h
+
+instance Expr_Lit repr => Trans Trans_Bool_Const repr where
+ trans_lift = Trans_Bool_Const_Unk
+ trans_apply (Trans_Bool_Const_Unk x) = x
+ trans_apply (Trans_Bool_Const_Lit x) = lit x
+
+trans_bool_const
+ :: (Expr_Bool repr, Expr_Lit repr)
+ => Trans_Bool_Const repr h
+ -> repr h
+trans_bool_const = trans_apply
+
+instance Expr_Lit repr => Expr_Lit (Trans_Bool_Const repr) where
+ lit = Trans_Bool_Const_Lit
+instance Expr_Bool repr => Expr_Bool (Trans_Bool_Const repr) where
+ and (Trans_Bool_Const_Lit True) y = y
+ and (Trans_Bool_Const_Lit False) _y = Trans_Bool_Const_Lit False
+ and x (Trans_Bool_Const_Lit True) = x
+ and _x (Trans_Bool_Const_Lit False) = Trans_Bool_Const_Lit False
+ and (Trans_Bool_Const_Unk x)
+ (Trans_Bool_Const_Unk y)
+ = Trans_Bool_Const_Unk $ and x y
+
+ or (Trans_Bool_Const_Lit False) y = y
+ or (Trans_Bool_Const_Lit True) _y = Trans_Bool_Const_Lit True
+ or x (Trans_Bool_Const_Lit False) = x
+ or _x (Trans_Bool_Const_Lit True) = Trans_Bool_Const_Lit True
+ or (Trans_Bool_Const_Unk x)
+ (Trans_Bool_Const_Unk y)
+ = Trans_Bool_Const_Unk $ or x y
+
+ neg (Trans_Bool_Const_Unk e) = Trans_Bool_Const_Unk $ neg e
+ neg (Trans_Bool_Const_Lit x) = Trans_Bool_Const_Lit $ not x
--- /dev/null
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Trans.Bool.Const.Test where
+
+import Data.Function (($))
+import qualified Data.Text.Lazy as Text
+import Data.Text.Lazy.Builder as Build
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import qualified Expr.Bool.Test as Bool
+import qualified Repr.Text.Write.Test ()
+import Hcompta.Repr
+import Hcompta.Trans
+
+tests :: TestTree
+tests = testGroup "Const" $
+ let (==>) expr expected =
+ testCase (Text.unpack expected) $
+ Build.toLazyText (repr_text_write $ trans_bool_const expr) @?=
+ expected
+ in
+ [ Bool.e1 ==> "False"
+ , Bool.e2 ==> "True"
+ , Bool.e3 ==> "True"
+ , Bool.e4 ==> "True"
+ , Bool.e5 ==> "!x"
+ , Bool.e6 ==> "(x | y) & !(x & y)"
+ , Bool.e7 ==> "((x | y) & !(x & y) | z) & !(((x | y) & !(x & y)) & z)"
+ , Bool.e8 ==> "(x | !y) & !(x & !y)"
+ ]
+
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+module Trans.Bool.Test where
+
+import Test.Tasty
+import qualified Trans.Bool.Const.Test as Const
+
+tests :: TestTree
+tests =
+ testGroup "Bool"
+ [ Const.tests
+ ]
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+module Trans.Test where
+
+import Test.Tasty
+import qualified Trans.Bool.Test as Bool
+
+tests :: TestTree
+tests =
+ testGroup "Trans"
+ [ Bool.tests
+ ]
+++ /dev/null
-import Prelude
-import Test.HUnit
-import Test.Framework.Providers.HUnit (hUnitTestToTests)
-import Test.Framework.Runners.Console (defaultMain)
-
-import Hcompta.CLI
-
-main :: IO ()
-main = defaultMain $ hUnitTestToTests test_Hcompta_CLI
-
-test_Hcompta_CLI :: Test
-test_Hcompta_CLI =
- TestList
- [ "dummy test" ~:
- assertBool "" $ True
- ]
+++ /dev/null
-haddock
- html-location: http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html
-AUTHOR: jULIEN mOUTINHO <JULM+HCOMPTA@AUTOGEREE.NET>
-bug-reports: http://doc.autogeree.net/coop/hcompta/bugs
+author: Julien Moutinho <julm+hcompta@autogeree.net>
+-- bug-reports: http://bug.autogeree.net/hcompta
build-type: Simple
cabal-version: >= 1.8
category: Finance
-- data-dir: data
-- data-files:
description: Hcompta command line interface.
-extra-source-files: Test.hs
extra-tmp-files:
extra-source-files:
- -- i18n/en.msg
- -- i18n/fr.msg
-homepage: http://doc.autogeree.net/coop/hcompta
-license: GPL
+-- homepage: http://pad.autogeree.net/hcompta
+license: GPL-3
license-file: COPYING
maintainer: Julien Moutinho <julm+hcompta@autogeree.net>
name: hcompta-cli
stability: experimental
synopsis: hcompta
-tested-with: GHC==7.8.4
-version: 0.0.0
+tested-with: GHC==7.10.3
+version: 1.201608
-source-repository head
- type: git
+Source-Repository head
location: git://git.autogeree.net/hcompta
+ type: git
Flag dev
Description: Turn on development settings.
Default: False
+ Manual: True
Flag dump
Default: False
Flag library-only
Description: Build only library.
Default: False
+ Manual: True
Flag prof
Default: False
Description: Turn on profiling settings.
+ Manual: True
Flag threaded
Default: True
if flag(dev)
cpp-options: -DDEVELOPMENT
ghc-options:
- else
- ghc-options: -O2
if flag(dump)
ghc-options: -ddump-ds -ddump-simpl -ddump-splices -ddump-stg -ddump-to-file
if flag(prof)
exposed-modules:
Hcompta.CLI.Args
Hcompta.CLI.Command
- Hcompta.CLI.Command.Balance
- Hcompta.CLI.Command.GL
- Hcompta.CLI.Command.Journal
+ -- Hcompta.CLI.Command.Balance
+ -- Hcompta.CLI.Command.GL
+ -- Hcompta.CLI.Command.Journal
Hcompta.CLI.Command.Journals
-- Hcompta.CLI.Command.Stats
-- Hcompta.CLI.Command.Tags
Hcompta.CLI.Context
Hcompta.CLI.Env
+ Hcompta.CLI.Convert
Hcompta.CLI.Format
Hcompta.CLI.Format.JCC
Hcompta.CLI.Format.Ledger
Hcompta.CLI.Lang
Hcompta.CLI.Write
+ Hcompta.Expr
+ Hcompta.Expr.Bool
+ Hcompta.Expr.Dup
+ Hcompta.Expr.Eq
+ Hcompta.Expr.Fun
+ Hcompta.Expr.If
+ Hcompta.Expr.Lit
+ Hcompta.Expr.Log
+ Hcompta.Expr.Maybe
+ Hcompta.Expr.Ord
+ Hcompta.Expr.Set
+ Hcompta.Expr.Trans
+ Hcompta.Repr
+ Hcompta.Repr.Meta
+ Hcompta.Repr.Text
+ Hcompta.Repr.Text.Write
+ Hcompta.Repr.Tree
+ Hcompta.Repr.Tree.Read
+ Hcompta.Trans
+ Hcompta.Trans.Bool
+ Hcompta.Trans.Bool.Const
+ Hcompta.Type
build-depends:
base >= 4.6 && < 5
, ansi-terminal >= 0.4 && < 0.7
, Decimal
, deepseq
-- , directory
+ , exceptions
, ghc-prim
, hcompta-jcc
, hcompta-ledger
-- , HUnit
, io-memoize >= 1.1
-- NOTE: needed for System.IO.Memoize.once
+ , monad-classes
, parsec
+ , parsec-error-custom
-- , safe >= 0.2
+ , safe-exceptions
, semigroups
, strict
-- , template-haskell
, text
+ , text-format
, time
, transformers >= 0.4 && < 0.5
-- NOTE: needed for Control.Monad.Trans.Except
+ , treemap
+ , walderleijen-ansi-text
Executable hcompta
extensions: NoImplicitPrelude
if flag(dev)
cpp-options: -DDEVELOPMENT
ghc-options:
- else
- ghc-options: -O2
if flag(prof)
cpp-options: -DPROFILING
ghc-options: -fprof-auto
, io-memoize >= 1.1
-- NOTE: needed for System.IO.Memoize.once
, parsec
+ , parsec-error-custom
-- , safe >= 0.2
, semigroups
, strict
, time
, transformers >= 0.4 && < 0.5
-- NOTE: needed for Control.Monad.Trans.Except
+ , treemap
+ , walderleijen-ansi-text
-test-suite Test
+Test-Suite hcompta-cli-test
type: exitcode-stdio-1.0
- main-is: Main.hs
- hs-source-dirs: Test
- ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures
- ghc-options: -fno-warn-type-defaults -fno-warn-orphans
-- default-language: Haskell2010
+ extensions: NoImplicitPrelude
+ ghc-options: -Wall -fno-warn-tabs
+ -main-is Test
+ hs-source-dirs: Hcompta
+ main-is: Test.hs
+ other-modules:
+ Repr.Test
+ Repr.Text
+ Repr.Text.Write
+ Repr.Text.Write.Test
+ Repr.Tree
+ Repr.Tree.Read
+ Repr.Tree.Read.Test
+ -- Repr.Meta
+ -- Repr.Meta.Test
+ Expr.Bool.Test
+ Expr.Dup.Test
+ Expr.Fun.Test
+ Expr.If.Test
+ Trans.Bool.Const.Test
+ Trans.Bool.Test
+ Trans.Test
+ if flag(threaded)
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ if flag(dev)
+ cpp-options: -DDEVELOPMENT
+ ghc-options:
+ if flag(prof)
+ cpp-options: -DPROFILING
+ ghc-options: -fprof-auto
build-depends:
- hcompta-cli
- , hcompta-jcc
- , hcompta-ledger
- , base >= 4.6 && < 5
+ base >= 4.6 && < 5
+ , containers >= 0.5 && < 0.6
, Decimal
- , HUnit
- -- , safe
- , test-framework
- , test-framework-hunit
+ , ghc-prim
+ , hcompta-lib
+ , hcompta-cli
+ , semigroups
+ , strict
+ , tasty >= 0.11
+ , tasty-hunit
+ , text
+ , text-format
+ , transformers >= 0.4 && < 0.5
+ , treemap
sourcephile / git / comptalang.git / commitdiff