Dumb prototype

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2017, Denis Redozubov
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Denis Redozubov nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

schematic.cabal

@@ -0,0 +1,51 @@
+-- Initial schematic.cabal generated by cabal init.  For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                schematic
+version:             0.1.0.0
+synopsis:            JSON-biased spec and validation tool
+-- description:
+license:             BSD3
+license-file:        LICENSE
+author:              Denis Redozubov
+maintainer:          denis.redozubov@gmail.com
+-- copyright:
+category:            Data
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Data.Schematic
+  -- ghc-options:
+  -- other-modules:
+  default-extensions:  ConstraintKinds
+                     , DataKinds
+                     , DeriveFunctor
+                     , DeriveFoldable
+                     , DeriveDataTypeable
+                     , FlexibleInstances
+                     , FunctionalDependencies
+                     , GADTs
+                     , KindSignatures
+                     , InstanceSigs
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , PolyKinds
+                     , QuasiQuotes
+                     , PartialTypeSignatures
+                     , RecordWildCards
+                     , ScopedTypeVariables
+                     , TemplateHaskell
+                     , TypeApplications
+                     , TypeFamilies
+                     , TypeInType
+                     , TypeOperators
+                     , TypeSynonymInstances
+  build-depends:       base >=4.9 && <4.10
+                     , recursion-schemes
+                     , singletons
+                     , regex-compat
+                     , vinyl
+  hs-source-dirs:      src
+  default-language:    Haskell2010

src/Data/Schematic.hs

@@ -0,0 +1 @@
+module Data.Schematic where

src/Data/Schematic/OldSchema.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Data.Schematic.Schema where
+
+import Data.Maybe
+import Data.Proxy
+import GHC.TypeLits
+import Text.Regex
+
+
+-- JSON types
+data JText
+data JNumber
+data JArray
+data JObject
+data JNull
+
+type family Repr (ty :: k1) :: k2 where
+  Repr JText = String -- because of matchRegex
+  Repr JNumber = Double
+
+class Schema schema where
+  type Term subschema
+  predicate :: Repr (Term ty) -> Bool
+
+data Regexp (s :: Symbol) = Regexp
+
+instance KnownSymbol reg => Schema (Regexp reg) subschema where
+  type Term (Regexp reg) subschema = Term ((), subschema)
+  predicate = isJust . matchRegex (mkRegex $ symbolVal (Proxy :: Proxy reg))
+
+data LengthEqNat (n :: Nat)
+data LengthGtNat (n :: Nat)
+data LengthGeNat (n :: Nat)
+data LengthLtNat (n :: Nat)
+data LengthLeNat (n :: Nat)
+
+instance KnownNat n => Schema (LengthEqNat n) subschema where
+  type Term (LengthEqNat n) s = Term s
+  predicate s = natVal (Proxy :: Proxy n) == fromIntegral (length s)
+    && predicate
+
+instance KnownNat n => Schema (LengthGtNat n) rest where
+  type Term (LengthGtNat n) = JNumber
+  predicate s = natVal (Proxy :: Proxy n) > fromIntegral (length s)
+
+instance KnownNat n => Schema (LengthGeNat n) rest where
+  type Term (LengthGeNat n) = JNumber
+  predicate s = natVal (Proxy :: Proxy n) >= fromIntegral (length s)
+
+instance KnownNat n => Schema (LengthLtNat n) rest where
+  type Term (LengthLtNat n) = JNumber
+  predicate s = natVal (Proxy :: Proxy n) < fromIntegral (length s)
+
+instance KnownNat n => Schema (LengthLeNat n) rest where
+  type Term (LengthLeNat n) = JNumber
+  predicate s = natVal (Proxy :: Proxy n) <= fromIntegral (length s)
+
+-- | Corresponds to [] or {} json values.
+data EmptyObj = EmptyObj
+
+data ConsObj (s :: Symbol) jsval = ConsObj
+
+-- data Schema a where
+--   (:*:) :: KnownSymbol label => label -> Schema l -> Schema r -> Schema a
+--   (:%:) :: Schema c a => Schema a -> c a -> Schema a
+--   Nil   :: Schema a
+
+data (s :: Symbol) :+: obj = (:+:) a b
+
+infixl 6 :+:
+infixl 6 :*:
+infixl 9 :%:
+
+schema :: Schema ()
+schema = "foo" :%: (Regexp "foo") :*: Nil

src/Data/Schematic/Schema.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.Schematic.Schema where
+
+import Data.Functor.Foldable
+import Data.Singletons.TH
+import Data.Kind hiding (Type)
+import Data.Proxy
+import Data.Type.Equality
+import Data.Vinyl
+import Data.Vinyl.Functor
+import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
+
+singletons [d|
+    data Type
+      = Text
+      | Number
+      | Array
+      | Object
+      | Null
+
+  |]
+
+type family CRepr (ty :: k) :: Type
+
+type family Repr (ty :: k1) :: k2 where
+  Repr 'Text = String -- because of matchRegex
+  Repr 'Number = Double
+
+class Constrained c ty | c -> ty where
+  predicate :: Repr ty -> Bool
+
+data LengthEqNat nat
+
+instance KnownNat nat => Constrained (LengthEqNat nat) Text where
+  predicate n = natVal (Proxy @nat) == fromIntegral (length n)
+
+type instance CRepr (LengthEqNat nat) = Number
+
+type family Verifiable (els :: k) (t :: z) :: Constraint where
+  Verifiable '[]        ty = ()
+  Verifiable (e : els) ty = (Constrained e (CRepr e), Verifiable els ty)
+
+data Exists f where
+  Exists :: f a -> Exists f
+
+data C els =
+  forall els ty. Verifiable els ty => C (Rec Proxy els)
+
+data Schema where
+  SchemaText :: Schema
+  SchemaNumber :: Schema
+  SchemaObjCons :: KnownSymbol label
+    => Proxy label
+    -> Schema -- new elem
+    -> Schema -- tail
+    -> Schema
+  SchemaObjNil :: Schema
+
+class Schematic ty where
+  rep :: Proxy ty -> Schema
+
+-- | Signals it's appropriate as a top-level json type
+-- class Schematic ty => TopLevel ty
+
+data c :% s
+
+instance Schematic s => Schematic (c :% s) where
+  rep _ = rep $ Proxy @s
+
+data NilObj
+
+instance Schematic NilObj where
+  rep _ = SchemaObjNil
+
+data (:**) (label :: Symbol) e (s :: Type)
+
+instance (KnownSymbol label, Schematic e, Schematic s)
+  => Schematic (label :** e s) where
+  rep _ = SchemaObjCons
+    (Proxy @label)
+    (rep $ Proxy @e)
+    (rep $ Proxy @s)
+
+data JText
+
+instance Schematic JText where
+  rep _ = SchemaText
+
+-- type TestStruct
+--   = "carrier" (JString :% LengthEqNat 2 :% Regexp "[a-zA-Z]+")
+--   :& "booking_classes" (JArray :% (LengthArrLe 5) (JString :% Regexp "[a-zA-Z]{2}"))

src/Data/Schematic/Validatable.hs

@@ -0,0 +1,5 @@
+module Data.Schematic.Validatable where
+
+
+class Validatable spec where
+  type Schema a

stack.yaml

@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# http://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+#  name: custom-snapshot
+#  location: "./custom-snapshot.yaml"
+resolver: lts-8.12
+#resolver: ghc-8.0.2
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#   extra-dep: true
+#  subdirs:
+#  - auto-update
+#  - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- '.'
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.4"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor