Utils.hs

{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      : Hasmin.Parser.Utils
-- Copyright   : (c) 2017 Cristian Adrián Ontivero
-- License     : BSD3
-- Stability   : experimental
-- Portability : unknown
--
-----------------------------------------------------------------------------
module Hasmin.Parser.Utils
    ( ident
    , skipComments
    , lexeme
    , functionParser
    , digits
    , comma
    , colon
    , slash
    , opt
    , nmchar
    , hexadecimal
    , word8
    , parserFromPairs
    , atMost
    ) where

import Control.Applicative (liftA2, (<|>), many)
import Control.Monad (void, mzero)
import Data.Attoparsec.Text (char,
  option, Parser, satisfy, skipSpace, string)
import Data.Text (Text)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Word (Word8)
import qualified Data.Attoparsec.Text as A
import qualified Data.Char as C
import qualified Data.Map.Strict as Map

import Hasmin.Parser.Primitives

-- | Skip whatever comments and whitespaces are found.
skipComments :: Parser ()
skipComments = void $ many (skipSpace *> comment) <* skipSpace

-- | Parse a comment, i.e. a string starting with \"\/\*\" and ending with \"\*\/\"
comment :: Parser Text
comment = mappend <$> string "/*" <*> (string "*/" <|> untilAsterisk)
  where untilAsterisk = mappend <$> A.takeWhile (/= '*') <*> checkAsterisk
        checkAsterisk = mappend <$> string "*" <*> (string "/" <|> untilAsterisk)

comma :: Parser Char
comma = lexeme $ char ','

colon :: Parser Char
colon = lexeme $ char ':'

slash :: Parser Char
slash = lexeme $ char '/'

lexeme :: Parser a -> Parser a
lexeme p = skipComments *> p <* skipComments

-- | Given a parser, makes it optional, defaulting to whatever value its 'Monoid'
-- instance defines for 'mempty'.
opt :: Monoid m => Parser m -> Parser m
opt = option mempty

-- | Assumes the identifier and the left parenthesis have been parsed
-- Parses p, ignoring surrounding whitespace and comments, and consumes the
-- final right parenthesis.
functionParser :: Parser a -> Parser a
functionParser p = lexeme p <* char ')'

hexadecimal :: Parser Char
hexadecimal = satisfy C.isHexDigit

word8 :: Parser Word8
word8 = read <$> digits

parserFromPairs :: [(Text, Parser a)] -> Parser a
parserFromPairs ls = do
    i <- ident
    let t = T.toLower i
    fromMaybe mzero (Map.lookup t m)
  where m = Map.fromList ls

atMost :: Int -> Parser a -> Parser [a]
atMost 0 _ = pure []
atMost n p = A.option [] $ liftA2 (:) p (atMost (n-1) p)