module Penny.Copper.Account (
lvl1Account
, lvl1AccountQuoted
, lvl2Account
, render
, lvl1Char
, lvl2FirstChar
, lvl2RemainingChar
) where
import Control.Applicative((<$>), (<*>), (*>))
import qualified Data.Foldable as F
import Data.Text ( snoc, cons, pack, Text )
import qualified Data.Traversable as T
import Text.Parsec (
char, satisfy, many, (<?>),
many1, between, sepBy1, option )
import Text.Parsec.Text ( Parser )
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NE
import qualified Penny.Lincoln.Bits as B
import Penny.Lincoln.TextNonEmpty ( TextNonEmpty ( TextNonEmpty ),
unsafeTextNonEmpty )
import qualified Penny.Lincoln.HasText as HT
import qualified Penny.Copper.Util as U
lvl1Char :: Char -> Bool
lvl1Char c = allowed && notBanned where
allowed = U.rangeLettersToSymbols c || c == ' '
notBanned = not $ c `elem` "}:"
lvl1Sub :: Parser B.SubAccountName
lvl1Sub = f <$> p <?> e where
f = B.SubAccountName . unsafeTextNonEmpty
p = many1 (satisfy lvl1Char)
e = "sub account name"
lvl1Account :: Parser B.Account
lvl1Account = B.Account . NE.fromList <$> p <?> e where
e = "account name"
p = sepBy1 lvl1Sub (char ':')
lvl1AccountQuoted :: Parser B.Account
lvl1AccountQuoted = between (char '{') (char '}') lvl1Account
lvl2FirstChar :: Char -> Bool
lvl2FirstChar = U.rangeLetters
lvl2RemainingChar :: Char -> Bool
lvl2RemainingChar c = allowed && notBanned where
allowed = U.rangeLettersToSymbols c
notBanned = not $ c `elem` "}:"
lvl2SubAccountFirst :: Parser B.SubAccountName
lvl2SubAccountFirst = f <$> c1 <*> cs <?> e where
c1 = satisfy lvl2FirstChar
cs = many (satisfy lvl2RemainingChar)
f l1 lr = B.SubAccountName (TextNonEmpty l1 (pack lr))
e = "sub account name beginning with a letter"
lvl2SubAccountRest :: Parser B.SubAccountName
lvl2SubAccountRest = f <$> cs <?> e where
cs = many1 (satisfy p)
p c = allowed && notBanned where
allowed = U.rangeLettersToSymbols c
notBanned = not $ c `elem` "}:"
f = B.SubAccountName . unsafeTextNonEmpty
e = "sub account name"
lvl2Account :: Parser B.Account
lvl2Account = f <$> p1 <*> p2 <?> e where
f x y = B.Account (x :| y)
p1 = lvl2SubAccountFirst
p2 = option [] $
char ':' *> sepBy1 lvl2SubAccountRest (char ':')
e = "account name"
data Level = L1 | L2
deriving (Eq, Ord, Show)
checkAccount :: B.Account -> Maybe Level
checkAccount (B.Account subs) = let
checkFirst = checkFirstSubAccount (NE.head subs)
checkRest = map checkFirstSubAccount (NE.tail subs)
in F.minimum <$> T.sequenceA (checkFirst : checkRest)
checkFirstSubAccount ::
B.SubAccountName
-> Maybe Level
checkFirstSubAccount s = do
l <- checkOtherSubAccount s
return $ case l of
L1 -> L1
L2 -> let (B.SubAccountName (TextNonEmpty c _)) = s
in if lvl2FirstChar c then L2 else L1
checkOtherSubAccount ::
B.SubAccountName
-> Maybe Level
checkOtherSubAccount = U.checkText ls where
ls = (lvl2RemainingChar, L2) :| [(lvl1Char, L1)]
render :: B.Account -> Maybe Text
render a = do
l <- checkAccount a
let t = HT.text . HT.Delimited (pack ":") . HT.textList $ a
return $ case l of
L1 -> cons '{' t `snoc` '}'
L2 -> t