{-|
Module      : Advent.Format.Utils
Description : Queries and transforms for the format AST
Copyright   : (c) Eric Mertens, 2018-2021
License     : ISC
Maintainer  : emertens@gmail.com

-}
module Advent.Format.Utils where

import Advent.Format.Enum (enumCases)
import Advent.Format.Types (Format(..))
import Control.Monad (when)
import Data.Char (isUpper)
import Language.Haskell.TH (Q)

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]
xs           -> (Format -> Bool) -> [Format] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Format -> Bool
interesting [Format]
xs
    Format
UnsignedInteger     -> Bool
True
    Format
SignedInteger       -> Bool
True
    Format
HexInteger          -> Bool
True
    Format
UnsignedInt         -> Bool
True
    Format
SignedInt           -> Bool
True
    Format
HexInt              -> 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             -> (Format -> Q Bool) -> [Format] -> Q Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM Format -> Q Bool
acceptsEmpty [Format
x, Format
y]
    Follow [Format]
xs           -> (Format -> Q Bool) -> [Format] -> Q Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM Format -> Q Bool
acceptsEmpty [Format]
xs
    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
HexInteger          -> 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
HexInt              -> 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 cases <- String -> Q [(Name, String)]
enumCases String
name
            pure (any (null . snd) cases)
      | Bool
otherwise -> Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM a -> m Bool
_ [] = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
anyM a -> m Bool
f (a
x : [a]
xs) = a -> m Bool
f a
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 (a -> m Bool) -> [a] -> m Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM a -> m Bool
f [a]
xs

allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
_ [] = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
allM a -> m Bool
f (a
x : [a]
xs) = a -> m Bool
f a
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 (a -> m Bool) -> [a] -> m Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
f [a]
xs else Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

simplify :: Format -> Format
simplify :: Format -> Format
simplify (Follow [Format]
xs) = [Format] -> Format
Follow ((Format -> [Format] -> [Format])
-> [Format] -> [Format] -> [Format]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Format -> [Format] -> [Format]
simplifyFollow [] [Format]
xs)
simplify (Alt Format
x Format
y)   = Format -> Format -> Format
Alt (Format -> Format
simplify Format
x) (Format -> Format
simplify Format
y)
simplify (Group Format
x)   = Format -> Format
Group (Format -> Format
simplify Format
x)
simplify (SepBy Format
x Format
y) = Format -> Format -> Format
SepBy (Format -> Format
simplify Format
x) (Format -> Format
simplify Format
y)
simplify (Gather Format
x)  = Format -> Format
Gather (Format -> Format
simplify Format
x)
simplify (Many Format
x)    = Format -> Format
Many (Format -> Format
simplify Format
x)
simplify (Some Format
x)    = Format -> Format
Some (Format -> Format
simplify Format
x)
simplify Format
x           = Format
x

simplifyFollow :: Format -> [Format] -> [Format]
simplifyFollow :: Format -> [Format] -> [Format]
simplifyFollow (Follow [Format]
xs) [Format]
z = (Format -> [Format] -> [Format])
-> [Format] -> [Format] -> [Format]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Format -> [Format] -> [Format]
simplifyFollow [Format]
z [Format]
xs
simplifyFollow (Literal String
a) (Literal String
b : [Format]
c) = String -> Format
Literal (String
aString -> String -> String
forall a. [a] -> [a] -> [a]
++String
b) Format -> [Format] -> [Format]
forall a. a -> [a] -> [a]
: [Format]
c
simplifyFollow Format
x [Format]
z = Format -> Format
simplify Format
x Format -> [Format] -> [Format]
forall a. a -> [a] -> [a]
: [Format]
z