LayoutParser.hs

module Hydrogen.Syntax.Parser.LayoutParser where

import Hydrogen.Prelude hiding ((<|>), many)
import Hydrogen.Syntax.Types

import Hydrogen.Parsing.Char hiding (token, tokens, space)


data LayoutConfig a = LayoutConfig {
    cfgValueTokens :: String -> Maybe a
  , cfgBlockTransformer :: POP a -> POP a
  , cfgIndentToken :: String
}

instance Default (LayoutConfig a) where
    default_ = LayoutConfig {
        cfgValueTokens = const Nothing
      , cfgBlockTransformer = id
      , cfgIndentToken = ";;"
    }

parseLayout :: forall a. LayoutConfig a -> Parser (Tokens Token) (POPs a)
parseLayout cfg = runTokenParser (many (liftA2 (,) getPosition (someToken 0)) <* eof)
  where
    LayoutConfig { .. } = cfg

    someToken :: Monad m => Int -> ParsecT [(SourcePos, Token)] u m (POP a)
    someToken i = choice [
        sourceToken $ \case

            TIndent i' | i' <= i -> Just (Token SomethingT "" cfgIndentToken)

            TString k '\'' v -> Just (Token AposString k v)
            TString k '"'  v -> Just (Token QuotString k v)
            TString k '`'  v -> Just (Token TickString k v)

            TSpecial v -> Just (Token SomethingT "" [v])
            TSomething v
                | isJust val -> Just (Value (fromJust val) v)
                | otherwise  -> Just (Token SomethingT "" v)
              where
                val = cfgValueTokens v

            _ -> Nothing

      , do
            (k, c) <- sourceToken $ \case
                TBraceOpen k c -> curry Just k c
                _ -> Nothing
            i' <- sourceToken $ \(TIndent indent) -> Just indent
            ts <- many (liftA2 (,) getPosition (someToken i'))
            bt <- case c of
                '(' -> sourceToken $ \case TBraceClose ')' -> Just Grouping ; _ -> Nothing
                '[' -> sourceToken $ \case TBraceClose ']' -> Just Brackets ; _ -> Nothing
                '{' -> sourceToken $ \case TBraceClose '}' -> Just Mustache ; _ -> Nothing
                _ -> error "Popsicle!"
            return (cfgBlockTransformer $ Block bt k ts)

      ] <* skipMany (sourceToken lineContinuation)
      where
        lineContinuation = \case TIndent i' | i' > i -> Just () ; _ -> Nothing