Merge pull request #53 from Kroisse/docstr-annotation-unification

Unify docs into annotations

nirum.cabal

@@ -21,6 +21,7 @@ library
   exposed-modules:     Nirum.Cli
                  ,     Nirum.Constructs
                  ,     Nirum.Constructs.Annotation
+                 ,     Nirum.Constructs.Annotation.Internal
                  ,     Nirum.Constructs.Declaration
                  ,     Nirum.Constructs.DeclarationSet
                  ,     Nirum.Constructs.Identifier
@@ -76,6 +77,7 @@ test-suite spec
                ,       Nirum.Constructs.ModuleSpec
                ,       Nirum.Constructs.ModulePathSpec
                ,       Nirum.Constructs.NameSpec
+               ,       Nirum.Constructs.ServiceSpec
                ,       Nirum.Constructs.TypeDeclarationSpec
                ,       Nirum.Constructs.TypeExpressionSpec
                ,       Nirum.PackageSpec

src/Nirum/Constructs/Annotation.hs

@@ -1,67 +1,53 @@
-{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Nirum.Constructs.Annotation ( Annotation(Annotation)
-                                   , AnnotationSet(AnnotationSet)
+                                   , AnnotationSet
                                    , Metadata
                                    , NameDuplication(AnnotationNameDuplication)
                                    , annotations
+                                   , docs
                                    , empty
                                    , fromList
+                                   , insertDocs
+                                   , lookup
+                                   , lookupDocs
+                                   , singleton
                                    , toCode
                                    , toList
+                                   , union
                                    ) where
 
-import qualified Data.Char as C
+import Prelude hiding (lookup)
+
 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.Annotation.Internal
+import Nirum.Constructs.Declaration (Docs (Docs), annotationDocsName, toText)
 import Nirum.Constructs.Identifier (Identifier)
 
 
-type Metadata = T.Text
-
--- | Annotation for 'Declaration'.
-data Annotation = Annotation { name :: Identifier
-                             , metadata :: Maybe Metadata
-                             } deriving (Eq, Ord, Show)
-
-instance Construct Annotation where
-    toCode Annotation {name = n,  metadata = Just m} = [qq|@{toCode n}("$m'")|]
-      where
-        m' = (showLitString $ T.unpack m) ""
-        showLitString :: String -> ShowS
-        showLitString = foldr ((.) . showLitChar') id
-        showLitChar' :: Char -> ShowS
-        showLitChar' '"' = showString "\\\""
-        showLitChar' c   = C.showLitChar c
-    toCode Annotation {name = n,  metadata = Nothing} = [qq|@{toCode n}|]
-
-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"]]
+docs :: Docs -> Annotation
+docs (Docs d) = Annotation { name = annotationDocsName, metadata = Just d }
 
 data NameDuplication = AnnotationNameDuplication Identifier
                      deriving (Eq, Ord, Show)
 
 empty :: AnnotationSet
 empty = AnnotationSet { annotations = M.empty }
 
+singleton :: Annotation -> AnnotationSet
+singleton Annotation { name = name', metadata = metadata' } =
+    AnnotationSet { annotations = M.singleton name' metadata' }
+
 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'
-                                                            ]
-                                 }
+        _ -> Right $ AnnotationSet ( M.fromList [ (name a, metadata a)
+                                                | a <- annotations'
+                                                ]
+                                   )
   where
     names :: [Identifier]
     names = [name a | a <- annotations']
@@ -74,4 +60,28 @@ fromList annotations' =
             _ -> Nothing
 
 toList :: AnnotationSet -> [Annotation]
-toList AnnotationSet { annotations = annotations' } = M.elems annotations'
+toList AnnotationSet { annotations = annotations' } =
+    map fromTuple $ M.assocs annotations'
+
+union :: AnnotationSet -> AnnotationSet -> AnnotationSet
+union (AnnotationSet a) (AnnotationSet b) = AnnotationSet $ M.union a b
+
+lookup :: Identifier -> AnnotationSet -> Maybe Annotation
+lookup id' (AnnotationSet anno) = do
+    metadata' <- M.lookup id' anno
+    return Annotation { name = id', metadata = metadata' }
+
+lookupDocs :: AnnotationSet -> Maybe Docs
+lookupDocs annotationSet = do
+    Annotation _ m <- lookup annotationDocsName annotationSet
+    data' <- m
+    return $ Docs data'
+
+insertDocs :: (Monad m) => Docs -> AnnotationSet -> m AnnotationSet
+insertDocs docs' (AnnotationSet anno) =
+    case insertLookup annotationDocsName (Just $ toText docs') anno of
+        (Just _ , _    ) -> fail "<duplicated>"
+        (Nothing, anno') -> return $ AnnotationSet anno'
+  where
+    insertLookup :: Ord k => k -> a -> M.Map k a -> (Maybe a, M.Map k a)
+    insertLookup = M.insertLookupWithKey (\_ a _ -> a)

src/Nirum/Constructs/Annotation/Internal.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
+module Nirum.Constructs.Annotation.Internal ( Annotation(..)
+                                            , AnnotationSet(..)
+                                            , Metadata
+                                            , fromTuple
+                                            ) where
+
+import qualified Data.Char as C
+import qualified Data.Map.Strict as M
+import qualified Data.Text as T
+import Text.InterpolatedString.Perl6 (qq)
+
+import Nirum.Constructs (Construct (toCode))
+import Nirum.Constructs.Declaration (annotationDocsName)
+import Nirum.Constructs.Identifier (Identifier)
+
+
+type Metadata = T.Text
+
+-- | Annotation for 'Declaration'.
+data Annotation = Annotation { name :: Identifier
+                             , metadata :: Maybe Metadata
+                             } deriving (Eq, Ord, Show)
+
+instance Construct Annotation where
+    toCode Annotation {name = n,  metadata = Just m} = [qq|@{toCode n}("$m'")|]
+      where
+        m' = (showLitString $ T.unpack m) ""
+        showLitString :: String -> ShowS
+        showLitString = foldr ((.) . showLitChar') id
+        showLitChar' :: Char -> ShowS
+        showLitChar' '"' = showString "\\\""
+        showLitChar' c   = C.showLitChar c
+    toCode Annotation {name = n,  metadata = Nothing} = [qq|@{toCode n}|]
+
+fromTuple :: (Identifier, Maybe Metadata) -> Annotation
+fromTuple (name', meta') = Annotation { name = name', metadata = meta' }
+
+data AnnotationSet
+  -- | The set of 'Annotation' values.
+  -- Every annotation name has to be unique in the set.
+  = AnnotationSet { annotations :: M.Map Identifier (Maybe Metadata) }
+  deriving (Eq, Ord, Show)
+
+instance Construct AnnotationSet where
+    toCode AnnotationSet {annotations = annotations'} =
+        T.concat [s | e <- M.assocs annotations'
+                    , fst e /= annotationDocsName
+                    , s <- [toCode $ fromTuple e, "\n"]]

src/Nirum/Constructs/Declaration.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Nirum.Constructs.Declaration ( Declaration
                                     , Docs(Docs)
+                                    , annotationDocsName
                                     , docs
                                     , name
                                     , toCode
@@ -13,8 +14,12 @@ import Data.String (IsString(fromString))
 import qualified Data.Text as T
 
 import Nirum.Constructs (Construct(toCode))
+import Nirum.Constructs.Identifier (Identifier)
 import Nirum.Constructs.Name (Name)
 
+annotationDocsName :: Identifier
+annotationDocsName = "docs"
+
 -- 'Construct' which has its own unique 'name' and can has its 'docs'.
 class Construct a => Declaration a where
     name :: a -> Name

src/Nirum/Constructs/Module.hs

@@ -67,25 +67,29 @@ coreModule = Module coreTypes $ Just coreDocs
 coreTypes :: DS.DeclarationSet TypeDeclaration
 coreTypes =
     -- number types
-    [ 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
+    [ decl' "bigint" Bigint String
+    , decl' "decimal" Decimal String
+    , decl' "int32" Int32 Number
+    , decl' "int64" Int64 Number
+    , decl' "float32" Float32 Number
+    , decl' "float64" Float64 Number
     -- string types
-    , TypeDeclaration "text" (PrimitiveType Text String) Nothing empty
-    , TypeDeclaration "binary" (PrimitiveType Binary String) Nothing empty
+    , decl' "text" Text String
+    , decl' "binary" Binary String
     -- time types
-    , TypeDeclaration
-          "date" (PrimitiveType Date String) Nothing empty
-    , TypeDeclaration
-          "datetime" (PrimitiveType Datetime String) Nothing empty
+    , decl' "date" Date String
+    , decl' "datetime" Datetime String
     -- et cetera
-    , TypeDeclaration "bool" (PrimitiveType Bool Boolean) Nothing empty
-    , TypeDeclaration "uuid" (PrimitiveType Uuid String) Nothing empty
-    , TypeDeclaration "uri" (PrimitiveType Uri String) Nothing empty
+    , decl' "bool" Bool Boolean
+    , decl' "uuid" Uuid String
+    , decl' "uri" Uri String
     ]
+  where
+    decl' name prim json =
+        TypeDeclaration { typename = name
+                        , type' = PrimitiveType prim json
+                        , typeAnnotations = empty
+                        }
 
 coreDocs :: Docs
 coreDocs = [q|

src/Nirum/Constructs/Service.hs

@@ -1,19 +1,19 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Nirum.Constructs.Service ( Method ( Method
                                          , methodAnnotations
-                                         , methodDocs
                                          , methodName
                                          , parameters
                                          , returnType
                                          )
                                 , Parameter(Parameter)
                                 , Service(Service, methods)
+                                , methodDocs
                                 ) where
 
 import qualified Data.Text as T
 
 import Nirum.Constructs (Construct(toCode))
-import Nirum.Constructs.Annotation (AnnotationSet)
+import Nirum.Constructs.Annotation (AnnotationSet, lookupDocs)
 import Nirum.Constructs.Declaration ( Declaration(name, docs)
                                     , Docs
                                     , toCodeWithPrefix
@@ -44,14 +44,15 @@ data Method = Method { methodName :: Name
                      , parameters :: DeclarationSet Parameter
                      , returnType :: TypeExpression
                      , errorType  :: Maybe TypeExpression
-                     , methodDocs :: Maybe Docs
                      , methodAnnotations :: AnnotationSet
                      } deriving (Eq, Ord, Show)
 
+methodDocs :: Method -> Maybe Docs
+methodDocs = lookupDocs . methodAnnotations
+
 instance Construct Method where
     toCode method@Method { parameters = params
                          , errorType = error'
-                         , methodDocs = docs'
                          , methodAnnotations = annotationSet'
                          } =
         T.concat $ [ toCode annotationSet'
@@ -77,6 +78,8 @@ instance Construct Method where
       where
         params' :: [Parameter]
         params' = toList params
+        docs' :: Maybe Docs
+        docs' = lookupDocs annotationSet'
         indentedCode :: Construct a => a -> T.Text
         indentedCode c = T.concat [ "  "
                                   , T.intercalate "\n  " $ T.lines (toCode c)