{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
module Tax.FDF where
import Data.Char (isDigit)
import Data.CAProvinceCodes qualified as Province
import Data.Fixed (Centi)
import Data.Foldable (find)
import Data.Functor.Const (Const (Const, getConst))
import Data.Map.Lazy (Map)
import Data.Map.Lazy qualified as Map
import Data.Semigroup.Cancellative (stripSuffix)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Time (Day, defaultTimeLocale, formatTime, parseTimeM)
import Rank2 qualified
import Text.FDF (FDF, foldMapWithKey, mapWithKey, parse, serialize)
import Text.Read (readEither)
data FieldConst a = Field {path :: [Text], entry :: Entry a}
data Entry a where
Count :: Entry Word
Date :: Entry Day
Province :: Entry Province.Code
Textual :: Entry Text
Amount :: Entry Centi
Percent :: Entry Rational
Checkbox :: Entry Bool
RadioButton :: (Bounded a, Enum a, Eq a, Show a) => [a] -> Entry a
RadioButtons :: (Bounded a, Enum a, Eq a, Show a) => Text -> [a] -> Entry a
Switch :: Text -> Text -> Text -> Entry Bool
Switch' :: Text -> Entry Bool
deriving instance Show a => Show (Entry a)
within :: Text -> FieldConst x -> FieldConst x
within root field@Field{path} = field{path = root:path}
load :: (Rank2.Apply form, Rank2.Traversable form) => form FieldConst -> FDF -> Either String (form Maybe)
load fields = fromFieldMap fields . foldMapWithKey Map.singleton
update :: (Rank2.Apply form, Rank2.Foldable form) => form FieldConst -> form Maybe -> FDF -> FDF
update fields = mapWithKey . updateKey . Rank2.foldMap (uncurry Map.singleton . getConst) . Rank2.liftA2 pairKey fields
where pairKey :: FieldConst a -> Maybe a -> Const ([Text], Text) a
pairKey Field {path, entry} v = Const ((<> "[0]") <$> path, foldMap (fromEntry entry) v)
updateKey :: Map [Text] Text -> [Text] -> Text -> Text
updateKey m k v = Map.findWithDefault v k m
fromEntry :: Entry a -> a -> Text
fromEntry Textual v = v
fromEntry Date v = Text.pack $ formatTime defaultTimeLocale "%Y%m%d" v
fromEntry Checkbox True = "Yes"
fromEntry Checkbox False = "No"
fromEntry (RadioButton values) v = Text.pack $ show $ fromEnum v + 1
fromEntry Amount v = Text.pack (show v)
fromEntry Percent v = Text.pack (show (fromRational $ v * 100 :: Centi)) <> "%"
fromEntry Count v = Text.pack (show v)
fromEntry Province v = Text.pack (show v)
fromFieldMap :: Rank2.Traversable form => form FieldConst -> Map [Text] Text -> Either String (form Maybe)
fromFieldMap fields fieldValues = Rank2.traverse fill fields
where fill :: FieldConst a -> Either String (Maybe a)
fill Field {path, entry}
| Just v <- Map.lookup path fieldValues = toEntry entry (Text.unpack v)
| Just v <- Map.lookup ((<> "[0]") <$> path) fieldValues = toEntry entry (Text.unpack v)
| RadioButtons leaf values <- entry,
Just (n, v) <- find (\(i, _)-> any (`notElem` ["", "Off"]) $
Map.lookup (((<> "[0]") <$> path) <> [leaf <> "[" <> Text.pack (show i) <> "]"]) fieldValues)
(zip [0 ..] values)
= Right $ Just v
| Switch yes no leaf <- entry,
Just yesValue <- Map.lookup ((<> "[0]") <$> (path <> [yes, leaf])) fieldValues,
Just noValue <- Map.lookup ((<> "[0]") <$> (path <> [no, leaf])) fieldValues
= if yesValue `elem` ["", "Off"] && noValue `elem` ["", "Off"] then Right Nothing
else if yesValue == "1" && noValue `elem` ["", "Off"] then Right (Just True)
else if yesValue `elem` ["", "Off"] && noValue `elem` ["1", "2"] then Right (Just False)
else error ("Can't figure out the checkbox at " <> show (path, entry, yesValue, noValue))
| Switch' leaf <- entry,
Just yesValue <- Map.lookup (map (<> "[0]") path <> [leaf <> "[0]"]) fieldValues,
Just noValue <- Map.lookup (map (<> "[0]") path <> [leaf <> "[1]"]) fieldValues
= if yesValue `elem` ["", "Off"] && noValue `elem` ["", "Off"] then Right Nothing
else if yesValue == "1" && noValue `elem` ["", "Off"] then Right (Just True)
else if yesValue `elem` ["", "Off"] && noValue `elem` ["1", "2"] then Right (Just False)
else error ("Can't figure out the checkbox at " <> show (path, entry, yesValue, noValue))
| otherwise = error ("Unknown field path " ++ show path ++ " between "
++ show (Map.lookupLT ((<> "[0]") <$> path) fieldValues,
Map.lookupGT ((<> "[0]") <$> path) fieldValues))
toEntry :: Entry a -> String -> Either String (Maybe a)
toEntry _ "" = Right Nothing
toEntry Count v = Just <$> readEither v
toEntry Date v = Just <$> parseTimeM False defaultTimeLocale "%Y%m%d" v
toEntry Province v = Just <$> readEither v
toEntry Textual v = Right $ Just $ Text.pack v
toEntry Amount v = Just <$> readEither (dropCommas v)
toEntry Percent v
| Just v' <- stripSuffix "%" v,
(wholePart, pointyPart) <- span (/= '.') v',
Right whole <- fromInteger <$> readEither wholePart,
Right decimal <- case pointyPart
of '.' : decimals -> (/ 10 ^ length decimals) . fromInteger <$> readEither decimals
"" -> Right 0
_ -> Left "bad decimals"
= Right $ Just ((whole + decimal) / 100)
| otherwise = Left ("Bad percentage value: " <> show v)
toEntry Checkbox "Yes" = Right $ Just True
toEntry Checkbox "No" = Right $ Just False
toEntry Checkbox "Off" = Right $ Just False
toEntry Checkbox "1" = Right $ Just True
toEntry Checkbox v = Left ("Bad checkbox value: " <> show v)
toEntry e@(RadioButton values) v
| Right n <- readEither v, n > 0, x:_ <- drop (n - 1) values = Right $ Just x
| otherwise = Left ("Bad radio button value: " <> show (e, v))
toEntry e@RadioButtons{} v = error (show (e, v))
toEntry e@(Switch a b leaf) v = error (show (e, v))
toEntry e@(Switch' leaf) v = error (show (e, v))
dropCommas num
| (wholePart, pointyPart@('.' : decimals)) <- span (/= '.') num,
length decimals == 2,
all isDigit decimals
= filter (/= ',') wholePart <> pointyPart
| otherwise = num
instance MonadFail (Either String) where
fail = Left