Initial commit --- working in progress

README.md

@@ -0,0 +1,10 @@
+Nirum
+=====
+
+Nirum is a [distributed object][1] framework/compiler for microservices,
+built on top of the modern Web server technologies such as RESTful HTTP and
+JSON.
+
+WIP.
+
+[1]: https://en.wikipedia.org/wiki/Distributed_object

Setup.hs

@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain

examples/builtins.nrm

@@ -0,0 +1,73 @@
+# Introducing built-in types.
+
+record number-types (
+    bigint a,
+    # `bigint` stores an arbitrary integer.  Represented as a string in JSON.
+
+    decimal b,
+    # `decimal` stores an arbitrary real number.
+    # Represented as a string in JSON.
+
+    int32 c,
+    # `int32` stores a 32-bit signed integer.  Represented as a number in JSON.
+
+    int64 d,
+    # `int64` stores a 64-bit signed integer.  Represented as a number in JSON.
+
+    float32 e,
+    # `float32` stores a 32-bit signed floating number.
+    # Represented as a number in JSON.
+
+    float64 f,
+    # `float64` stores a 64-bit signed floating number.
+    # Represented as a number in JSON.
+);
+
+record string-types (
+    text a,
+    # `text` stores an arbitrary size of Unicode string.
+    # Represented as a string in JSON.
+
+    binary b,
+    # `binary` stores an arbitrary size of byte string.
+    # Represented as a base64 string in JSON.
+);
+
+record time-types (
+    date a,
+    # `date` stores a date assuming the Gregorian calendar.
+    # Represented as an ISO 8601 string in JSON.
+
+    datetime b,
+    # `datetime` stores a UTC date and time assuming the Gregorian calendar.
+    # Represented as an RFC 3339 string in JSON.
+);
+
+record et-cetera (
+    bool a,
+    # `bool` stores a boolean value.  Represented as `true`/`false` in JSON.
+
+    uuid b,
+    # `uuid` stores a UUID.  Represented as a string in JSON.
+
+    uri c,
+    # `uri` stores a URI.  Represented as a string in JSON.
+);
+
+record containers (
+    bigint? a,
+    # Option stores an any value of the specified type, or an empty state
+    # i.e. null, nil, none.  An empty state is represented as a `null` in JSON.
+
+    {bigint} b,
+    # Set stores an unordered set of unique elements.
+    # Represented as an array in JSON.
+
+    [bigint] c,
+    # List stores an ordered list of elements that some of them might be
+    # duplicated.  Represented as an array in JSON.
+
+    {text: bigint} d,
+    # Map stores a map of unique keys to values.
+    # Represented as an array of arrays in JSON e.g. `[[k, v], [k2, v2], ...]`.
+);

examples/product.nrm

@@ -0,0 +1,19 @@
+enum currency = krw
+              | jpy
+              | usd
+              ;
+
+record money (
+    currency currency,
+    decimal amount
+);
+
+record product (
+    text name,
+    money? price
+);
+
+record order (
+    {product: bigint} items,
+    datetime ordered-at
+);

examples/shapes.nrm

@@ -0,0 +1,44 @@
+# Module consists zero or more type declarations.
+
+boxed offset (float64);
+# If there's only one field which omit its identifier in a value type,
+# it's defined as a boxed type of the field type.
+#
+# The key difference between boxed type and value type consisting of single
+# consturctor of a field is that the former has the same JSON representation
+# to its boxing target type, while the latter has thicker JSON representation
+# than its only field.
+#
+# For example, a boxed type `value offset (float);` is represented in JSON as:
+#
+#     120.5
+#
+# While a value type `value offset (float position);` is represented in JSON as:
+#
+#     {"position": 120.5}
+#
+# What does it mean?  It means you can safely change a value type `float`
+# to its boxed type `offset` with backward compatibility.
+
+record point (
+    # Value type definition `value t = t (...);` can be shortened as
+    # `value t (...);`.
+
+    offset left/x,
+    # for backward compatibility, you can specify *behind name*.
+
+    offset top,
+    # trailing comma is okay
+);
+
+union shape
+    # Type constructors in a sum type become translated to subtypes in OO
+    # languages, and datatypes in functional languages.
+    = rectangle (point upper-left, point lower-right)
+    | circle (point origin, offset radius)
+    ;
+
+// This is comment.  Note that there are important differences between
+// `#` comment syntax and `//` comment syntax:  the former is for docs
+// thus captured as AST, while the latter is for just comments thus eliminated
+// after parsing.

nirum.cabal

@@ -0,0 +1,72 @@
+name:                nirum
+version:             0.1.0
+synopsis:            Distributed object framework built on top of
+                     REST HTTP and JSON
+description:         Distributed object framework for microservices,
+                     built on top of RESTful HTTP and JSON
+homepage:            https://bitbucket.org/dahlia/nirum
+bug-reports:         https://bitbucket.org/dahlia/nirum/issues
+license:             GPL-3
+license-file:        LICENSE
+author:              Hong Minhee
+maintainer:          hongminhee@member.fsf.org
+copyright:           (c) 2016 Hong Minhee
+stability:           alpha
+category:            Language
+build-type:          Simple
+extra-source-files:  README.md
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Nirum.Constructs
+                 ,     Nirum.Constructs.Declaration
+                 ,     Nirum.Constructs.DeclarationSet
+                 ,     Nirum.Constructs.Identifier
+                 ,     Nirum.Constructs.Module
+                 ,     Nirum.Constructs.Name
+                 ,     Nirum.Constructs.TypeDeclaration
+                 ,     Nirum.Constructs.TypeExpression
+                 ,     Nirum.Parser
+                 ,     Nirum.Targets.Python
+  build-depends:       base                     >=4.7     && <5
+               ,       containers               >=0.5.6.2 && <0.6
+               ,       interpolatedstring-perl6 >=1.0.0   && <1.1.0
+               ,       megaparsec               >=4.4.0   && <5.0.0
+               ,       text                     >=0.9.1.0 && <1.3
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  ghc-options:         -Wall -Werror -fwarn-incomplete-uni-patterns
+
+test-suite spec
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Spec.hs
+  other-modules:       Nirum.Constructs.DeclarationSpec
+               ,       Nirum.Constructs.DeclarationSetSpec
+               ,       Nirum.Constructs.IdentifierSpec
+               ,       Nirum.Constructs.ModuleSpec
+               ,       Nirum.Constructs.NameSpec
+               ,       Nirum.Constructs.TypeDeclarationSpec
+               ,       Nirum.Constructs.TypeExpressionSpec
+               ,       Nirum.ParserSpec
+               ,       Nirum.Targets.PythonSpec
+  default-language:    Haskell2010
+  build-depends:       base            >=4.7     && <5
+               ,       directory
+               ,       hspec
+               ,       hspec-core
+               ,       hspec-meta
+               ,       megaparsec      >=4.4.0   && <5.0.0
+               ,       nirum
+               ,       text            >=0.9.1.0 && <1.3
+  ghc-options:         -Wall -Werror
+                       -fno-warn-incomplete-uni-patterns
+                       -fno-warn-missing-signatures
+
+test-suite hlint
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             HLint.hs
+  default-language:    Haskell2010
+  build-depends:       base        >=4.7     && <5
+               ,       hlint       >=1.9     && <2

src/Nirum/Constructs.hs

@@ -0,0 +1,6 @@
+module Nirum.Constructs (Construct, toCode) where
+
+import Data.Text (Text)
+
+class Ord a => Construct a where
+    toCode :: a -> Text

src/Nirum/Constructs/Declaration.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Nirum.Constructs.Declaration ( Declaration
+                                    , Docs(Docs)
+                                    , docs
+                                    , name
+                                    , toCode
+                                    , toCodeWithPrefix 
+                                    , toText
+                                    ) where
+
+import Data.String (IsString(fromString))
+
+import qualified Data.Text as T
+
+import Nirum.Constructs (Construct(toCode))
+import Nirum.Constructs.Name (Name)
+
+-- 'Construct' which has its own unique 'name' and can has its 'docs'.
+class Construct a => Declaration a where
+    name :: a -> Name
+    docs :: a -> Maybe Docs
+
+-- | Docstring for constructs.
+data Docs = Docs T.Text deriving (Eq, Ord, Show)
+
+-- | Convert the docs to text.
+toText :: Docs -> T.Text
+toText (Docs docs') = docs'
+
+-- | Similar to 'toCode' except it takes 'Maybe Docs' instead of 'Docs'.
+-- If the given docs is 'Nothing' it simply returns an empty string.
+-- Otherwise it returns a code string with the prefix.
+toCodeWithPrefix :: T.Text     -- | The prefix to be prepended if not empty.
+                 -> Maybe Docs -- | The docs to convert to code.
+                 -> T.Text
+toCodeWithPrefix _ Nothing = ""
+toCodeWithPrefix prefix (Just docs') = T.append prefix $ toCode docs'
+
+instance Construct Docs where
+    toCode (Docs docs') = let d = if "\n" `T.isSuffixOf` docs'
+                                  then T.dropEnd 1 docs'
+                                  else docs'
+                          in T.append "# " $ T.replace "\n" "\n# " d
+
+instance IsString Docs where
+    fromString s = let t = T.pack s
+                   in Docs (if "\n" `T.isSuffixOf` t
+                            then t
+                            else t `T.snoc` '\n')

src/Nirum/Constructs/DeclarationSet.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE OverloadedLists, TypeFamilies #-}
+module Nirum.Constructs.DeclarationSet ( DeclarationSet()
+                                       , NameDuplication( BehindNameDuplication
+                                                        , FacialNameDuplication
+                                                        )
+                                       , empty
+                                       , fromList
+                                       , lookup
+                                       , lookup'
+                                       , null
+                                       , null'
+                                       , size
+                                       , toList
+                                       , (!)
+                                       ) where
+
+import Data.Maybe (fromJust)
+import qualified GHC.Exts as L
+import Prelude hiding (lookup, null)
+
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+
+import Nirum.Constructs.Declaration (Declaration(name))
+import Nirum.Constructs.Identifier (Identifier)
+import Nirum.Constructs.Name (Name(Name, behindName, facialName))
+
+data Declaration a => DeclarationSet a
+    -- | The set of 'Declaration' values.
+    -- Every 'name' has to be unique in the set.
+    -- The order of declarations is maintained.
+    = DeclarationSet { declarations :: M.Map Identifier a
+                     , index :: ![Identifier]
+                     }
+    deriving (Eq, Ord, Show)
+
+data NameDuplication = FacialNameDuplication !Name
+                     | BehindNameDuplication !Name
+                     deriving (Eq, Show)
+
+empty :: Declaration a => DeclarationSet a
+empty = DeclarationSet { declarations = M.empty
+                       , index = []
+                       }
+
+fromList :: Declaration a => [a] -> Either NameDuplication (DeclarationSet a)
+fromList declarations' =
+    case findDup names facialName S.empty of
+        Just dup -> Left $ FacialNameDuplication dup
+        _ -> case findDup names behindName S.empty of
+            Just dup -> Left $ BehindNameDuplication dup
+            _ -> Right DeclarationSet { declarations = M.fromList mapList
+                                      , index = index'
+                                      }
+  where
+    names :: [Name]
+    names = map name declarations'
+    index' :: [Identifier]
+    index' = map facialName names
+    mapList = [(facialName (name d), d) | d <- declarations']
+    findDup :: [Name] -> (Name -> Identifier) -> S.Set Identifier -> Maybe Name
+    findDup names' f dups =
+        case names' of
+            x:xs -> let name' = f x
+                    in if name' `S.member` dups
+                       then Just x
+                       else findDup xs f $ S.insert name' dups
+            _ -> Nothing
+
+toList :: Declaration a => DeclarationSet a -> [a]
+toList (DeclarationSet declarations' index') =
+    map ((M.!) declarations') index'
+
+size :: Declaration a => DeclarationSet a -> Int
+size (DeclarationSet declarations' _) = M.size declarations'
+
+null :: Declaration a => DeclarationSet a -> Bool
+null = null'
+
+null' :: Declaration a => DeclarationSet a -> Bool
+null' (DeclarationSet declarations' _) = M.null declarations'
+
+lookup :: Declaration a => Identifier -> DeclarationSet a -> Maybe a
+lookup = lookup'
+
+lookup' :: Declaration a => Identifier -> DeclarationSet a -> Maybe a
+lookup' facialName' (DeclarationSet declarations' _) =
+    M.lookup facialName' declarations'
+
+(!) :: Declaration a => DeclarationSet a -> Identifier -> a
+declarationSet ! facialName' = fromJust $ lookup' facialName' declarationSet
+
+instance (Declaration a) => L.IsList (DeclarationSet a) where
+    type Item (DeclarationSet a) = a
+    fromList declarations' =
+        case fromList declarations' of
+            Right set -> set
+            Left (FacialNameDuplication (Name fname _)) ->
+                error ("identifiers must be unique; " ++ show fname ++
+                       " is defined more than once")
+            Left (BehindNameDuplication (Name _ bname)) ->
+                error ("behind names must be unique; " ++ show bname ++
+                        " is defined more than once")
+    toList = toList