module Parsers.Haskell.DataDef where

import Parsers.Haskell.Common      (class', ctor, var)
import Parsers.Haskell.Type        (anyKindedType, type', typeCtor, typeParam)
import SyntaxTrees.Haskell.DataDef (DataCtorDef (..), DataDef (..),
                                    DerivingClause (..), DerivingStrategy (..),
                                    FieldDef (..), NamedFieldDef (..),
                                    NewTypeDef (..), TypeDef (..),
                                    UnNamedFieldDef (..))

import Bookhound.Parser              (Parser, withError)
import Bookhound.ParserCombinators   (IsMatch (..), anySepBy, someSepBy, (<#>),
                                      (<|>), (|*), (|?))
import Bookhound.Parsers.Char        (colon, comma, equal)
import Bookhound.Parsers.Collections (tupleOf)
import Bookhound.Parsers.String      (maybeWithinParens, withinCurlyBrackets,
                                      withinParens)

import Data.Foldable (Foldable (fold))


typeDef :: Parser TypeDef
typeDef :: Parser TypeDef
typeDef = forall a. String -> Parser a -> Parser a
withError String
"Type declaration" forall a b. (a -> b) -> a -> b
$
  TypeCtor -> [TypeParam] -> AnyKindedType -> TypeDef
TypeDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a. IsMatch a => a -> Parser a
is String
"type") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser TypeCtor
typeCtor)
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser TypeParam
typeParam |*) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
equal
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser AnyKindedType
anyKindedType

newtypeDef :: Parser NewTypeDef
newtypeDef :: Parser NewTypeDef
newtypeDef = forall a. String -> Parser a -> Parser a
withError String
"Newtype declaration" forall a b. (a -> b) -> a -> b
$
  TypeCtor
-> [TypeParam]
-> Ctor
-> FieldDef
-> [DerivingClause]
-> NewTypeDef
NewTypeDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. IsMatch a => a -> Parser a
is String
"newtype" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser TypeCtor
typeCtor)
             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser TypeParam
typeParam |*) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
equal
             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Ctor
ctor
             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser FieldDef
fieldDef
             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser DerivingClause
derivingClause |*)

dataDef :: Parser DataDef
dataDef :: Parser DataDef
dataDef = forall a. String -> Parser a -> Parser a
withError String
"Data declaration" forall a b. (a -> b) -> a -> b
$
  TypeCtor
-> [TypeParam] -> [DataCtorDef] -> [DerivingClause] -> DataDef
DataDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. IsMatch a => a -> Parser a
is String
"data" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser TypeCtor
typeCtor)
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser TypeParam
typeParam |*)
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe [DataCtorDef])
alternatives)
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser DerivingClause
derivingClause |*)
  where
    alternatives :: Parser (Maybe [DataCtorDef])
alternatives = ((Parser Char
equal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a b. Parser a -> Parser b -> Parser [b]
someSepBy (forall a. IsMatch a => a -> Parser a
is String
"|") Parser DataCtorDef
dataCtorDef) |?)


namedFieldDef :: Parser NamedFieldDef
namedFieldDef :: Parser NamedFieldDef
namedFieldDef = Var -> Type -> NamedFieldDef
NamedFieldDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Var
var forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Parser Char
colon forall a. Parser a -> Integer -> Parser [a]
<#> Integer
2)
                              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Type
type'

unNamedFieldDef :: Parser UnNamedFieldDef
unNamedFieldDef :: Parser UnNamedFieldDef
unNamedFieldDef = Type -> UnNamedFieldDef
UnNamedFieldDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b. Parser b -> Parser b
withinParens Parser Type
type' forall a. Parser a -> Parser a -> Parser a
<|> Parser Type
type')

fieldDef :: Parser FieldDef
fieldDef :: Parser FieldDef
fieldDef = UnNamedFieldDef -> FieldDef
UnNamedField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser UnNamedFieldDef
unNamedFieldDef forall a. Parser a -> Parser a -> Parser a
<|>
           NamedFieldDef -> FieldDef
NamedField   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b. Parser b -> Parser b
withinCurlyBrackets Parser NamedFieldDef
namedFieldDef

dataCtorDef :: Parser DataCtorDef
dataCtorDef :: Parser DataCtorDef
dataCtorDef = Ctor -> [NamedFieldDef] -> DataCtorDef
NamedFieldsCtor   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Ctor
ctor
                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall b. Parser b -> Parser b
withinCurlyBrackets forall a b. (a -> b) -> a -> b
$
                                    forall a b. Parser a -> Parser b -> Parser [b]
anySepBy Parser Char
comma Parser NamedFieldDef
namedFieldDef) forall a. Parser a -> Parser a -> Parser a
<|>
              Ctor -> [UnNamedFieldDef] -> DataCtorDef
UnNamedFieldsCtor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Ctor
ctor
                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser UnNamedFieldDef
unNamedFieldDef |*)

derivingClause :: Parser DerivingClause
derivingClause :: Parser DerivingClause
derivingClause = (forall a. IsMatch a => a -> Parser a
is String
"deriving" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                  ((forall a. IsMatch a => a -> Parser a
is String
"stock" |?) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                      (DerivingStrategy -> [Class] -> DerivingClause
Deriving DerivingStrategy
StandardDeriving forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Class]
derivingList))
                  forall a. Parser a -> Parser a -> Parser a
<|> (forall a. IsMatch a => a -> Parser a
is String
"newtype" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                       (DerivingStrategy -> [Class] -> DerivingClause
Deriving DerivingStrategy
NewTypeDeriving forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Class]
derivingList))
                  forall a. Parser a -> Parser a -> Parser a
<|> (forall a. IsMatch a => a -> Parser a
is String
"anyclass" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                       (DerivingStrategy -> [Class] -> DerivingClause
Deriving DerivingStrategy
AnyClassDeriving forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Class]
derivingList))
                  forall a. Parser a -> Parser a -> Parser a
<|> ([Class] -> AnyKindedType -> DerivingClause
DerivingVia forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Class]
derivingList
                                   forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. IsMatch a => a -> Parser a
is String
"via" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser AnyKindedType
anyKindedType)))
  where
    derivingList :: Parser [Class]
derivingList = (forall a. Parser a -> Parser [a]
tupleOf Parser Class
class' forall a. Parser a -> Parser a -> Parser a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b. Parser b -> Parser b
maybeWithinParens Parser Class
class')