venzone-1.0.0.0: src/Parse.hs

{-# Language LambdaCase #-}

module Parse where

import Tile
import Room
import Story
import Plant
import Meeple.Operate
import Input

import Terminal.Game
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import Lens.Micro.Platform

import qualified Codec.Binary.UTF8.Light as U8
import qualified Control.Monad.State     as S
import qualified Data.Void               as V
import qualified Data.List.NonEmpty      as LN
import qualified Data.Set                as DS

-- proparse: we are in between ®®
type PropParse = Bool
data ParseState = ParseState { psCoords :: Coords,
                               psProp   :: PropParse }
            deriving (Eq, Show)

-- coords: for map parsing
type Parser a = ParsecT V.Void String (S.State ParseState) a


---------------
-- INTERFACE --
---------------

readStory :: FilePath -> IO Story
readStory fp =
        parseRun fp pstory <$> U8.readUTF8File fp

-- run parse and crash on error
parseRun :: FilePath -> Parser a -> String -> a
parseRun fp p t =
        let eps = runParserT p fp t
            ep  = fst $ S.runState eps pstate
            a   = either (error . (errProl ++) . errorBundlePretty) id ep
        in a
    where
          pstate = ParseState (1, 1) False

          errProl = unlines
            ["",
             "",
             "Error in parsing Story file!",
             "Read what's written below; if the error is unclear or you",
             "found a bug, contact me at <fa-ml@ariis.it>.",
             ""]


-----------
-- STORY --
-----------

pstory :: Parser Story
pstory = option () noncode *> st
       <?> "Story file"
    where
          ps = proom <* (noncode <|> eof)
             <?> "room (and maybe noncode)"
          st = buildStory <$> pstoryname
                          <*> (proomsize <* eol)
                          <*> pstartroom
                          <*  noncode
                          <*> some ps
                          <*  eof
             <?> "Story body"

pstoryname :: Parser String
pstoryname = string "story_name:" *> space1 *> someTill anySingle eol
           <?> "story_name instruction"

proomsize :: Parser Coords
proomsize = string "room_size:" >>
            space1 >> num >>= \r ->
            space1 >> num >>= \c ->
            return (r, c)
          <?> "room_size instruction"
    where
          num :: Parser Integer
          num = read <$> some digitChar

pstartroom :: Parser String
pstartroom = string "start_room:" *> space1 *> someTill anySingle eol
           <?> "start_room instruction"


pcomment :: Parser ()
pcomment = string "@@" *>
           manyTill anySingle (() <$ eol <|> eof) *>
           pure ()
         <?> "Comment"

-- a number of comments/whitespace
noncode :: Parser ()
noncode = () <$ some (space1 <|> pcomment)
        <?> "Whitespace or Comment"



----------
-- ROOM --
----------

proom :: Parser Room
proom = ptitle                   >>= \t ->
        S.lift (S.put initState) >>
        pelements                >>= \es ->
        let r = elemsRoom es     in
        some pexit               >>= \xs ->
        return (r & title .~ t
                  & exits .~ xs)
      <?> "Room"
    where
          initState = ParseState (1, 1) False

-- title
ptitle :: Parser String
ptitle = char '#' *> space1 *> someTill anySingle eol
       <?> "Room title"

pelements :: Parser [RoomElem]
pelements = some pelem
          <?> "Room ASCII elements"


-----------
-- PLANT --
-----------

-- fill architecture/player/baddies
elemsRoom :: [RoomElem] -> Room
elemsRoom ces = foldr elemRoom defaultRoom ces

elemRoom :: RoomElem -> Room -> Room
elemRoom Blank        r = r
elemRoom (ETile t cs) r = r & plant %~ addTile cs t
elemRoom (EMeeple m)  r = addMeeple m r


-----------
-- EXITS --
-----------

pexit :: Parser Exit
pexit = string ">>>" *> space1 >>
        pcard <* space1        >>= \c ->
        string "->"  *> space1 >>
        someTill anySingle fin >>= \t ->
        return (Exit c t)
      <?> "Room exit (>>>)"
    where
          fin = () <$ eol <|> eof

pcard :: Parser Cardinal
pcard = choice [N <$ char' 'N',
                S <$ char' 'S',
                E <$ char' 'E',
                W <$ char' 'W']
      <?> "Cardinal direction (NWSE)"


--------------
-- ELEMENTS --
--------------

data RoomElem = ETile Tile Coords
              | EMeeple Meeple
              | Blank
              deriving (Show, Eq)

-- to be invoked after succesfull parsing of a char
pcoords :: Parser Coords
pcoords = S.lift (S.gets psCoords) >>= \cs ->
          return cs
        <?> "ASCII Room coordinates"

pelem :: Parser RoomElem
pelem = choice [try epropmode, try pprop,
                try etile, try emeeple,
                try eNewLine, espace]
      <?> "Room ASCII element (simple)"

eNewLine :: Parser RoomElem
eNewLine = eol          >>
           advance ARow >>
           return Blank
         <?> "enew line"

espace :: Parser RoomElem
espace = Blank <$ char ' ' <* advance ACol
       <?> "space (none) element"

epropmode :: Parser RoomElem
epropmode = Blank <$ char '®' <*
            (toggleprop <* advance ACol)
          <?> "text-mode marker"

emeeple :: Parser RoomElem
emeeple = EMeeple <$> pmeeple <* advance ACol
        <?> "meeple (creature)"

etile :: Parser RoomElem
etile = ETile <$> ltile <*> pcoords <* advance ACol
      <?> "Tile element"

pprop :: Parser RoomElem
pprop = anySingle >>= \c ->
        S.lift (S.gets psProp) >>= \case
          True  -> ETile (creaProp c) <$> pcoords <* advance ACol
          False -> expected [c] "prop element (we're not in prop mode)"
      <?> "Prop (background) char"

toggleprop :: Parser ()
toggleprop = let tog (ParseState c p) = ParseState c (not p) in
             S.lift (S.modify tog)
           <?> "Toggle Prop character (after ®)"


-------------------
-- TILES/MEEPLES --
-------------------

ltile :: Parser Tile
ltile = anySingle >>= \c ->
        case charTile c of
          Just t  -> return t
          Nothing -> expected [c] "tile"
      <?> "Single tile"

pmeeple :: Parser Meeple
pmeeple = anySingle >>= \c ->
          pcoords   >>= \cs ->
          case charMeeple c cs of
            Just m  -> return m
            Nothing -> expected [c] "meeple"
        <?> "Meeple"

-- wrong element / expected one
expected :: String -> String -> Parser a
expected cs t = failure (Just . Tokens $ LN.fromList cs)
                        (DS.fromList [Label $ LN.fromList t])
              <?> "expected error"


-----------------
-- ANCILLARIES --
-----------------

data Adv = ARow | ACol
advance :: Adv -> Parser ()
advance ARow = S.lift . S.modify $
                    \(ParseState (r, _) b) -> ParseState (r+1, 1) b
advance ACol = S.lift . S.modify $
                    \(ParseState (r, c) b) -> ParseState (r, c+1) b