RuleParser.hs

{-# LANGUAGE OverloadedStrings #-}

module Boilerplate.RuleParser (ruleParser) where

import Boilerplate.Types
import Control.Applicative
import qualified Data.Text as T
import Text.Parser.Char
import Text.Parser.Combinators

data Kind = RootTree | TParamTree | DataTree | FieldTree
  deriving (Show)

ruleParser :: CharParsing m => m Rule
ruleParser = Rule <$> (pTree RootTree <* eof)
  where
    tryText = try . text
    pN = read <$> option "1" (some digit)
    pTree tree = (many $ (pMagic' . choice $ contextual <> [pType, pCustom tree]) <|> pRaw) <?> (show tree)
      where
        contextual = case tree of
          RootTree -> [pTParams, pProduct, pSum, pSugarInstance]
          TParamTree -> [pTParam]
          DataTree -> [pUncons, pCons, pField]
          FieldTree -> [pCons, pParam, pFieldName, pFieldType, pTyCase]
    pRaw = Raw <$> T.pack <$> some pSourceChar <?> "haskell source"
    pRaw' = T.pack <$> many pSourceChar <?> "haskell source"
    pSourceChar = choice $ noneOf "{}\\" : (escaped <$> "{}\\")
      where escaped c = try $ char '\\' *> char c
    pMagic' fa = between (char '{') (char '}') fa
    pMagic fa = (pMagic' fa) <* spaces
    pMagic_ fa = spaces *> pMagic fa
    pType = Type <$ tryText "Type"
    pTParams = tryText "TParams" *> space *> (try pTParams1 <|> pTParams2)
      where
        pTParams1 = TParams <$> pMagic_ (pTree RootTree) <*> pMagic (pTree RootTree) <*> pMagic (pTree TParamTree) <*> pMagic pRaw' <*> pMagic pRaw'
        pTParams2 = (\el sep -> TParams [] [] el sep "") <$> pMagic_ (pTree TParamTree) <*> pMagic pRaw'
    pTParam = TParam <$ tryText "TParam"
    pProduct = tryText "Product" *> space *> (Product <$> pTree DataTree)
    pSum = tryText "Sum" *> space *> (try pSum1 <|> try pSum2 <|> pSum3)
      where
        pSum1 = (\t -> Sum "" t "" "") <$> pTree DataTree
        pSum2 = (\t s -> Sum "" t s "") <$> pMagic_ (pTree DataTree)  <*> pMagic pRaw'
        pSum3 = Sum <$> pMagic_ pRaw' <*> pMagic (pTree DataTree) <*> pMagic pRaw' <*> pMagic pRaw'
    pUncons = Uncons <$> (tryText "Uncons" *> pN)
    pCons = Cons <$ tryText "Cons"
    pField = tryText "Field" *> space *> (try pField1 <|> pField2)
      where
        pField1 = Field <$> pMagic_ (pTree DataTree) <*> pMagic (pTree DataTree) <*> pMagic (pTree FieldTree) <*> pMagic pRaw' <*> pMagic pRaw'
        pField2 = (\el sep -> Field [] [] el sep "") <$> pMagic_ (pTree FieldTree) <*> pMagic pRaw'
    pTyCase = tryText "TyCase" *> space *> pTyCase'
      where
        pTyCase' = TyCase <$> pMagic_ (pTree FieldTree) <*> pMagic (pTree FieldTree) <*> pMagic (pTree FieldTree)
    pParam = Param <$> (tryText "Param" *> pN)
    pFieldName = FieldName <$ tryText "FieldName"
    pFieldType = FieldType <$ tryText "FieldType"
    pCustom tree = Custom <$> (tryText "Custom" *> space *> pId) <*> (optional $ space *> pTree tree)
      where pId = T.pack <$> some alphaNum
    pSugarInstance = Sugar <$> (instance' <|> data')
      where
        instance' = Instance . T.pack <$> (tryText "Instance" *> space *> (some alphaNum))
        data' = Data <$> (tryText "Data" *> space *> pTree DataTree)