{-# language CPP             #-}
{-# language DataKinds       #-}
{-# language TemplateHaskell #-}
{-# language TypeOperators   #-}
{-|
Description : (Deprecated) Generate a set of Haskell types from a 'Schema'

This module is deprecated. Haskell types
corresponding to schema types should be
written manually.
-}
module Mu.Schema.Conversion.SchemaToTypes (
  generateTypesFromSchema
, Namer
) where

import           Control.Applicative
import           Data.Char
import qualified Data.Map                     as M
import           Data.SOP
import           GHC.Generics                 (Generic)
import           Language.Haskell.TH
import           Language.Haskell.TH.Datatype

import           Mu.Schema.Definition

-- | Generate the name from each new Haskell type
--   from the name given in the schema.
type Namer = String -> String

-- | Generates types to represent each of the types
--   in a given schema. You should call it as:
--   > $(generateTypesFromSchema f 'Schema)
--   where @f@ is a function @String -> String@
--   which obtains the Haskell name for a type
--   given the name in the schema. The second argument
--   is simply the name of the schema.
generateTypesFromSchema :: Namer -> Name -> Q [Dec]
generateTypesFromSchema :: Namer -> Name -> Q [Dec]
generateTypesFromSchema Namer
namer Name
schemaTyName
  = do let schemaTy :: Type
schemaTy = Name -> Type
ConT Name
schemaTyName
       Maybe (SchemaB Type String String)
schDef <- Type -> Q (Maybe (SchemaB Type String String))
typeToSchemaDef Type
schemaTy
       case Maybe (SchemaB Type String String)
schDef of
         Maybe (SchemaB Type String String)
Nothing -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"schema cannot be parsed"
         Just SchemaB Type String String
sd -> [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeDefB Type String String -> Q [Dec])
-> SchemaB Type String String -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Type -> Namer -> TypeDefB Type String String -> Q [Dec]
typeDefToDecl Type
schemaTy Namer
namer) SchemaB Type String String
sd

-- Generation of types
-- ===================

typeDefToDecl :: Type -> Namer -> TypeDefB Type String String -> Q [Dec]
-- Records with one field
typeDefToDecl :: Type -> Namer -> TypeDefB Type String String -> Q [Dec]
typeDefToDecl Type
_schemaTy Namer
namer (DRecord String
name [FieldDefB Type String String
f])
  = do let complete :: String
complete = Namer -> Namer
completeName Namer
namer String
name
       Name
fVar <- String -> Q Name
newName String
"f"
       Dec
d <- CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Type
-> ConQ
-> [DerivClauseQ]
-> DecQ
newtypeD ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
                     (String -> Name
mkName String
complete)
                     [Name -> TyVarBndr
PlainTV Name
fVar]
                     Maybe Type
forall a. Maybe a
Nothing
                     (Con -> ConQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [VarBangType] -> Con
RecC (String -> Name
mkName String
complete) [Namer
-> String -> Name -> FieldDefB Type String String -> VarBangType
fieldDefToDecl Namer
namer String
complete Name
fVar FieldDefB Type String String
f]))
                     [DerivClause -> DerivClauseQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Type
ConT ''Generic])]
       Type
_wTy <- Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"w"
       -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete [f])
       [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
d] -- , hsi]
-- Records with more than one field
typeDefToDecl Type
_schemaTy Namer
namer (DRecord String
name [FieldDefB Type String String]
fields)
  = do let complete :: String
complete = Namer -> Namer
completeName Namer
namer String
name
       Name
fVar <- String -> Q Name
newName String
"f"
       Dec
d <- CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataD ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
                  (String -> Name
mkName String
complete)
                  [Name -> TyVarBndr
PlainTV Name
fVar]
                  Maybe Type
forall a. Maybe a
Nothing
                  [Con -> ConQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [VarBangType] -> Con
RecC (String -> Name
mkName String
complete) ((FieldDefB Type String String -> VarBangType)
-> [FieldDefB Type String String] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map (Namer
-> String -> Name -> FieldDefB Type String String -> VarBangType
fieldDefToDecl Namer
namer String
complete Name
fVar) [FieldDefB Type String String]
fields))]
                  [DerivClause -> DerivClauseQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Type
ConT ''Generic])]
       Type
_wTy <- Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"w"
       -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete fields)
       [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
d] -- , hsi]
-- Enumerations
typeDefToDecl Type
_schemaTy Namer
namer (DEnum String
name [ChoiceDef String]
choices)
  = do let complete :: String
complete = Namer -> Namer
completeName Namer
namer String
name
       Name
fVar <- String -> Q Name
newName String
"f"
       Dec
d <- CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataD ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
                  (String -> Name
mkName String
complete)
                  [Name -> TyVarBndr
PlainTV Name
fVar]
                  Maybe Type
forall a. Maybe a
Nothing
                  [ Con -> ConQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [VarBangType] -> Con
RecC (String -> Name
mkName (String -> Namer
choiceName String
complete String
choicename)) [])
                    | ChoiceDef String
choicename <- [ChoiceDef String]
choices]
                  [DerivClause -> DerivClauseQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DerivStrategy -> [Type] -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Type
ConT ''Eq, Name -> Type
ConT ''Ord, Name -> Type
ConT ''Show, Name -> Type
ConT ''Generic])]
       Type
_wTy <- Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"w"
       -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (choiceMapping complete choices)
       [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
d] --, hsi]
-- Simple things
typeDefToDecl Type
_ Namer
_ (DSimple FieldTypeB Type String
_)
  = String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"DSimple is not supported"

fieldDefToDecl :: Namer -> String -> Name -> FieldDefB Type String String -> (Name, Bang, Type)
fieldDefToDecl :: Namer
-> String -> Name -> FieldDefB Type String String -> VarBangType
fieldDefToDecl Namer
namer String
complete Name
fVar (FieldDef String
name FieldTypeB Type String
ty)
  = ( String -> Name
mkName (String -> Namer
fieldName String
complete String
name)
    , SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
    , Type -> Type -> Type
AppT (Name -> Type
VarT Name
fVar) (Namer -> Name -> FieldTypeB Type String -> Type
fieldTypeToDecl Namer
namer Name
fVar FieldTypeB Type String
ty) )

{- broken for now
generateBuiltinInstance :: Bool -> Type -> String -> Name -> Dec
generateBuiltinInstance withPrereq wTy complete className
#if MIN_VERSION_template_haskell(2,12,0)
  = StandaloneDerivD Nothing ctx ty
#else
  = StandaloneDerivD ctx ty

#endif
  where
    me  = ConT (mkName complete)
    ctx = [AppT (ConT className) (AppT wTy (AppT me wTy)) | withPrereq]
    ty  = AppT (ConT className) (AppT me wTy)
-}

{-
generateHasSchemaInstance :: Type -> Type -> String -> String -> Type -> Dec
generateHasSchemaInstance wTy schemaTy schemaName complete mapping
  = InstanceD Nothing [AppT (ConT ''Applicative) wTy]
              (AppT (AppT (AppT (AppT (ConT ''HasSchema)
                                      wTy )
                                      schemaTy )
                                      (LitT (StrTyLit schemaName)))
                                      (AppT (ConT (mkName complete)) wTy) )
#if MIN_VERSION_template_haskell(2,15,0)
              [TySynInstD (TySynEqn Nothing
                                    (AppT (AppT (AppT (AppT (ConT ''FieldMapping)
                                                      wTy )
                                                      schemaTy )
                                                      (LitT (StrTyLit schemaName)) )
                                                      (AppT (ConT (mkName complete)) wTy))
                                    mapping) ]
#else
              [TySynInstD ''FieldMapping
                          (TySynEqn [ wTy, schemaTy, LitT (StrTyLit schemaName)
                                    , AppT (ConT (mkName complete)) wTy ]
                                     mapping) ]
#endif
-}

{-
fieldMapping :: String -> [FieldDefB Type String String] -> Type
fieldMapping _complete [] = PromotedNilT
fieldMapping complete (FieldDef name _ : rest)
  = AppT (AppT PromotedConsT thisMapping) (fieldMapping complete rest)
  where thisMapping
          = AppT (AppT (PromotedT '(:->))
                       (LitT (StrTyLit (fieldName complete name))))
                       (LitT (StrTyLit name))

choiceMapping :: String -> [ChoiceDef String] -> Type
choiceMapping _complete [] = PromotedNilT
choiceMapping complete (ChoiceDef name : rest)
  = AppT (AppT PromotedConsT thisMapping) (choiceMapping complete rest)
  where thisMapping
          = AppT (AppT (PromotedT '(:->))
                       (LitT (StrTyLit (choiceName complete name))))
                       (LitT (StrTyLit name))
-}

-- Name manipulation
-- =================

completeName :: Namer -> String -> String
completeName :: Namer -> Namer
completeName Namer
namer String
name = Namer
firstUpper (Namer
namer (Namer
firstUpper String
name))

choiceName :: String -> String -> String
choiceName :: String -> Namer
choiceName String
complete String
cname = Namer
firstUpper (String
complete String -> Namer
forall a. [a] -> [a] -> [a]
++ Namer
firstUpper String
cname)

fieldName :: String -> String -> String
fieldName :: String -> Namer
fieldName String
complete String
fname = Namer
firstLower (String
complete String -> Namer
forall a. [a] -> [a] -> [a]
++ Namer
firstUpper String
fname)

firstUpper :: String -> String
firstUpper :: Namer
firstUpper []       = Namer
forall a. HasCallStack => String -> a
error String
"Empty names are not allowed"
firstUpper (Char
x:String
rest) = Char -> Char
toUpper Char
x Char -> Namer
forall a. a -> [a] -> [a]
: String
rest

firstLower :: String -> String
firstLower :: Namer
firstLower []       = Namer
forall a. HasCallStack => String -> a
error String
"Empty names are not allowed"
firstLower (Char
x:String
rest) = Char -> Char
toLower Char
x Char -> Namer
forall a. a -> [a] -> [a]
: String
rest

fieldTypeToDecl :: Namer -> Name -> FieldTypeB Type String -> Type
fieldTypeToDecl :: Namer -> Name -> FieldTypeB Type String -> Type
fieldTypeToDecl Namer
_namer Name
_fVar FieldTypeB Type String
TNull
  = Name -> Type
ConT ''()
fieldTypeToDecl Namer
_namer Name
_fVar (TPrimitive Type
t)
  = Type
t
fieldTypeToDecl Namer
namer Name
fVar (TSchematic String
nm)
  = Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Namer -> Namer
completeName Namer
namer String
nm)) (Name -> Type
VarT Name
fVar)
fieldTypeToDecl Namer
namer Name
fVar (TOption FieldTypeB Type String
t)
  = Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe) (Namer -> Name -> FieldTypeB Type String -> Type
fieldTypeToDecl Namer
namer Name
fVar FieldTypeB Type String
t)
fieldTypeToDecl Namer
namer Name
fVar (TList FieldTypeB Type String
t)
  = Type -> Type -> Type
AppT Type
ListT (Namer -> Name -> FieldTypeB Type String -> Type
fieldTypeToDecl Namer
namer Name
fVar FieldTypeB Type String
t)
fieldTypeToDecl Namer
namer Name
fVar (TMap FieldTypeB Type String
k FieldTypeB Type String
v)
  = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''M.Map) (Namer -> Name -> FieldTypeB Type String -> Type
fieldTypeToDecl Namer
namer Name
fVar FieldTypeB Type String
k)) (Namer -> Name -> FieldTypeB Type String -> Type
fieldTypeToDecl Namer
namer Name
fVar FieldTypeB Type String
v)
fieldTypeToDecl Namer
namer Name
fVar (TUnion [FieldTypeB Type String]
ts)
  = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''NS) (Name -> Type
ConT ''I)) (Namer -> Name -> [FieldTypeB Type String] -> Type
fieldTypeUnion Namer
namer Name
fVar [FieldTypeB Type String]
ts)

fieldTypeUnion :: Namer -> Name -> [FieldTypeB Type String] -> Type
fieldTypeUnion :: Namer -> Name -> [FieldTypeB Type String] -> Type
fieldTypeUnion Namer
_ Name
_fVar [] = Type
PromotedNilT
fieldTypeUnion Namer
namer Name
fVar (FieldTypeB Type String
t:[FieldTypeB Type String]
ts)
  = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
PromotedConsT (Namer -> Name -> FieldTypeB Type String -> Type
fieldTypeToDecl Namer
namer Name
fVar FieldTypeB Type String
t)) (Namer -> Name -> [FieldTypeB Type String] -> Type
fieldTypeUnion Namer
namer Name
fVar [FieldTypeB Type String]
ts)

-- Parsing
-- =======

typeToSchemaDef :: Type -> Q (Maybe (SchemaB Type String String))
typeToSchemaDef :: Type -> Q (Maybe (SchemaB Type String String))
typeToSchemaDef Type
toplevelty
  = Type -> Maybe (SchemaB Type String String)
typeToSchemaDef' (Type -> Maybe (SchemaB Type String String))
-> Q Type -> Q (Maybe (SchemaB Type String String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
resolveTypeSynonyms Type
toplevelty
  where
    typeToSchemaDef' :: Type -> Maybe (SchemaB Type String String)
    typeToSchemaDef' :: Type -> Maybe (SchemaB Type String String)
typeToSchemaDef' Type
expanded
      = do [Type]
types <- Type -> Maybe [Type]
tyList Type
expanded
           (Type -> Maybe (TypeDefB Type String String))
-> [Type] -> Maybe (SchemaB Type String String)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Maybe (TypeDefB Type String String)
typeToTypeDef [Type]
types

    typeToTypeDef, typeToRecordDef, typeToEnumDef, typeToSimpleType
      :: Type -> Maybe (TypeDefB Type String String)
    typeToTypeDef :: Type -> Maybe (TypeDefB Type String String)
typeToTypeDef Type
t
      = Type -> Maybe (TypeDefB Type String String)
typeToRecordDef Type
t Maybe (TypeDefB Type String String)
-> Maybe (TypeDefB Type String String)
-> Maybe (TypeDefB Type String String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> Maybe (TypeDefB Type String String)
typeToEnumDef Type
t Maybe (TypeDefB Type String String)
-> Maybe (TypeDefB Type String String)
-> Maybe (TypeDefB Type String String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> Maybe (TypeDefB Type String String)
typeToSimpleType Type
t
    typeToRecordDef :: Type -> Maybe (TypeDefB Type String String)
typeToRecordDef Type
t
      = do (Type
nm, Type
fields) <- Name -> Type -> Maybe (Type, Type)
tyD2 'DRecord Type
t
           String
-> [FieldDefB Type String String] -> TypeDefB Type String String
forall builtin typeName fieldName.
typeName
-> [FieldDefB builtin typeName fieldName]
-> TypeDefB builtin typeName fieldName
DRecord (String
 -> [FieldDefB Type String String] -> TypeDefB Type String String)
-> Maybe String
-> Maybe
     ([FieldDefB Type String String] -> TypeDefB Type String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe String
tyString Type
nm
                   Maybe
  ([FieldDefB Type String String] -> TypeDefB Type String String)
-> Maybe [FieldDefB Type String String]
-> Maybe (TypeDefB Type String String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Type -> Maybe (FieldDefB Type String String))
-> [Type] -> Maybe [FieldDefB Type String String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Maybe (FieldDefB Type String String)
typeToFieldDef ([Type] -> Maybe [FieldDefB Type String String])
-> Maybe [Type] -> Maybe [FieldDefB Type String String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Maybe [Type]
tyList Type
fields)
    typeToEnumDef :: Type -> Maybe (TypeDefB Type String String)
typeToEnumDef Type
t
      = do (Type
nm, Type
choices) <- Name -> Type -> Maybe (Type, Type)
tyD2 'DEnum Type
t
           String -> [ChoiceDef String] -> TypeDefB Type String String
forall builtin typeName fieldName.
typeName
-> [ChoiceDef fieldName] -> TypeDefB builtin typeName fieldName
DEnum (String -> [ChoiceDef String] -> TypeDefB Type String String)
-> Maybe String
-> Maybe ([ChoiceDef String] -> TypeDefB Type String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe String
tyString Type
nm
                 Maybe ([ChoiceDef String] -> TypeDefB Type String String)
-> Maybe [ChoiceDef String] -> Maybe (TypeDefB Type String String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Type -> Maybe (ChoiceDef String))
-> [Type] -> Maybe [ChoiceDef String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Maybe (ChoiceDef String)
typeToChoiceDef ([Type] -> Maybe [ChoiceDef String])
-> Maybe [Type] -> Maybe [ChoiceDef String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Maybe [Type]
tyList Type
choices)
    typeToSimpleType :: Type -> Maybe (TypeDefB Type String String)
typeToSimpleType Type
t
      = do Type
innerT <- Name -> Type -> Maybe Type
tyD1 'DSimple Type
t
           FieldTypeB Type String -> TypeDefB Type String String
forall builtin typeName fieldName.
FieldTypeB builtin typeName -> TypeDefB builtin typeName fieldName
DSimple (FieldTypeB Type String -> TypeDefB Type String String)
-> Maybe (FieldTypeB Type String)
-> Maybe (TypeDefB Type String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe (FieldTypeB Type String)
typeToFieldType Type
innerT

    typeToFieldDef :: Type -> Maybe (FieldDefB Type String String)
    typeToFieldDef :: Type -> Maybe (FieldDefB Type String String)
typeToFieldDef Type
t
      = do (Type
nm, Type
innerTy) <- Name -> Type -> Maybe (Type, Type)
tyD2 'FieldDef Type
t
           String -> FieldTypeB Type String -> FieldDefB Type String String
forall builtin typeName fieldName.
fieldName
-> FieldTypeB builtin typeName
-> FieldDefB builtin typeName fieldName
FieldDef (String -> FieldTypeB Type String -> FieldDefB Type String String)
-> Maybe String
-> Maybe (FieldTypeB Type String -> FieldDefB Type String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe String
tyString Type
nm
                    Maybe (FieldTypeB Type String -> FieldDefB Type String String)
-> Maybe (FieldTypeB Type String)
-> Maybe (FieldDefB Type String String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe (FieldTypeB Type String)
typeToFieldType Type
innerTy

    typeToChoiceDef :: Type -> Maybe (ChoiceDef String)
    typeToChoiceDef :: Type -> Maybe (ChoiceDef String)
typeToChoiceDef Type
t
      = do Type
nm <- Name -> Type -> Maybe Type
tyD1 'ChoiceDef Type
t
           String -> ChoiceDef String
forall fieldName. fieldName -> ChoiceDef fieldName
ChoiceDef (String -> ChoiceDef String)
-> Maybe String -> Maybe (ChoiceDef String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe String
tyString Type
nm

    typeToFieldType :: Type -> Maybe (FieldTypeB Type String)
    typeToFieldType :: Type -> Maybe (FieldTypeB Type String)
typeToFieldType Type
t
      =     FieldTypeB Type String
forall builtin typeName. FieldTypeB builtin typeName
TNull FieldTypeB Type String
-> Maybe () -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> Type -> Maybe ()
tyD0 'TNull Type
t
        Maybe (FieldTypeB Type String)
-> Maybe (FieldTypeB Type String) -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Type -> FieldTypeB Type String
forall builtin typeName. builtin -> FieldTypeB builtin typeName
TPrimitive (Type -> FieldTypeB Type String)
-> Maybe Type -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>Name -> Type -> Maybe Type
tyD1 'TPrimitive Type
t
        Maybe (FieldTypeB Type String)
-> Maybe (FieldTypeB Type String) -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do Type
sch <- Name -> Type -> Maybe Type
tyD1 'TSchematic Type
t
                String -> FieldTypeB Type String
forall builtin typeName. typeName -> FieldTypeB builtin typeName
TSchematic (String -> FieldTypeB Type String)
-> Maybe String -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe String
tyString Type
sch)
        Maybe (FieldTypeB Type String)
-> Maybe (FieldTypeB Type String) -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do Type
inner <- Name -> Type -> Maybe Type
tyD1 'TOption Type
t
                FieldTypeB Type String -> FieldTypeB Type String
forall builtin typeName.
FieldTypeB builtin typeName -> FieldTypeB builtin typeName
TOption (FieldTypeB Type String -> FieldTypeB Type String)
-> Maybe (FieldTypeB Type String) -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe (FieldTypeB Type String)
typeToFieldType Type
inner)
        Maybe (FieldTypeB Type String)
-> Maybe (FieldTypeB Type String) -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do Type
inner <- Name -> Type -> Maybe Type
tyD1 'TList Type
t
                FieldTypeB Type String -> FieldTypeB Type String
forall builtin typeName.
FieldTypeB builtin typeName -> FieldTypeB builtin typeName
TList (FieldTypeB Type String -> FieldTypeB Type String)
-> Maybe (FieldTypeB Type String) -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe (FieldTypeB Type String)
typeToFieldType Type
inner)
        Maybe (FieldTypeB Type String)
-> Maybe (FieldTypeB Type String) -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do (Type
k,Type
v) <- Name -> Type -> Maybe (Type, Type)
tyD2 'TMap Type
t
                FieldTypeB Type String
-> FieldTypeB Type String -> FieldTypeB Type String
forall builtin typeName.
FieldTypeB builtin typeName
-> FieldTypeB builtin typeName -> FieldTypeB builtin typeName
TMap (FieldTypeB Type String
 -> FieldTypeB Type String -> FieldTypeB Type String)
-> Maybe (FieldTypeB Type String)
-> Maybe (FieldTypeB Type String -> FieldTypeB Type String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe (FieldTypeB Type String)
typeToFieldType Type
k Maybe (FieldTypeB Type String -> FieldTypeB Type String)
-> Maybe (FieldTypeB Type String) -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe (FieldTypeB Type String)
typeToFieldType Type
v)
        Maybe (FieldTypeB Type String)
-> Maybe (FieldTypeB Type String) -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do Type
inners <- Name -> Type -> Maybe Type
tyD1 'TUnion Type
t
                [FieldTypeB Type String] -> FieldTypeB Type String
forall builtin typeName.
[FieldTypeB builtin typeName] -> FieldTypeB builtin typeName
TUnion ([FieldTypeB Type String] -> FieldTypeB Type String)
-> Maybe [FieldTypeB Type String] -> Maybe (FieldTypeB Type String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type -> Maybe (FieldTypeB Type String))
-> [Type] -> Maybe [FieldTypeB Type String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Maybe (FieldTypeB Type String)
typeToFieldType ([Type] -> Maybe [FieldTypeB Type String])
-> Maybe [Type] -> Maybe [FieldTypeB Type String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Maybe [Type]
tyList Type
inners))

tyString :: Type -> Maybe String
tyString :: Type -> Maybe String
tyString (SigT Type
t Type
_)
  = Type -> Maybe String
tyString Type
t
tyString (LitT (StrTyLit String
s))
  = String -> Maybe String
forall a. a -> Maybe a
Just String
s
tyString Type
_
  = Maybe String
forall a. Maybe a
Nothing

tyList :: Type -> Maybe [Type]
tyList :: Type -> Maybe [Type]
tyList (SigT Type
t Type
_)
  = Type -> Maybe [Type]
tyList Type
t
tyList Type
PromotedNilT
  = [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just []
tyList (AppT (AppT Type
PromotedConsT Type
ty) Type
rest)
  = (Type
ty Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:) ([Type] -> [Type]) -> Maybe [Type] -> Maybe [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe [Type]
tyList Type
rest
tyList Type
_ = Maybe [Type]
forall a. Maybe a
Nothing

tyD0 :: Name -> Type -> Maybe ()
tyD0 :: Name -> Type -> Maybe ()
tyD0 Name
name (SigT Type
t Type
_) = Name -> Type -> Maybe ()
tyD0 Name
name Type
t
tyD0 Name
name (PromotedT Name
c)
  | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = () -> Maybe ()
forall a. a -> Maybe a
Just ()
  | Bool
otherwise = Maybe ()
forall a. Maybe a
Nothing
tyD0 Name
_ Type
_ = Maybe ()
forall a. Maybe a
Nothing

tyD1 :: Name -> Type -> Maybe Type
tyD1 :: Name -> Type -> Maybe Type
tyD1 Name
name (SigT Type
t Type
_) = Name -> Type -> Maybe Type
tyD1 Name
name Type
t
tyD1 Name
name (AppT (PromotedT Name
c) Type
x)
  | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
x
  | Bool
otherwise = Maybe Type
forall a. Maybe a
Nothing
tyD1 Name
_ Type
_ = Maybe Type
forall a. Maybe a
Nothing

tyD2 :: Name -> Type -> Maybe (Type, Type)
tyD2 :: Name -> Type -> Maybe (Type, Type)
tyD2 Name
name (SigT Type
t Type
_) = Name -> Type -> Maybe (Type, Type)
tyD2 Name
name Type
t
tyD2 Name
name (AppT (AppT (PromotedT Name
c) Type
x) Type
y)
  | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
x, Type
y)
  | Bool
otherwise = Maybe (Type, Type)
forall a. Maybe a
Nothing
tyD2 Name
_ Type
_ = Maybe (Type, Type)
forall a. Maybe a
Nothing

{-
tyD3 :: Name -> Type -> Maybe (Type, Type, Type)
tyD3 name (SigT t _) = tyD3 name t
tyD3 name (AppT (AppT (AppT (PromotedT c) x) y) z)
  | c == name = Just (x, y, z)
  | otherwise = Nothing
tyD3 _ _ = Nothing
-}