{-# 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 (Int -> Kind -> ShowS
[Kind] -> ShowS
Kind -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Kind] -> ShowS
$cshowList :: [Kind] -> ShowS
show :: Kind -> String
$cshow :: Kind -> String
showsPrec :: Int -> Kind -> ShowS
$cshowsPrec :: Int -> Kind -> ShowS
Show)

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