{-# Language BlockArguments, TemplateHaskell #-}
{-|
Module      : Advent.Format
Description : Input file format quasiquoter
Copyright   : (c) Eric Mertens, 2018-2021
License     : ISC
Maintainer  : emertens@gmail.com

Usage: @[format|<day> <format string>|]@

When day is specified as @0@ the quasiquoter returns a pure
parser function. Otherwise day uses command line arguments
to find the input file and parses it as an IO action.

A format string can optionally be specified across multiple
lines. In this case the day number goes on the first line and
the pattern starts on the second line. All common leading white
space from all the remaining lines is trimmed off and newlines
are discarded (use @%n@ for matching newlines)

The following are identical:

@
example1 = [format|1
    %s%n
    %s%n|]

example2 = [format|1 %s%n%s%n|]
@

Patterns:

    * @%u@ unsigned integer as 'Int'
    * @%d@ signed integer as 'Int'
    * @%lu@ unsigned integer as 'Integer'
    * @%ld@ signed integer as 'Integer'
    * @%s@ non-empty list of non-space characters as 'String'
    * @%c@ single, non-newline character as 'Char'
    * @%a@ single ASCII letter as 'Char'
    * @%n@ single newline character
    * other characters match literally
    * use @%@ to escape literal matches of special characters
    * @\@A@ matches the names of the constructors of type @A@ as an @A@

Structures:

    * @p|q@ combine alternatives @p@ and @q@
    * @(pq)@ group subpattern @pq@
    * @p*@ zero-to-many repititions of @p@ as a '[]'
    * @p+@ one-to-many repititions of @p@ as a '[]'
    * @p&q@ zero-to-many repititions of @p@ separated by @q@ as a '[]'
    * @p!@ returns the characters that matched pattern @p@ as a 'String'

-}
module Advent.Format (format) where

import Advent.Prelude (countBy)
import Advent.Input (getRawInput)
import Advent.Format.Lexer ( alexScanTokens, AlexPosn(..) )
import Advent.Format.Parser (parseFormat, ParseError(..) )
import Advent.Format.Types ( interesting, Format(..), acceptsEmpty, showFormat, showToken )
import Control.Applicative ((<|>), some)
import Control.Monad ( (<=<) )
import Data.Char ( isDigit, isSpace, isUpper )
import Data.Maybe ( listToMaybe )
import Data.Traversable ( for )
import Data.List (stripPrefix)
import Language.Haskell.TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import Text.ParserCombinators.ReadP
import Text.Read (readMaybe)

parse :: String -> Q Format
parse :: String -> Q Format
parse String
txt =
  case [(AlexPosn, Token)] -> Either ParseError Format
parseFormat (String -> [(AlexPosn, Token)]
alexScanTokens String
txt) of
    Right Format
fmt                -> Format -> Q Format
forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
fmt
    Left (Unclosed AlexPosn
p)        -> AlexPosn -> String -> Q Format
forall a. AlexPosn -> String -> Q a
failAt AlexPosn
p String
"Unclosed parenthesis"
    Left (UnexpectedToken AlexPosn
p Token
t) -> AlexPosn -> String -> Q Format
forall a. AlexPosn -> String -> Q a
failAt AlexPosn
p (String
"Unexpected token " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Token -> String
showToken Token
t)
    Left ParseError
UnexpectedEOF       -> String -> Q Format
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Format parse error, unexpected end-of-input"

failAt :: AlexPosn -> String -> Q a
failAt :: forall a. AlexPosn -> String -> Q a
failAt (AlexPn Int
_ Int
line Int
col) String
msg = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Format parse error at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
col String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg)

-- | Constructs an input parser. See "Advent.Format"
format :: QuasiQuoter
format :: QuasiQuoter
format = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp  = (Int -> String -> Q Exp) -> (Int, String) -> Q Exp
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> String -> Q Exp
makeParser ((Int, String) -> Q Exp)
-> (String -> Q (Int, String)) -> String -> Q Exp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q (Int, String)
prepare
  , quotePat :: String -> Q Pat
quotePat  = \String
_ -> String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"format: patterns not supported"
  , quoteType :: String -> Q Type
quoteType = Format -> Q Type
toType (Format -> Q Type) -> (String -> Q Format) -> String -> Q Type
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q Format
parse (String -> Q Format)
-> ((Int, String) -> String) -> (Int, String) -> Q Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, String) -> String
forall a b. (a, b) -> b
snd ((Int, String) -> Q Format)
-> (String -> Q (Int, String)) -> String -> Q Format
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Q (Int, String)
prepare
  , quoteDec :: String -> Q [Dec]
quoteDec  = \String
_ -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"format: declarations not supported"
  }

prepare :: String -> Q (Int,String)
prepare :: String -> Q (Int, String)
prepare String
str =
  case String -> [String]
lines String
str of
    []   -> String -> Q (Int, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty input format"
    [String
x]  -> case ReadS Int
forall a. Read a => ReadS a
reads String
x of
              [(Int
n,String
rest)] -> (Int, String) -> Q (Int, String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n, (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
' 'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
rest)
              [(Int, String)]
_ -> String -> Q (Int, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to parse single-line input pattern"
    String
x:[String]
xs ->
      do Int
n <- case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
x of
                Maybe Int
Nothing -> String -> Q Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to parse format day number"
                Just Int
n  -> Int -> Q Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
         (Int, String) -> Q (Int, String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n, (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
indent) [String]
xs1)
      where
        xs1 :: [String]
xs1    = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char
' ' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=)) [String]
xs
        indent :: Int
indent = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (String -> String) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char
' 'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==)) [String]
xs1)

makeParser :: Int -> String -> ExpQ
makeParser :: Int -> String -> Q Exp
makeParser Int
n String
str =
  do Format
fmt <- String -> Q Format
parse String
str
     let formats :: Q Exp
formats = [| readP_to_S ($(toReadP fmt) <* eof) |]
     let qf :: Q Exp
qf = [| maybe (error "bad input parse") fst . listToMaybe . $formats |]
     if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then
       Q Exp
qf
     else
       [| $qf <$> getRawInput n |]

toReadP :: Format -> ExpQ
toReadP :: Format -> Q Exp
toReadP Format
s =
  case Format
s of
    Literal String
xs -> [| () <$ string xs |]

    Gather Format
p -> [| fst <$> gather $(toReadP p) |]

    Named String
n
      | Char -> Bool
isUpper (String -> Char
forall a. [a] -> a
head String
n) -> String -> Q Exp
enumParser String
n
      | Bool
otherwise -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
n)

    Format
UnsignedInteger -> [| (read :: String -> Integer) <$>                                      munch1 isDigit  |]
    Format
SignedInteger   -> [| (read :: String -> Integer) <$> ((++) <$> option "" (string "-") <*> munch1 isDigit) |]
    Format
UnsignedInt     -> [| (read :: String -> Int    ) <$>                                      munch1 isDigit  |]
    Format
SignedInt       -> [| (read :: String -> Int    ) <$> ((++) <$> option "" (string "-") <*> munch1 isDigit) |]

    Format
Char      -> [| satisfy ('\n' /=) |]
    Format
Letter    -> [| satisfy (\x -> 'a' <= x && x <= 'z' || 'A' <= x && x <= 'Z') |]
    Format
Word      -> [| some (satisfy (not . isSpace)) |]

    Many Format
x
      | Format -> Bool
acceptsEmpty Format
x -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Argument to * accepts ε: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Format -> String -> String
showFormat Int
0 Format
s String
"")
      | Format -> Bool
interesting Format
x -> [|       many $(toReadP x) |]
      | Bool
otherwise     -> [| () <$ many $(toReadP x) |]

    Some Format
x
      | Format -> Bool
acceptsEmpty Format
x -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Argument to + accepts ε: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Format -> String -> String
showFormat Int
0 Format
s String
"")
      | Format -> Bool
interesting Format
x -> [|       some $(toReadP x) |]
      | Bool
otherwise     -> [| () <$ some $(toReadP x) |]

    SepBy Format
x Format
y
      | Format -> Bool
acceptsEmpty Format
x, Format -> Bool
acceptsEmpty Format
y -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Both arguments to & accept ε: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Format -> String -> String
showFormat Int
0 Format
s String
"")
      | Format -> Bool
interesting Format
x -> [|       sepBy $(toReadP x) $(toReadP y) |]
      | Bool
otherwise     -> [| () <$ sepBy $(toReadP x) $(toReadP y) |]

    Alt Format
x Format
y
      | Bool
xi, Bool
yi    -> [| Left    <$> $xp <|> Right   <$> $yp |]
      | Bool
xi        -> [| Just    <$> $xp <|> Nothing <$  $yp |]
      |     Bool
yi    -> [| Nothing <$  $xp <|> Just    <$> $yp |]
      | Bool
otherwise -> [|             $xp <|>             $yp |]
      where
        xi :: Bool
xi = Format -> Bool
interesting Format
x
        yi :: Bool
yi = Format -> Bool
interesting Format
y
        xp :: Q Exp
xp = Format -> Q Exp
toReadP Format
x
        yp :: Q Exp
yp = Format -> Q Exp
toReadP Format
y

    Format
_ ->
      case [(Format -> Bool
interesting Format
x, Format -> Q Exp
toReadP Format
x) | Format
x <- Format -> [Format] -> [Format]
follows Format
s []] of
        [] -> [| pure () |]
        xxs :: [(Bool, Q Exp)]
xxs@((Bool
ix,Q Exp
x):[(Bool, Q Exp)]
xs)
          | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    -> (Q Exp -> (Bool, Q Exp) -> Q Exp)
-> Q Exp -> [(Bool, Q Exp)] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> (Bool, Q Exp) -> Q Exp
forall {m :: * -> *} {a}. Quote m => m Exp -> (a, m Exp) -> m Exp
apply0 Q Exp
x [(Bool, Q Exp)]
xs
          | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1    -> (Q Exp -> (Bool, Q Exp) -> Q Exp)
-> Q Exp -> [(Bool, Q Exp)] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> (Bool, Q Exp) -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> (Bool, m Exp) -> m Exp
apply1 Q Exp
x [(Bool, Q Exp)]
xs
          | Bool
ix        -> (Q Exp -> (Bool, Q Exp) -> Q Exp)
-> Q Exp -> [(Bool, Q Exp)] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> (Bool, Q Exp) -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> (Bool, m Exp) -> m Exp
applyN [| $tup <$> $x |] [(Bool, Q Exp)]
xs
          | Bool
otherwise -> (Q Exp -> (Bool, Q Exp) -> Q Exp)
-> Q Exp -> [(Bool, Q Exp)] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> (Bool, Q Exp) -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> (Bool, m Exp) -> m Exp
applyN [| $tup <$  $x |] [(Bool, Q Exp)]
xs
          where
            tup :: Q Exp
tup            = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Int -> Name
tupleDataName Int
n)
            n :: Int
n              = ((Bool, Q Exp) -> Bool) -> [(Bool, Q Exp)] -> Int
forall (f :: * -> *) a. Foldable f => (a -> Bool) -> f a -> Int
countBy (Bool, Q Exp) -> Bool
forall a b. (a, b) -> a
fst [(Bool, Q Exp)]
xxs
            apply0 :: m Exp -> (a, m Exp) -> m Exp
apply0 m Exp
l (a
_,m Exp
r) = [| $l *> $r |]
            apply1 :: m Exp -> (Bool, m Exp) -> m Exp
apply1 m Exp
l (Bool
i,m Exp
r) = if Bool
i then [| $l  *> $r |] else [| $l <* $r |]
            applyN :: m Exp -> (Bool, m Exp) -> m Exp
applyN m Exp
l (Bool
i,m Exp
r) = if Bool
i then [| $l <*> $r |] else [| $l <* $r |]

toType :: Format -> TypeQ
toType :: Format -> Q Type
toType Format
fmt =
  case Format
fmt of
    Literal String
_ -> [t| () |]

    Gather Format
_ -> [t| String |]

    Named String
n
      | Char -> Bool
isUpper (String -> Char
forall a. [a] -> a
head String
n) -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
n)
      | Bool
otherwise -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"toType: not implemented for variable yet"

    Format
UnsignedInteger -> [t| Integer |]
    Format
SignedInteger   -> [t| Integer |]
    Format
UnsignedInt     -> [t| Int |]
    Format
SignedInt       -> [t| Int |]

    Format
Char      -> [t| Char |]
    Format
Letter    -> [t| Char |]
    Format
Word      -> [t| String |]

    Many Format
x
      | Format -> Bool
acceptsEmpty Format
x -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Argument to * accepts ε: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Format -> String -> String
showFormat Int
0 Format
fmt String
"")
      | Format -> Bool
interesting Format
x -> [t| [$(toType x)] |]
      | Bool
otherwise     -> [t| () |]

    Some Format
x
      | Format -> Bool
acceptsEmpty Format
x -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Argument to + accepts ε: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Format -> String -> String
showFormat Int
0 Format
fmt String
"")
      | Format -> Bool
interesting Format
x -> [t| [$(toType x)] |]
      | Bool
otherwise     -> [t| () |]

    SepBy Format
x Format
y
      | Format -> Bool
acceptsEmpty Format
x, Format -> Bool
acceptsEmpty Format
y -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Both arguments to & accept ε: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Format -> String -> String
showFormat Int
0 Format
fmt String
"")
      | Format -> Bool
interesting Format
x -> [t| [$(toType x)] |]
      | Bool
otherwise     -> [t| () |]

    Alt Format
x Format
y
      | Bool
xi, Bool
yi    -> [t| Either $xt $yt |]
      | Bool
xi        -> [t| Maybe $xt |]
      |     Bool
yi    -> [t| Maybe $yt |]
      | Bool
otherwise -> [t| () |]
      where
        xi :: Bool
xi = Format -> Bool
interesting Format
x
        yi :: Bool
yi = Format -> Bool
interesting Format
y
        xt :: Q Type
xt = Format -> Q Type
toType Format
x
        yt :: Q Type
yt = Format -> Q Type
toType Format
y

    Format
_ ->
      case [Format -> Q Type
toType Format
x | Format
x <- Format -> [Format] -> [Format]
follows Format
fmt [], Format -> Bool
interesting Format
x] of
        [] -> [t| () |]
        [Q Type
t] -> Q Type
t
        [Q Type]
ts -> (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: * -> *). Quote m => Int -> m Type
tupleT ([Q Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
ts)) [Q Type]
ts

-- | Prefix a list of format strings with a format string.
-- If the given list has all the topmost 'Follow' constructors
-- removed, the output list will as well. Any consecutive literals found
-- while flattening will be combined.
follows :: Format -> [Format] -> [Format]
follows :: Format -> [Format] -> [Format]
follows (Follow Format
x Format
y) [Format]
zs               = Format -> [Format] -> [Format]
follows Format
x (Format -> [Format] -> [Format]
follows Format
y [Format]
zs)
follows Format
Empty        [Format]
zs               = [Format]
zs
follows (Literal String
x)  (Literal String
y : [Format]
zs) = Format -> [Format] -> [Format]
follows (String -> Format
Literal (String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y)) [Format]
zs
follows Format
x            [Format]
zs               = Format
x Format -> [Format] -> [Format]
forall a. a -> [a] -> [a]
: [Format]
zs

enumParser :: String -> ExpQ
enumParser :: String -> Q Exp
enumParser 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 (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Failed to find type named " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
nameStr)) Name -> Q Name
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 ()]
_ Maybe Type
_ [Con]
cons [DerivClause]
_) -> [Con] -> Q [Con]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Con]
cons
         Info
_ -> String -> Q [Con]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Failed to find data declaration for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
nameStr)

     [(Name, String)]
entries <-
       [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 (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, String
str)
           Con
_ -> String -> Q (Name, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unsupported constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
con)

     let parsers :: [Q Exp]
parsers = [[| $(conE name) <$ string str |] | (Name
name, String
str) <- [(Name, String)]
entries]

     [| choice $(listE parsers) |]