module Text.Cook (Result (..), Content (..), Category (..), Item (..), Step, Metadata, parseCook) where
import Control.Monad (void, when)
import Data.Void (Void)
import Text.Megaparsec (MonadParsec (try), Parsec, errorBundlePretty, many, noneOf, optional, parse, some, (<|>))
import Text.Megaparsec.Char (char, digitChar, hspace, newline, space, string)
import Text.Printf (printf)
type Parser = Parsec Void String
type Metadata = (String, String)
type Step = [Content]
data Content
=
Text String
|
Ingredient String String String
|
Timer String String String
|
Cookware String String
deriving (Int -> Content -> ShowS
[Content] -> ShowS
Content -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Content] -> ShowS
$cshowList :: [Content] -> ShowS
show :: Content -> String
$cshow :: Content -> String
showsPrec :: Int -> Content -> ShowS
$cshowsPrec :: Int -> Content -> ShowS
Show, Content -> Content -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Content -> Content -> Bool
$c/= :: Content -> Content -> Bool
== :: Content -> Content -> Bool
$c== :: Content -> Content -> Bool
Eq)
data Item = Item String String
deriving (Int -> Item -> ShowS
[Item] -> ShowS
Item -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Item] -> ShowS
$cshowList :: [Item] -> ShowS
show :: Item -> String
$cshow :: Item -> String
showsPrec :: Int -> Item -> ShowS
$cshowsPrec :: Int -> Item -> ShowS
Show, Item -> Item -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Item -> Item -> Bool
$c/= :: Item -> Item -> Bool
== :: Item -> Item -> Bool
$c== :: Item -> Item -> Bool
Eq)
data Category = Category String [Item]
deriving (Int -> Category -> ShowS
[Category] -> ShowS
Category -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Category] -> ShowS
$cshowList :: [Category] -> ShowS
show :: Category -> String
$cshow :: Category -> String
showsPrec :: Int -> Category -> ShowS
$cshowsPrec :: Int -> Category -> ShowS
Show, Category -> Category -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Category -> Category -> Bool
$c/= :: Category -> Category -> Bool
== :: Category -> Category -> Bool
$c== :: Category -> Category -> Bool
Eq)
data Result
=
Recipe [Metadata] [Step]
|
Grouping [Category]
deriving (Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show, Result -> Result -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq)
parseCook :: String -> Either String Result
parseCook :: String -> Either String Result
parseCook String
input = case forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parser Result
cookFile String
"" (ShowS
simplify String
input) of
Left ParseErrorBundle String Void
bundle -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String Void
bundle
Right Result
result -> forall a b. b -> Either a b
Right Result
result
simplify :: String -> String
simplify :: ShowS
simplify = ShowS
inlineComments forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
blockComments
where
inlineComments :: ShowS
inlineComments = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ShowS
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
where
f :: ShowS
f (Char
'-' : Char
'-' : String
_) = String
""
f (Char
x : String
xs) = Char
x forall a. a -> [a] -> [a]
: ShowS
f String
xs
f String
"" = String
""
blockComments :: String -> String
blockComments :: ShowS
blockComments (Char
'[' : Char
'-' : String
xs) = ShowS
blockComments (ShowS
consume String
xs)
where
consume :: ShowS
consume (Char
'-' : Char
']' : String
ys) = String
ys
consume (Char
_ : String
ys) = ShowS
consume String
ys
consume String
"" = String
""
blockComments (Char
x : String
xs) = Char
x forall a. a -> [a] -> [a]
: ShowS
blockComments String
xs
blockComments String
"" = String
""
cookFile :: Parser Result
cookFile :: Parser Result
cookFile = Parser Result
grouping forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Result
recipe
recipe :: Parser Result
recipe :: Parser Result
recipe = do
[Result]
pieces <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Parser Result
metadata forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Result
step forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Result -> Result -> Result
go ([Metadata] -> [[Content]] -> Result
Recipe [] []) [Result]
pieces
where
go :: Result -> Result -> Result
go (Recipe [Metadata]
m [[Content]]
s) (Recipe [Metadata]
m' [[Content]]
s') = [Metadata] -> [[Content]] -> Result
Recipe ([Metadata]
m forall a. [a] -> [a] -> [a]
++ [Metadata]
m') ([[Content]]
s forall a. [a] -> [a] -> [a]
++ [[Content]]
s')
go Result
x Result
y = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Not expecting " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Result
x forall a. [a] -> [a] -> [a]
++ String
" and " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Result
y forall a. [a] -> [a] -> [a]
++ String
" in recipe parser."
grouping :: Parser Result
grouping :: Parser Result
grouping = [Category] -> Result
Grouping forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (ParsecT Void String Identity Category
category forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline)
category :: Parser Category
category :: ParsecT Void String Identity Category
category = do
String
title <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'[' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf String
"]") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
']' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
[Item]
items <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Item
item
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> [Item] -> Category
Category (ShowS
norm String
title) [Item]
items
item :: Parser Item
item :: Parser Item
item = do
String
first <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf String
"\n|")
String
second <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'|') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf String
"\n") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> String -> Item
Item (ShowS
norm String
first) (ShowS
norm String
second)
metadata :: Parser Result
metadata :: Parser Result
metadata = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
">>" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
String
key <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf String
":"
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
[String]
value <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall a b. (a -> b) -> a -> b
$ ParsecT Void String Identity String
word forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Metadata] -> [[Content]] -> Result
Recipe [(ShowS
norm String
key, [String] -> String
unwords [String]
value)] []
step :: Parser Result
step :: Parser Result
step = do
[Content]
content <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall a b. (a -> b) -> a -> b
$ (ParsecT Void String Identity Content
ingredient forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String Identity Content
cookware forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String Identity Content
timer forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String Identity Content
text)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Metadata] -> [[Content]] -> Result
Recipe [] [[Content]
content]
text :: Parser Content
text :: ParsecT Void String Identity Content
text = String -> Content
Text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf String
"@#~\n"))
ingredient :: Parser Content
ingredient :: ParsecT Void String Identity Content
ingredient =
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'@'
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ( forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try
( do
String
content <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf String
"#~@\n{"
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'{'
(String
amount, String
units) <- Parser Metadata
quantity
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'}'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Content
Ingredient (ShowS
norm String
content) (case String
amount of String
"" -> String
"some"; String
x -> String
x) String
units
)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
x -> String -> String -> String -> Content
Ingredient String
x String
"some" String
"") ParsecT Void String Identity String
word
)
cookware :: Parser Content
cookware :: ParsecT Void String Identity Content
cookware =
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'#'
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ( forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try
( do
String
content <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf String
"#~@\n{"
(String
amount, String
_) <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'{' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Metadata
quantity forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'}'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> String -> Content
Cookware (ShowS
norm String
content) (case String
amount of String
"" -> String
"1"; String
x -> String
x)
)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
x -> String -> String -> Content
Cookware String
x String
"1") ParsecT Void String Identity String
word
)
timer :: Parser Content
timer :: ParsecT Void String Identity Content
timer =
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'~'
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ( forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try
( do
String
timerLabel <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf String
"#~@\n{"
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'{'
(String
amount, String
units) <- Parser Metadata
quantity
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'}'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Content
Timer (ShowS
norm String
timerLabel) String
amount String
units
)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
x -> String -> String -> String -> Content
Timer String
x String
"" String
"") ParsecT Void String Identity String
word
)
quantity :: Parser (String, String)
quantity :: Parser Metadata
quantity = do
String
amount <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void String Identity String
fraction forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf String
"\n%}")
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'%') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
String
units <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf String
"\n}"
forall (m :: * -> *) a. Monad m => a -> m a
return (ShowS
norm String
amount, ShowS
norm String
units)
fraction :: Parser String
fraction :: ParsecT Void String Identity String
fraction = do
String
n1 <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'/' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace
String
n2 <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== Char
'0') String
n2 Bool -> Bool -> Bool
|| forall a. [a] -> a
head String
n1 forall a. Eq a => a -> a -> Bool
== Char
'0') (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not a vaild fraction")
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
let x :: String
x = forall r. PrintfType r => String -> r
printf String
"%.2f" ((forall a. Read a => String -> a
read String
n1 forall a. Fractional a => a -> a -> a
/ forall a. Read a => String -> a
read String
n2) :: Double)
in if forall a. [a] -> a
last String
x forall a. Eq a => a -> a -> Bool
== Char
'0' then forall a. [a] -> [a]
init String
x else String
x
word :: Parser String
word :: ParsecT Void String Identity String
word = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf String
" \t\n"
norm :: String -> String
norm :: ShowS
norm = [String] -> String
unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words