Partially implement annotations

nirum.cabal

@@ -20,6 +20,7 @@ cabal-version:       >=1.10
 library
   exposed-modules:     Nirum.Cli
                  ,     Nirum.Constructs
+                 ,     Nirum.Constructs.Annotation
                  ,     Nirum.Constructs.Declaration
                  ,     Nirum.Constructs.DeclarationSet
                  ,     Nirum.Constructs.Identifier
@@ -68,6 +69,7 @@ test-suite spec
   hs-source-dirs:      test
   main-is:             Spec.hs
   other-modules:       Nirum.CliSpec
+               ,       Nirum.Constructs.AnnotationSpec
                ,       Nirum.Constructs.DeclarationSpec
                ,       Nirum.Constructs.DeclarationSetSpec
                ,       Nirum.Constructs.IdentifierSpec

src/Nirum/Constructs/Annotation.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
+module Nirum.Constructs.Annotation ( Annotation(Annotation)
+                                   , AnnotationSet(AnnotationSet)
+                                   , Metadata
+                                   , NameDuplication(AnnotationNameDuplication)
+                                   , annotations
+                                   , empty
+                                   , fromList
+                                   , toCode
+                                   , toList
+                                   ) where
+
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+import qualified Data.Text as T
+import Text.InterpolatedString.Perl6 (qq)
+
+import Nirum.Constructs (Construct (toCode))
+import Nirum.Constructs.Identifier (Identifier)
+
+
+type Metadata = T.Text
+
+-- | Annotation for 'Declaration'.
+data Annotation = Annotation { name :: Identifier
+                             , metadata :: Metadata
+                             } deriving (Eq, Ord, Show)
+
+instance Construct Annotation where
+    toCode Annotation {name = n,  metadata = m} = [qq|[{toCode n}: "$m"]|]
+
+data AnnotationSet
+  -- | The set of 'Annotation' values.
+  -- Every annotation name has to be unique in the set.
+  = AnnotationSet { annotations :: M.Map Identifier Annotation }
+  deriving (Eq, Ord, Show)
+
+instance Construct AnnotationSet where
+    toCode AnnotationSet {annotations = annotations'} =
+        T.concat [s | e <- M.elems annotations', s <- [toCode e, "\n"]]
+
+data NameDuplication = AnnotationNameDuplication Identifier
+                     deriving (Eq, Ord, Show)
+
+empty :: AnnotationSet
+empty = AnnotationSet { annotations = M.empty }
+
+fromList :: [Annotation] -> Either NameDuplication AnnotationSet
+fromList annotations' =
+    case findDup names S.empty of
+        Just duplication -> Left (AnnotationNameDuplication duplication)
+        _ -> Right AnnotationSet { annotations = M.fromList [ (name a, a)
+                                                            | a <- annotations'
+                                                            ]
+                                 }
+  where
+    names :: [Identifier]
+    names = [name a | a <- annotations']
+    findDup :: [Identifier] -> S.Set Identifier -> Maybe Identifier
+    findDup identifiers dups =
+        case identifiers of
+            x:xs -> if x `S.member` dups
+                    then Just x
+                    else findDup xs $ S.insert x dups
+            _ -> Nothing
+
+toList :: AnnotationSet -> [Annotation]
+toList AnnotationSet { annotations = annotations' } = M.elems annotations'

src/Nirum/Constructs/Declaration.hs

@@ -4,7 +4,7 @@ module Nirum.Constructs.Declaration ( Declaration
                                     , docs
                                     , name
                                     , toCode
-                                    , toCodeWithPrefix 
+                                    , toCodeWithPrefix
                                     , toText
                                     ) where
 

src/Nirum/Constructs/Module.hs

@@ -12,6 +12,7 @@ import qualified Data.Text as T
 import Text.InterpolatedString.Perl6 (q)
 
 import Nirum.Constructs (Construct(toCode))
+import Nirum.Constructs.Annotation (empty)
 import Nirum.Constructs.Declaration (Docs)
 import qualified Nirum.Constructs.DeclarationSet as DS
 import Nirum.Constructs.Identifier (Identifier)
@@ -66,22 +67,24 @@ coreModule = Module coreTypes $ Just coreDocs
 coreTypes :: DS.DeclarationSet TypeDeclaration
 coreTypes =
     -- number types
-    [ TypeDeclaration "bigint" (PrimitiveType Bigint String) Nothing
-    , TypeDeclaration "decimal" (PrimitiveType Decimal String) Nothing
-    , TypeDeclaration "int32" (PrimitiveType Int32 Number) Nothing
-    , TypeDeclaration "int64" (PrimitiveType Int64 Number) Nothing
-    , TypeDeclaration "float32" (PrimitiveType Float32 Number) Nothing
-    , TypeDeclaration "float64" (PrimitiveType Float64 Number) Nothing
+    [ TypeDeclaration "bigint" (PrimitiveType Bigint String) Nothing empty
+    , TypeDeclaration "decimal" (PrimitiveType Decimal String) Nothing empty
+    , TypeDeclaration "int32" (PrimitiveType Int32 Number) Nothing empty
+    , TypeDeclaration "int64" (PrimitiveType Int64 Number) Nothing empty
+    , TypeDeclaration "float32" (PrimitiveType Float32 Number) Nothing empty
+    , TypeDeclaration "float64" (PrimitiveType Float64 Number) Nothing empty
     -- string types
-    , TypeDeclaration "text" (PrimitiveType Text String) Nothing
-    , TypeDeclaration "binary" (PrimitiveType Binary String) Nothing
+    , TypeDeclaration "text" (PrimitiveType Text String) Nothing empty
+    , TypeDeclaration "binary" (PrimitiveType Binary String) Nothing empty
     -- time types
-    , TypeDeclaration "date" (PrimitiveType Date String) Nothing
-    , TypeDeclaration "datetime" (PrimitiveType Datetime String) Nothing
+    , TypeDeclaration
+          "date" (PrimitiveType Date String) Nothing empty
+    , TypeDeclaration
+          "datetime" (PrimitiveType Datetime String) Nothing empty
     -- et cetera
-    , TypeDeclaration "bool" (PrimitiveType Bool Boolean) Nothing
-    , TypeDeclaration "uuid" (PrimitiveType Uuid String) Nothing
-    , TypeDeclaration "uri" (PrimitiveType Uri String) Nothing
+    , TypeDeclaration "bool" (PrimitiveType Bool Boolean) Nothing empty
+    , TypeDeclaration "uuid" (PrimitiveType Uuid String) Nothing empty
+    , TypeDeclaration "uri" (PrimitiveType Uri String) Nothing empty
     ]
 
 coreDocs :: Docs

src/Nirum/Constructs/Service.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Nirum.Constructs.Service ( Method ( Method
+                                         , methodAnnotations
                                          , methodDocs
                                          , methodName
                                          , parameters
@@ -12,6 +13,7 @@ module Nirum.Constructs.Service ( Method ( Method
 import qualified Data.Text as T
 
 import Nirum.Constructs (Construct(toCode))
+import Nirum.Constructs.Annotation (AnnotationSet)
 import Nirum.Constructs.Declaration ( Declaration(name, docs)
                                     , Docs
                                     , toCodeWithPrefix
@@ -40,13 +42,18 @@ instance Declaration Parameter where
 -- | 'Service' method.
 data Method = Method { methodName :: Name
                      , parameters :: DeclarationSet Parameter
-                     , returnType :: TypeExpression 
+                     , returnType :: TypeExpression
                      , methodDocs :: Maybe Docs
+                     , methodAnnotations :: AnnotationSet
                      } deriving (Eq, Ord, Show)
 
 instance Construct Method where
-    toCode method@Method { parameters = params, methodDocs = docs' } =
-        T.concat $ [ toCode $ returnType method
+    toCode method@Method { parameters = params
+                         , methodDocs = docs'
+                         , methodAnnotations = annotationSet'
+                         } =
+        T.concat $ [ toCode annotationSet'
+                   , toCode $ returnType method
                    , " "
                    , toCode $ methodName method
                    , " ("

src/Nirum/Constructs/TypeDeclaration.hs

@@ -11,9 +11,11 @@ module Nirum.Constructs.TypeDeclaration ( EnumMember(EnumMember)
                                                          , importName
                                                          , modulePath
                                                          , service
+                                                         , serviceAnnotations
                                                          , serviceDocs
                                                          , serviceName
                                                          , type'
+                                                         , typeAnnotations
                                                          , typeDocs
                                                          , typename
                                                          )
@@ -25,8 +27,9 @@ import Data.String (IsString(fromString))
 import qualified Data.Text as T
 
 import Nirum.Constructs (Construct(toCode))
-import Nirum.Constructs.Declaration ( Declaration(..)
-                                    , Docs(..)
+import Nirum.Constructs.Annotation (AnnotationSet)
+import Nirum.Constructs.Declaration ( Declaration (..)
+                                    , Docs (..)
                                     , toCodeWithPrefix
                                     )
 import Nirum.Constructs.DeclarationSet (DeclarationSet, null', toList)
@@ -111,44 +114,51 @@ data TypeDeclaration
     = TypeDeclaration { typename :: Name
                       , type' :: Type
                       , typeDocs :: Maybe Docs
+                      , typeAnnotations :: AnnotationSet
                       }
     | ServiceDeclaration { serviceName :: Name
                          , service :: Service
                          , serviceDocs :: Maybe Docs
+                         , serviceAnnotations :: AnnotationSet
                          }
     | Import { modulePath :: ModulePath
              , importName :: Identifier
              }
     deriving (Eq, Ord, Show)
 
 instance Construct TypeDeclaration where
-    toCode (TypeDeclaration name' (Alias cname) docs') =
-        T.concat [ "type ", toCode name'
+    toCode (TypeDeclaration name' (Alias cname) docs' annotationSet') =
+        T.concat [ toCode annotationSet'
+                 , "type ", toCode name'
                  , " = ", toCode cname, ";"
                  , toCodeWithPrefix "\n" docs'
                  ]
-    toCode (TypeDeclaration name' (BoxedType itype) docs') =
-        T.concat [ "boxed ", toCode name'
+    toCode (TypeDeclaration name' (BoxedType itype) docs' annotationSet') =
+        T.concat [ toCode annotationSet'
+                 , "boxed ", toCode name'
                  , " (", toCode itype, ");"
                  , toCodeWithPrefix "\n" docs']
-    toCode (TypeDeclaration name' (EnumType members') docs') =
-        T.concat [ "enum ", toCode name'
+    toCode (TypeDeclaration name' (EnumType members') docs' annotationSet') =
+        T.concat [ toCode annotationSet'
+                 , "enum ", toCode name'
                  , toCodeWithPrefix "\n    " docs'
                  , "\n    = ", T.replace "\n" "\n    " membersCode, "\n    ;"
                  ]
       where
         membersCode = T.intercalate "\n| " $ map toCode $ toList members'
-    toCode (TypeDeclaration name' (RecordType fields') docs') =
-        T.concat [ "record ", toCode name', " ("
+    toCode (TypeDeclaration name' (RecordType fields') docs' annotationSet') =
+        T.concat [ toCode annotationSet'
+                 , "record ", toCode name', " ("
                  , toCodeWithPrefix "\n    " docs'
                  , if isJust docs' then "\n" else ""
                  , T.replace "\n" "\n    " $ T.cons '\n' fieldsCode
                  , "\n);"
                  ]
       where
         fieldsCode = T.intercalate "\n" $ map toCode $ toList fields'
-    toCode (TypeDeclaration name' (UnionType tags') docs') =
-        T.concat [ "union ", nameCode
+    toCode (TypeDeclaration name' (UnionType tags') docs' annotationSet') =
+        T.concat [ toCode annotationSet'
+                 , "union ", nameCode
                  , toCodeWithPrefix "\n    " docs'
                  , "\n    = " , tagsCode
                  , "\n    ;"
@@ -161,8 +171,12 @@ instance Construct TypeDeclaration where
                                  [ T.replace "\n" "\n    " (toCode t)
                                  | t <- toList tags'
                                  ]
-    toCode (TypeDeclaration name' (PrimitiveType typename' jsonType') docs') =
-        T.concat [ "// primitive type `", toCode name', "`\n"
+    toCode (TypeDeclaration name'
+                            (PrimitiveType typename' jsonType')
+                            docs'
+                            annotationSet') =
+        T.concat [ toCode annotationSet'
+                 , "// primitive type `", toCode name', "`\n"
                  , "//     internal type identifier: ", showT typename', "\n"
                  , "//     coded to json ", showT jsonType', " type\n"
                  , docString docs'
@@ -174,8 +188,9 @@ instance Construct TypeDeclaration where
         docString Nothing = ""
         docString (Just (Docs d)) =
             T.concat ["\n// ", T.replace "\n" "\n// " $ T.stripEnd d, "\n"]
-    toCode (ServiceDeclaration name' (Service methods) docs') =
-        T.concat [ "service "
+    toCode (ServiceDeclaration name' (Service methods) docs' annotations') =
+        T.concat [ toCode annotations'
+                 , "service "
                  , toCode name'
                  , " ("
                  , toCodeWithPrefix "\n    " docs'
@@ -204,9 +219,9 @@ instance Construct TypeDeclaration where
                                           ]
 
 instance Declaration TypeDeclaration where
-    name (TypeDeclaration name' _ _) = name'
-    name (ServiceDeclaration name' _ _) = name'
+    name (TypeDeclaration name' _ _ _) = name'
+    name (ServiceDeclaration name' _ _ _) = name'
     name (Import _ identifier) = Name identifier identifier
-    docs (TypeDeclaration _ _ docs') = docs'
-    docs (ServiceDeclaration _ _ docs') = docs'
+    docs (TypeDeclaration _ _ docs' _) = docs'
+    docs (ServiceDeclaration _ _ docs' _) = docs'
     docs (Import _ _) = Nothing