{-# Language BlockArguments #-}
module Advent.Format.Types where

import Language.Haskell.TH
import Data.Traversable (for)
import Data.List (stripPrefix)
import Control.Monad (when)
import Data.Char (isUpper)

data Token
  = TOpenGroup
  | TCloseGroup
  | TAnyChar
  | TAnyLetter
  | TAnyWord
  | TUnsignedInteger
  | TSignedInteger
  | TUnsignedInt
  | TSignedInt
  | TMany
  | TSome
  | TSepBy
  | TAlt
  | TAt String
  | TBang
  | TLiteral Char
  deriving (Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq, Eq Token
Eq Token =>
(Token -> Token -> Ordering)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Token)
-> (Token -> Token -> Token)
-> Ord Token
Token -> Token -> Bool
Token -> Token -> Ordering
Token -> Token -> Token
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Token -> Token -> Ordering
compare :: Token -> Token -> Ordering
$c< :: Token -> Token -> Bool
< :: Token -> Token -> Bool
$c<= :: Token -> Token -> Bool
<= :: Token -> Token -> Bool
$c> :: Token -> Token -> Bool
> :: Token -> Token -> Bool
$c>= :: Token -> Token -> Bool
>= :: Token -> Token -> Bool
$cmax :: Token -> Token -> Token
max :: Token -> Token -> Token
$cmin :: Token -> Token -> Token
min :: Token -> Token -> Token
Ord, Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> String
show :: Token -> String
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show, ReadPrec [Token]
ReadPrec Token
Int -> ReadS Token
ReadS [Token]
(Int -> ReadS Token)
-> ReadS [Token]
-> ReadPrec Token
-> ReadPrec [Token]
-> Read Token
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Token
readsPrec :: Int -> ReadS Token
$creadList :: ReadS [Token]
readList :: ReadS [Token]
$creadPrec :: ReadPrec Token
readPrec :: ReadPrec Token
$creadListPrec :: ReadPrec [Token]
readListPrec :: ReadPrec [Token]
Read)

data Format
  -- repetitions
  = Many  Format
  | Some  Format
  | SepBy Format Format
  -- combinations
  | Alt Format Format
  | Follow Format Format
  | Empty
  -- return matched string
  | Gather Format
  | Named String
  -- explicit grouping to allow subtuples
  | Group Format
  -- primitives
  | Literal String
  | UnsignedInteger
  | SignedInteger
  | UnsignedInt
  | SignedInt
  | Word
  | Char
  | Letter
  deriving Int -> Format -> ShowS
[Format] -> ShowS
Format -> String
(Int -> Format -> ShowS)
-> (Format -> String) -> ([Format] -> ShowS) -> Show Format
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Format -> ShowS
showsPrec :: Int -> Format -> ShowS
$cshow :: Format -> String
show :: Format -> String
$cshowList :: [Format] -> ShowS
showList :: [Format] -> ShowS
Show

interesting :: Format -> Bool
interesting :: Format -> Bool
interesting Format
s =
  case Format
s of
    Many Format
x              -> Format -> Bool
interesting Format
x
    Some Format
x              -> Format -> Bool
interesting Format
x
    SepBy Format
x Format
_           -> Format -> Bool
interesting Format
x
    Group Format
x             -> Format -> Bool
interesting Format
x
    Alt Format
x Format
y             -> Format -> Bool
interesting Format
x Bool -> Bool -> Bool
|| Format -> Bool
interesting Format
y
    Follow Format
x Format
y          -> Format -> Bool
interesting Format
x Bool -> Bool -> Bool
|| Format -> Bool
interesting Format
y
    Format
Empty               -> Bool
False
    Format
UnsignedInteger     -> Bool
True
    Format
SignedInteger       -> Bool
True
    Format
UnsignedInt         -> Bool
True
    Format
SignedInt           -> Bool
True
    Format
Word                -> Bool
True
    Format
Char                -> Bool
True
    Format
Letter              -> Bool
True
    Gather{}            -> Bool
True
    Named{}             -> Bool
True
    Literal{}           -> Bool
False

acceptsEmpty :: Format -> Q Bool
acceptsEmpty :: Format -> Q Bool
acceptsEmpty Format
fmt =
  case Format
fmt of
    Many Format
_              -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Some Format
x              -> Format -> Q Bool
acceptsEmpty Format
x
    SepBy Format
_ Format
_           -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Alt Format
x Format
y             -> Q Bool -> Q Bool -> Q Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
orM  (Format -> Q Bool
acceptsEmpty Format
x) (Format -> Q Bool
acceptsEmpty Format
y)
    Follow Format
x Format
y          -> Q Bool -> Q Bool -> Q Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
andM (Format -> Q Bool
acceptsEmpty Format
x) (Format -> Q Bool
acceptsEmpty Format
y)
    Format
Empty               -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Format
UnsignedInteger     -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Format
SignedInteger       -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Format
UnsignedInt         -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Format
SignedInt           -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Format
Word                -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Format
Char                -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Format
Letter              -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Gather Format
x            -> Format -> Q Bool
acceptsEmpty Format
x
    Group Format
x             -> Format -> Q Bool
acceptsEmpty Format
x
    Literal String
x           -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x)
    Named String
name
      | Char -> Bool
isUpper (String -> Char
forall a. HasCallStack => [a] -> a
head String
name) ->
         do [(Name, String)]
cases <- String -> Q [(Name, String)]
enumCases String
name
            Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Name, String) -> Bool) -> [(Name, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool)
-> ((Name, String) -> String) -> (Name, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, String) -> String
forall a b. (a, b) -> b
snd) [(Name, String)]
cases)
      | Bool
otherwise -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False


whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
pm m ()
m = m Bool
pm m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
p -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
p m ()
m

andM :: Monad m => m Bool -> m Bool -> m Bool
andM :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
andM m Bool
x m Bool
y = m Bool
x m Bool -> (Bool -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then m Bool
y else Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

orM :: Monad m => m Bool -> m Bool -> m Bool
orM :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
orM  m Bool
x m Bool
y = m Bool
x m Bool -> (Bool -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True else m Bool
y

-- | Render a parsed format string back to the input syntax.
showFormat :: Int {- ^ surrounding precedence -} -> Format -> ShowS
showFormat :: Int -> Format -> ShowS
showFormat Int
p Format
fmt =
  case Format
fmt of
    Many Format
x              -> Int -> Format -> ShowS
showFormat Int
3 Format
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'*'
    Some Format
x              -> Int -> Format -> ShowS
showFormat Int
3 Format
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'+'
    Gather Format
x            -> Int -> Format -> ShowS
showFormat Int
3 Format
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'!'
    SepBy Format
x Format
y           -> Int -> Format -> ShowS
showFormat Int
3 Format
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'&' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Format -> ShowS
showFormat Int
3 Format
y
    Alt Format
x Format
y             -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Format -> ShowS
showFormat Int
1 Format
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'|' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Format -> ShowS
showFormat Int
2 Format
y
    Follow Format
x Format
y          -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Format -> ShowS
showFormat Int
2 Format
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Format -> ShowS
showFormat Int
3 Format
y
    Format
Empty               -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2) ShowS
forall a. a -> a
id
    Group Format
x             -> Int -> Format -> ShowS
showFormat Int
3 Format
x
    Format
UnsignedInteger     -> String -> ShowS
showString String
"%lu"
    Format
SignedInteger       -> String -> ShowS
showString String
"%ld"
    Format
UnsignedInt         -> String -> ShowS
showString String
"%u"
    Format
SignedInt           -> String -> ShowS
showString String
"%d"
    Format
Word                -> String -> ShowS
showString String
"%s"
    Format
Char                -> String -> ShowS
showString String
"%c"
    Format
Letter              -> String -> ShowS
showString String
"%a"
    Named String
n             -> Char -> ShowS
showChar Char
'@' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
n
    Literal String
x           -> (String -> ShowS) -> String -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Char -> ShowS) -> String -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS
showLiteral) String
x

-- | Render a literal character match back to input syntax.
showLiteral :: Char -> ShowS
showLiteral :: Char -> ShowS
showLiteral Char
x
  | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = String -> ShowS
showString String
"%n"
  | Char
x Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"()&!*+%@" = Char -> ShowS
showChar Char
'%' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
x
  | Bool
otherwise = Char -> ShowS
showChar Char
x

showToken :: Token -> String
showToken :: Token -> String
showToken Token
t =
  case Token
t of
    Token
TOpenGroup        -> String
"("
    Token
TCloseGroup       -> String
")"
    Token
TAnyChar          -> String
"%c"
    Token
TAnyLetter        -> String
"%a"
    Token
TAnyWord          -> String
"%s"
    Token
TUnsignedInteger  -> String
"%lu"
    Token
TSignedInteger    -> String
"%ld"
    Token
TUnsignedInt      -> String
"%u"
    Token
TSignedInt        -> String
"%d"
    Token
TMany             -> String
"*"
    Token
TSome             -> String
"+"
    Token
TSepBy            -> String
"&"
    Token
TAlt              -> String
"|"
    TAt String
x             -> String
"@" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x
    Token
TBang             -> String
"!"
    TLiteral Char
c        -> Char -> ShowS
showLiteral Char
c String
""

follow :: Format -> Format -> Format
follow :: Format -> Format -> Format
follow Format
Empty Format
x = Format
x
follow Format
x Format
Empty = Format
x
follow Format
x Format
y = Format -> Format -> Format
Follow Format
x Format
y

enumCases :: String -> Q [(Name,String)]
enumCases :: String -> Q [(Name, String)]
enumCases String
nameStr =
 do Name
tyName <- Q Name -> (Name -> Q Name) -> Maybe Name -> Q Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q Name
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Failed to find type named " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
nameStr)) Name -> Q Name
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
           (Maybe Name -> Q Name) -> Q (Maybe Name) -> Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q (Maybe Name)
lookupTypeName String
nameStr

    Info
info <- Name -> Q Info
reify Name
tyName
    [Con]
cons <-
      case Info
info of
        TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ [Con]
cons [DerivClause]
_) -> [Con] -> Q [Con]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Con]
cons
        Info
_ -> String -> Q [Con]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Failed to find data declaration for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
nameStr)

    [Con] -> (Con -> Q (Name, String)) -> Q [(Name, String)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cons \Con
con ->
      case Con
con of
        NormalC Name
name []
          | Just String
str <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
nameStr (Name -> String
nameBase Name
name) ->
            (Name, String) -> Q (Name, String)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, String
str)
        Con
_ -> String -> Q (Name, String)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unsupported constructor: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
con)