{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
-- FromJSON WExp
{-# OPTIONS_GHC -Wno-orphans #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Parser for the Swarm world description DSL.
module Swarm.Game.World.Parse where

import Control.Monad (void)
import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
import Control.Monad.Combinators.NonEmpty qualified as CNE (sepBy1)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Void (Void)
import Data.Yaml (FromJSON (parseJSON), withText)
import Swarm.Game.World.Syntax
import Swarm.Util (failT, showT, squote)
import Swarm.Util.Parse (fully)
import Text.Megaparsec hiding (runParser)
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L
import Witch (into)

type Parser = Parsec Void Text
type ParserError = ParseErrorBundle Text Void

------------------------------------------------------------
-- Lexing

reservedWords :: [Text]
reservedWords :: [Text]
reservedWords =
  [ Text
"not"
  , Text
"true"
  , Text
"false"
  , Text
"seed"
  , Text
"x"
  , Text
"y"
  , Text
"hash"
  , Text
"let"
  , Text
"in"
  , Text
"overlay"
  , Text
"hcat"
  , Text
"vcat"
  , Text
"if"
  , Text
"then"
  , Text
"else"
  , Text
"perlin"
  , Text
"mask"
  , Text
"empty"
  , Text
"abs"
  ]

-- | Skip spaces and comments.
sc :: Parser ()
sc :: Parser ()
sc =
  forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
    forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1
    (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
"//")
    (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment Tokens Text
"/*" Tokens Text
"*/")

-- | In general, we follow the convention that every token parser
--   assumes no leading whitespace and consumes all trailing
--   whitespace.  Concretely, we achieve this by wrapping every token
--   parser using 'lexeme'.
lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
sc

-- | A lexeme consisting of a literal string.
symbol :: Text -> Parser Text
symbol :: Text -> Parser Text
symbol = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
sc

operatorChar :: Parser Char
operatorChar :: Parser Char
operatorChar = forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf ([Char]
"!@#$%^&*=+-/<>" :: String)

operator :: Text -> Parser Text
operator :: Text -> Parser Text
operator Text
op = (forall a. Parser a -> Parser a
lexeme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
op forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy Parser Char
operatorChar

-- | A positive integer literal token.
integerOrFloat :: Parser (Either Integer Double)
integerOrFloat :: Parser (Either Integer Double)
integerOrFloat =
  forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"numeric literal" forall a b. (a -> b) -> a -> b
$
    forall a. Parser a -> Parser a
lexeme (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, RealFloat a) =>
m a
L.float forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal)

-- | Parse a case-insensitive reserved word, making sure it is not a
--   prefix of a longer variable name, and allowing the parser to
--   backtrack if it fails.
reserved :: Text -> Parser ()
reserved :: Text -> Parser ()
reserved Text
w = (forall a. Parser a -> Parser a
lexeme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' Text
w forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'_')

-- | Parse an identifier, i.e. any non-reserved string containing
--   alphanumeric characters and underscores and not starting with a
--   number.
identifier :: Parser Var
identifier :: Parser Text
identifier = (forall a. Parser a -> Parser a
lexeme forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) (ParsecT Void Text Identity [Token Text]
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {source} {m :: * -> *}.
(From source Text, MonadFail m) =>
source -> m Text
check) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"variable name"
 where
  p :: ParsecT Void Text Identity [Token Text]
p = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar forall (f :: * -> *) a. Alternative f => f a -> f a -> 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 -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'_' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\'')
  check :: source -> m Text
check (forall target source. From source target => source -> target
into @Text -> Text
t)
    | Text -> Text
T.toLower Text
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
reservedWords =
        forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT [Text
"reserved word", Text -> Text
squote Text
t, Text
"cannot be used as variable name"]
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Text
t

brackets :: Parser a -> Parser a
brackets :: forall a. Parser a -> Parser a
brackets = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol Text
"[") (Text -> Parser Text
symbol Text
"]")

parens :: Parser a -> Parser a
parens :: forall a. Parser a -> Parser a
parens = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol Text
"(") (Text -> Parser Text
symbol Text
")")

braces :: Parser a -> Parser a
braces :: forall a. Parser a -> Parser a
braces = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol Text
"{") (Text -> Parser Text
symbol Text
"}")

comma :: Parser ()
comma :: Parser ()
comma = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
","

------------------------------------------------------------
-- Parser

----------------------------------------------------------------------
-- NOTE: when updating the parser, be sure to update the BNF in
-- data/worlds/README.md to match!
----------------------------------------------------------------------

parseWExpAtom :: Parser WExp
parseWExpAtom :: Parser WExp
parseWExpAtom =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Integer -> WExp
WInt Double -> WExp
WFloat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Either Integer Double)
integerOrFloat
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> WExp
WBool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"true" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"false")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser WExp
parseCell
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> WExp
WVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
identifier
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> WExp
WSeed forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"seed"
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Axis -> WExp
WCoord forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Axis
X forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"x" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Axis
Y forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"y")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> WExp
WHash forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"hash"
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser WExp
parseIf
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser WExp
parsePerlin
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser WExp
parseAbs
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser WExp
parseLet
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser WExp
parseOverlay
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser WExp
parseMask
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser WExp
parseImport
    -- <|> parseCat
    -- <|> parseStruct
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Parser a -> Parser a
parens Parser WExp
parseWExp

parseWExp :: Parser WExp
parseWExp :: Parser WExp
parseWExp =
  forall (m :: * -> *) a.
MonadPlus m =>
m a -> [[Operator m a]] -> m a
makeExprParser
    Parser WExp
parseWExpAtom
    [
      [ forall (m :: * -> *) a. m (a -> a) -> Operator m a
Prefix (Op -> WExp -> WExp
unary Op
Not forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser ()
reserved Text
"not")
      , forall (m :: * -> *) a. m (a -> a) -> Operator m a
Prefix (Op -> WExp -> WExp
unary Op
Neg forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"-")
      ]
    ,
      [ forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixL (Op -> WExp -> WExp -> WExp
binary Op
Mul forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"*")
      , forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixL (Op -> WExp -> WExp -> WExp
binary Op
Div forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"/")
      , forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixL (Op -> WExp -> WExp -> WExp
binary Op
Mod forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"%")
      ]
    ,
      [ forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixL (Op -> WExp -> WExp -> WExp
binary Op
Add forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"+")
      , forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixL (Op -> WExp -> WExp -> WExp
binary Op
Sub forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"-")
      , forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixR (Op -> WExp -> WExp -> WExp
binary Op
Overlay forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"<>")
      ]
    ,
      [ forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixN (Op -> WExp -> WExp -> WExp
binary Op
Eq forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"==")
      , forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixN (Op -> WExp -> WExp -> WExp
binary Op
Neq forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"/=")
      , forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixN (Op -> WExp -> WExp -> WExp
binary Op
Lt forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"<")
      , forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixN (Op -> WExp -> WExp -> WExp
binary Op
Leq forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"<=")
      , forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixN (Op -> WExp -> WExp -> WExp
binary Op
Gt forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
">")
      , forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixN (Op -> WExp -> WExp -> WExp
binary Op
Geq forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
">=")
      ]
    , [forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixR (Op -> WExp -> WExp -> WExp
binary Op
And forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"&&")]
    , [forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixR (Op -> WExp -> WExp -> WExp
binary Op
Or forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
operator Text
"||")]
    ]
 where
  unary :: Op -> WExp -> WExp
unary Op
op WExp
x = Op -> [WExp] -> WExp
WOp Op
op [WExp
x]
  binary :: Op -> WExp -> WExp -> WExp
binary Op
op WExp
x1 WExp
x2 = Op -> [WExp] -> WExp
WOp Op
op [WExp
x1, WExp
x2]

parseCell :: Parser WExp
parseCell :: Parser WExp
parseCell =
  forall a. Parser a -> Parser a
braces forall a b. (a -> b) -> a -> b
$ RawCellVal -> WExp
WCell forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe CellTag, Text)
parseCellItem forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` Parser ()
comma

parseCellItem :: Parser (Maybe CellTag, Text)
parseCellItem :: Parser (Maybe CellTag, Text)
parseCellItem =
  (,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity CellTag
parseCellTag forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
symbol Text
":"))
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
parseName

parseCellTag :: Parser CellTag
parseCellTag :: ParsecT Void Text Identity CellTag
parseCellTag = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice (forall a b. (a -> b) -> [a] -> [b]
map forall {s} {f :: * -> *} {e} {a}.
(Tokens s ~ Text, MonadParsec e s f, FoldCase (Tokens s),
 Show a) =>
a -> f a
mkCellTagParser [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound :: CellTag])
 where
  mkCellTagParser :: a -> f a
mkCellTagParser a
ct = a
ct forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' (Int -> Text -> Text
T.drop Int
4 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
showT a
ct)

parseName :: Parser Text
parseName :: Parser Text
parseName =
  forall target source. From source target => source -> target
into @Text
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (\Token Text
c -> Token Text
c forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Token Text
c forall a. Eq a => a -> a -> Bool
== Char
'}' Bool -> Bool -> Bool
|| Token Text
c forall a. Eq a => a -> a -> Bool
== Char
']')))

parseIf :: Parser WExp
parseIf :: Parser WExp
parseIf =
  (\WExp
i WExp
t WExp
e -> Op -> [WExp] -> WExp
WOp Op
If [WExp
i, WExp
t, WExp
e])
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
reserved Text
"if" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser WExp
parseWExp)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser ()
reserved Text
"then" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser WExp
parseWExp)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser ()
reserved Text
"else" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser WExp
parseWExp)

parsePerlin :: Parser WExp
parsePerlin :: Parser WExp
parsePerlin =
  (\WExp
s WExp
o WExp
k WExp
p -> Op -> [WExp] -> WExp
WOp Op
Perlin [WExp
s, WExp
o, WExp
k, WExp
p])
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
reserved Text
"perlin" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser WExp
parseWExpAtom)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser WExp
parseWExpAtom
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser WExp
parseWExpAtom
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser WExp
parseWExpAtom

parseAbs :: Parser WExp
parseAbs :: Parser WExp
parseAbs =
  Op -> [WExp] -> WExp
WOp Op
Abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser ()
reserved Text
"abs" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser WExp
parseWExpAtom)

parseLet :: Parser WExp
parseLet :: Parser WExp
parseLet =
  [(Text, WExp)] -> WExp -> WExp
WLet
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( Text -> Parser ()
reserved Text
"let"
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
identifier forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser Text
symbol Text
"=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser WExp
parseWExp)) forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy` Parser ()
comma)
        )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Parser ()
reserved Text
"in" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser WExp
parseWExp)

parseOverlay :: Parser WExp
parseOverlay :: Parser WExp
parseOverlay = do
  Text -> Parser ()
reserved Text
"overlay"
  forall a. Parser a -> Parser a
brackets forall a b. (a -> b) -> a -> b
$ NonEmpty WExp -> WExp
WOverlay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser WExp
parseWExp forall (m :: * -> *) a sep.
MonadPlus m =>
m a -> m sep -> m (NonEmpty a)
`CNE.sepBy1` Parser ()
comma

parseMask :: Parser WExp
parseMask :: Parser WExp
parseMask = do
  Text -> Parser ()
reserved Text
"mask"
  WExp
w1 <- Parser WExp
parseWExpAtom
  WExp
w2 <- Parser WExp
parseWExpAtom
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Op -> [WExp] -> WExp
WOp Op
Mask [WExp
w1, WExp
w2]

parseImport :: Parser WExp
parseImport :: Parser WExp
parseImport = Text -> WExp
WImport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @Text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> Parser Text
symbol Text
"\"") (Text -> Parser Text
symbol Text
"\"") (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (forall a. Eq a => a -> a -> Bool
/= Char
'"')))

-- parseCat :: Parser WExp
-- parseCat =
--   WCat
--     <$> (X <$ reserved "hcat" <|> Y <$ reserved "vcat")
--     <*> brackets (parseWExp `sepBy` comma)

-- parseStruct :: Parser WExp
-- parseStruct = reserved "struct" *> fail "struct not implemented"

------------------------------------------------------------
-- Utility

runParser :: Parser a -> Text -> Either ParserError a
runParser :: forall a. Parser a -> Text -> Either ParserError a
runParser Parser a
p = forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
parse (forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
fully Parser ()
sc Parser a
p) [Char]
""

------------------------------------------------------------
-- JSON instance

instance FromJSON WExp where
  parseJSON :: Value -> Parser WExp
parseJSON = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"World DSL program" forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case forall a. Parser a -> Text -> Either ParserError a
runParser Parser WExp
parseWExp Text
t of
      Left ParserError
err -> forall a. HasCallStack => [Char] -> a
error (forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty ParserError
err)
      Right WExp
wexp -> forall (m :: * -> *) a. Monad m => a -> m a
return WExp
wexp