Skip to content

Commit

Permalink
Not to import functions seperately
Browse files Browse the repository at this point in the history
  • Loading branch information
@kanghyojun
kanghyojun committed Feb 28, 2018
1 parent f9bc8d5 commit 87d7f5e
Show file tree
Hide file tree
Showing 5 changed files with 155 additions and 183 deletions.
28 changes: 23 additions & 5 deletions src/Nirum/Constructs/TypeDeclaration.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,7 +40,6 @@ module Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember)
, jsonType
, members
, primitiveTypeIdentifier
, tags
)
, TypeDeclaration ( Import
, ServiceDeclaration
Expand All @@ -54,6 +53,8 @@ module Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember)
, typeAnnotations
, typename
)
, unionType
, tags
) where

import Data.Maybe (isJust, maybeToList)
Expand All @@ -67,7 +68,7 @@ import Nirum.Constructs.Declaration ( Declaration (annotations, name)
, Documented (docs)
)
import Nirum.Constructs.Docs (Docs (Docs), toCodeWithPrefix)
import Nirum.Constructs.DeclarationSet (DeclarationSet, null', toList)
import Nirum.Constructs.DeclarationSet as DS
import Nirum.Constructs.Identifier (Identifier)
import Nirum.Constructs.ModulePath (ModulePath)
import Nirum.Constructs.Name (Name (Name))
Expand All @@ -82,14 +83,22 @@ data Type
| UnboxedType { innerType :: TypeExpression }
| EnumType { members :: DeclarationSet EnumMember }
| RecordType { fields :: DeclarationSet Field }
| UnionType { tags :: DeclarationSet Tag
, defaultTag :: Maybe Tag
}
| UnionType -- | Use 'unionType' instaed.
{ nondefaultTags :: DeclarationSet Tag -- This should not be exported.
, defaultTag :: Maybe Tag
}
| PrimitiveType { primitiveTypeIdentifier :: PrimitiveTypeIdentifier
, jsonType :: JsonType
}
deriving (Eq, Ord, Show)

tags :: Type -> DeclarationSet Tag
tags UnionType { nondefaultTags = tags', defaultTag = defTag } =
case fromList $ toList tags' ++ maybeToList defTag of
Right ts -> ts
Left _ -> DS.empty -- must never happen!
tags _ = DS.empty

-- | Member of 'EnumType'.
data EnumMember = EnumMember Name AnnotationSet deriving (Eq, Ord, Show)

Expand Down Expand Up @@ -134,6 +143,15 @@ data Tag = Tag { tagName :: Name
, tagAnnotations :: AnnotationSet
} deriving (Eq, Ord, Show)

-- | Create a 'UnionType'.
unionType :: [Tag] -> Maybe Tag -> Either NameDuplication Type
unionType t dt = case fromList t of
Right ts -> Right $
case dt of
Nothing -> UnionType ts Nothing
Just dt' -> UnionType (delete dt' ts) dt
Left a -> Left a

instance Construct Tag where
toCode tag@(Tag name' fields' _) =
if null' fields'
Expand Down
112 changes: 51 additions & 61 deletions src/Nirum/Parser.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,7 @@ module Nirum.Parser ( Parser
, enumTypeDeclaration
, file
, handleNameDuplication
, handleNameDuplicationError
, identifier
, imports
, listModifier
Expand Down Expand Up @@ -67,22 +68,10 @@ import Nirum.Constructs.Service ( Method (Method)
, Parameter (Parameter)
, Service (Service)
)
import Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember)
, Field (Field)
, Tag (Tag)
, Type ( Alias
, EnumType
, RecordType
, UnboxedType
, UnionType
)
, TypeDeclaration ( Import
, ServiceDeclaration
, TypeDeclaration
, serviceAnnotations
, typeAnnotations
)
)
import Nirum.Constructs.TypeDeclaration as TD hiding ( fields
, modulePath
, importName
)
import Nirum.Constructs.TypeExpression ( TypeExpression ( ListModifier
, MapModifier
, OptionModifier
Expand Down Expand Up @@ -254,37 +243,37 @@ aliasTypeDeclaration = do
annotationSet' <- annotationSet <?> "type alias annotations"
string' "type" <?> "type alias keyword"
spaces
typename <- identifier <?> "alias type name"
let name' = Name typename typename
typeName <- identifier <?> "alias type name"
let name' = Name typeName typeName
spaces
char '='
spaces
canonicalType <- typeExpression <?> "canonical type of alias"
canonicalType' <- typeExpression <?> "canonical type of alias"
spaces
char ';'
docs' <- optional $ try $ spaces >> (docs <?> "type alias docs")
annotationSet'' <- annotationsWithDocs annotationSet' docs'
return $ TypeDeclaration name' (Alias canonicalType) annotationSet''
return $ TypeDeclaration name' (Alias canonicalType') annotationSet''


unboxedTypeDeclaration :: Parser TypeDeclaration
unboxedTypeDeclaration = do
annotationSet' <- annotationSet <?> "unboxed type annotations"
string' "unboxed" <?> "unboxed type keyword"
spaces
typename <- identifier <?> "unboxed type name"
let name' = Name typename typename
typeName <- identifier <?> "unboxed type name"
let name' = Name typeName typeName
spaces
char '('
spaces
innerType <- typeExpression <?> "inner type of unboxed type"
innerType' <- typeExpression <?> "inner type of unboxed type"
spaces
char ')'
spaces
char ';'
docs' <- optional $ try $ spaces >> (docs <?> "unboxed type docs")
annotationSet'' <- annotationsWithDocs annotationSet' docs'
return $ TypeDeclaration name' (UnboxedType innerType) annotationSet''
return $ TypeDeclaration name' (UnboxedType innerType') annotationSet''

enumMember :: Parser EnumMember
enumMember = do
Expand All @@ -300,25 +289,31 @@ enumMember = do
return $ EnumMember memberName annotationSet''

handleNameDuplication :: Declaration a
=> String -> [a]
=> String
-> [a]
-> (DeclarationSet a -> Parser b)
-> Parser b
handleNameDuplication label' declarations cont =
case DeclarationSet.fromList declarations of
Left (BehindNameDuplication (Name _ bname)) ->
fail ("the behind " ++ label' ++ " name `" ++ toString bname ++
"` is duplicated")
Left (FacialNameDuplication (Name fname _)) ->
fail ("the facial " ++ label' ++ " name `" ++ toString fname ++
"` is duplicated")
Right set -> cont set
handleNameDuplication label' declarations cont = do
set <- handleNameDuplicationError label' $
DeclarationSet.fromList declarations
cont set

handleNameDuplicationError :: String -> Either NameDuplication a -> Parser a
handleNameDuplicationError _ (Right v) = return v
handleNameDuplicationError label' (Left dup) =
fail ("the " ++ nameType ++ " " ++ label' ++ " name `" ++
toString name' ++ "` is duplicated")
where
(nameType, name') = case dup of
BehindNameDuplication (Name _ bname) -> ("behind", bname)
FacialNameDuplication (Name fname _) -> ("facial", fname)

enumTypeDeclaration :: Parser TypeDeclaration
enumTypeDeclaration = do
annotationSet' <- annotationSet <?> "enum type annotations"
string "enum" <?> "enum keyword"
spaces
typename <- name <?> "enum type name"
typeName <- name <?> "enum type name"
spaces
frontDocs <- optional $ do
d <- docs <?> "enum type docs"
Expand All @@ -333,9 +328,9 @@ enumTypeDeclaration = do
spaces
return d
annotationSet'' <- annotationsWithDocs annotationSet' docs'
members <- (enumMember `sepBy1` (spaces >> char '|' >> spaces))
<?> "enum members"
case DeclarationSet.fromList members of
members' <- (enumMember `sepBy1` (spaces >> char '|' >> spaces))
<?> "enum members"
case DeclarationSet.fromList members' of
Left (BehindNameDuplication (Name _ bname)) ->
fail ("the behind member name `" ++ toString bname ++
"` is duplicated")
Expand All @@ -345,7 +340,7 @@ enumTypeDeclaration = do
Right memberSet -> do
spaces
char ';'
return $ TypeDeclaration typename (EnumType memberSet)
return $ TypeDeclaration typeName (EnumType memberSet)
annotationSet''

fieldsOrParameters :: forall a . (String, String)
Expand All @@ -354,12 +349,12 @@ fieldsOrParameters :: forall a . (String, String)
fieldsOrParameters (label', pluralLabel) make = do
annotationSet' <- annotationSet <?> (label' ++ " annotations")
spaces
type' <- typeExpression <?> (label' ++ " type")
typeExpr <- typeExpression <?> (label' ++ " type")
spaces1
name' <- name <?> (label' ++ " name")
spaces
let makeWithDocs = make name' type' . A.union annotationSet'
. annotationsFromDocs
let makeWithDocs = make name' typeExpr . A.union annotationSet'
. annotationsFromDocs
followedByComma makeWithDocs <|> do
d <- optional docs' <?> (label' ++ " docs")
return [makeWithDocs d]
Expand Down Expand Up @@ -396,7 +391,7 @@ recordTypeDeclaration = do
annotationSet' <- annotationSet <?> "record type annotations"
string "record" <?> "record keyword"
spaces
typename <- name <?> "record type name"
typeName <- name <?> "record type name"
spaces
char '('
spaces
Expand All @@ -410,15 +405,15 @@ recordTypeDeclaration = do
spaces
char ';'
annotationSet'' <- annotationsWithDocs annotationSet' docs'
return $ TypeDeclaration typename (RecordType fields') annotationSet''
return $ TypeDeclaration typeName (RecordType fields') annotationSet''

tag :: Parser (Tag, Bool)
tag = do
annotationSet' <- annotationSet <?> "union tag annotations"
spaces
default' <- optional (string "default" <?> "default tag")
spaces
tagName <- name <?> "union tag name"
tagName' <- name <?> "union tag name"
spaces
paren <- optional $ char '('
spaces
Expand All @@ -442,7 +437,7 @@ tag = do
spaces
return d
annotationSet'' <- annotationsWithDocs annotationSet' docs'
return ( Tag tagName fields' annotationSet''
return ( Tag tagName' fields' annotationSet''
, case default' of
Just _ -> True
Nothing -> False
Expand All @@ -453,7 +448,7 @@ unionTypeDeclaration = do
annotationSet' <- annotationSet <?> "union type annotations"
string "union" <?> "union keyword"
spaces
typename <- name <?> "union type name"
typeName <- name <?> "union type name"
spaces
docs' <- optional $ do
d <- docs <?> "union type docs"
Expand All @@ -464,23 +459,18 @@ unionTypeDeclaration = do
tags' <- (tag `sepBy1` try (spaces >> char '|' >> spaces))
<?> "union tags"
let tags'' = [t | (t, _) <- tags']
let defaultTag = do
let defaultTag' = do
(t''', _) <- L.find snd tags'
return t'''
spaces
char ';'
annotationSet'' <- annotationsWithDocs annotationSet' docs'
handleNameDuplication "tag" tags'' $ \ tagSet -> do
let remainTagSet = case defaultTag of
Just t -> DeclarationSet.delete t tagSet
Nothing -> tagSet

if length (L.filter snd tags') > 1
then fail "`union` have to has only 1 default tag."
else return $ TypeDeclaration
typename
(UnionType remainTagSet defaultTag)
annotationSet''
if length (L.filter snd tags') > 1
then fail "A union type cannot have more than a default tag."
else do
ut <- handleNameDuplicationError "tag" $
unionType tags'' defaultTag'
return $ TypeDeclaration typeName ut annotationSet''

typeDeclaration :: Parser TypeDeclaration
typeDeclaration = do
Expand Down Expand Up @@ -561,7 +551,7 @@ serviceDeclaration = do
annotationSet' <- annotationSet <?> "service annotation"
string "service" <?> "service keyword"
spaces
serviceName <- name <?> "service name"
serviceName' <- name <?> "service name"
spaces
char '('
spaces
Expand All @@ -575,7 +565,7 @@ serviceDeclaration = do
spaces
char ';'
annotationSet'' <- annotationsWithDocs annotationSet' docs'
return $ ServiceDeclaration serviceName (Service methods') annotationSet''
return $ ServiceDeclaration serviceName' (Service methods') annotationSet''

modulePath :: Parser ModulePath
modulePath = do
Expand Down
Loading

0 comments on commit 87d7f5e

Please sign in to comment.