PEMKA

M.hs

{-# OPTIONS_GHC -W #-}
module Format where

import Control.Applicative (Applicative(..), Alternative(..), liftA2)
import Data.Foldable (asum)
import Data.Semigroup

infixr 4 :+:

-- | AST for formats:
--
-- (%one|%aanother%)hi%onemore%
data FormatTree m a =
    Empty
  | Pure a
  | FormatTree m a :+: FormatTree m a
  | Meta (Int -> m a)
  | Alternatives [FormatTree m a]


data Nat = Z | S Nat

-- |
--
-- >>> let table xs n | length xs > n = Just "world" | otherwise = Nothing
--
-- >>> formatString 7 (parse table "")
-- Nothing
--
-- >>> formatString 7 (parse table "hello")
-- Just "hello"
--
-- >>> formatString 7 (parse table "hello(world|!!!)")
-- Just "helloworld"
--
-- >>> formatString 4 (parse table "hello(%foobar%|!!!)")
-- Just "helloworld"
--
-- >>> formatString 7 (parse table "hello(%foobar%|!!!)")
-- Just "hello!!!"
parse :: (String -> Int -> Maybe String) -> String -> FormatTree Maybe String
parse table = go "" where
  go acc ('\\':'(':cs) = go ('(':acc) cs
  go acc ('\\':'%':cs) = go ('%':acc) cs
  go acc ('(':cs) =
    let (as, rest) = alternatives cs
    in accformat acc :+: Alternatives (map (go "") as) :+: go "" rest
  go acc ('%':cs) =
    let (key, rest) = meta cs
    in accformat acc :+: Meta (table key) :+: go "" rest
  go acc (c:cs) = go (c:acc) cs
  go acc [] = accformat acc

  accformat [] = Empty
  accformat xs = Pure (reverse xs)


-- |
-- >>> alternatives ""
-- *** Exception: Woot!
--
-- >>> alternatives "hello|world|!!!)"
-- (["hello","world","!!!"],"")
--
-- >>> alternatives "hello|world|!!!)yay!"
-- (["hello","world","!!!"],"yay!")
--
-- >>> alternatives "(hello|bye)|world|!!!)yay!"
-- (["(hello|bye)","world","!!!"],"yay!")
--
-- >>> alternatives "(hell\\(o|bye)|world|!!!)yay!"
-- (["(hell\\(o|bye)","world","!!!"],"yay!")
--
-- >>> alternatives "(hell\\)o|bye)|world|!!!)yay!"
-- (["(hell\\)o|bye)","world","!!!"],"yay!")
alternatives :: String -> ([String], String)
alternatives = go Z [] "" where
  go n strings acc ('\\':'(':xs) = go n strings ('(':'\\':acc) xs
  go n strings acc ('\\':')':xs) = go n strings (')':'\\':acc) xs
  go n strings acc ('\\':'|':xs) = go n strings ('|':'\\':acc) xs
  go n strings acc ('(':xs) = go (S n) strings ('(':acc) xs
  go Z strings acc (')':xs) = (reverse (reverse acc : strings), xs)
  go (S n) strings acc (')':xs) = go n strings (')':acc) xs
  go Z strings acc ('|':xs) = go Z (reverse acc : strings) [] xs
  go n strings acc (x:xs) = go n strings (x:acc) xs
  go _ _ _ [] = error "Woot!"

-- |
-- >>> meta ""
-- *** Exception: Woot!
--
-- >>> meta "hello%"
-- ("hello","")
--
-- >>> meta "hello%!!!"
-- ("hello","!!!")
--
-- >>> meta "hell\\%o%!!!"
-- ("hell%o","!!!")
meta :: String -> (String, String)
meta = go "" where
  go acc ('\\':'%':xs) = go ('%':acc) xs
  go acc ('%':xs) = (reverse acc, xs)
  go acc (x:xs) = go (x:acc) xs
  go _ [] = error "Woot!"

-- |
--
-- >>> let meta n | n > 4 = Just "world" | otherwise = Nothing
--
-- >>> formatString 7 Empty
-- Nothing
--
-- >>> formatString 7 (Pure "hello")
-- Just "hello"
--
-- >>> formatString 7 (Pure "hello" :+: Pure "world")
-- Just "helloworld"
--
-- >>> formatString 7 (Pure "hello" :+: Empty)
-- Just "hello"
--
-- >>> formatString 7 (Pure "hello" :+: Alternatives [Pure "world", Pure "!!!"])
-- Just "helloworld"
--
-- >>> formatString 7 (Pure "hello" :+: Alternatives [Meta meta, Pure "!!!"])
-- Just "helloworld"
--
-- >>> formatString 4 (Pure "hello" :+: Alternatives [Meta meta, Pure "!!!"])
-- Just "hello!!!"
formatString :: Int -> FormatTree Maybe String -> Maybe String
formatString = format

format :: (Alternative m, Semigroup a) => Int -> FormatTree m a -> m a
format n = go where
  go Empty             = empty
  go (Pure a)          = pure a
  go (x :+: y)         = let x' = go x; y' = go y in liftA2 (<>) x' y' <|> x' <|> y'
  go (Alternatives xs) = asum $ fmap go xs
  go (Meta f)      = f n