git.iko.soy/schematic
on master help sign in
Dumb prototype
6fd4877Denis Redozubov
LICENSEnew file+30
compare with master
unifiedsplit
@@ -0,0 +1,30 @@
1+Copyright (c) 2017, Denis Redozubov
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Denis Redozubov nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
schematic.cabalnew file+51
@@ -0,0 +1,51 @@
1+-- Initial schematic.cabal generated by cabal init. For further
2+-- documentation, see http://haskell.org/cabal/users-guide/
3+
4+name: schematic
5+version: 0.1.0.0
6+synopsis: JSON-biased spec and validation tool
7+-- description:
8+license: BSD3
9+license-file: LICENSE
10+author: Denis Redozubov
11+maintainer: denis.redozubov@gmail.com
12+-- copyright:
13+category: Data
14+build-type: Simple
15+extra-source-files: ChangeLog.md
16+cabal-version: >=1.10
17+
18+library
19+ exposed-modules: Data.Schematic
20+ -- ghc-options:
21+ -- other-modules:
22+ default-extensions: ConstraintKinds
23+ , DataKinds
24+ , DeriveFunctor
25+ , DeriveFoldable
26+ , DeriveDataTypeable
27+ , FlexibleInstances
28+ , FunctionalDependencies
29+ , GADTs
30+ , KindSignatures
31+ , InstanceSigs
32+ , MultiParamTypeClasses
33+ , OverloadedStrings
34+ , PolyKinds
35+ , QuasiQuotes
36+ , PartialTypeSignatures
37+ , RecordWildCards
38+ , ScopedTypeVariables
39+ , TemplateHaskell
40+ , TypeApplications
41+ , TypeFamilies
42+ , TypeInType
43+ , TypeOperators
44+ , TypeSynonymInstances
45+ build-depends: base >=4.9 && <4.10
46+ , recursion-schemes
47+ , singletons
48+ , regex-compat
49+ , vinyl
50+ hs-source-dirs: src
51+ default-language: Haskell2010
src/Data/Schematic.hsnew file+1
@@ -0,0 +1 @@
1+module Data.Schematic where
src/Data/Schematic/OldSchema.hsnew file+76
@@ -0,0 +1,76 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+
3+module Data.Schematic.Schema where
4+
5+import Data.Maybe
6+import Data.Proxy
7+import GHC.TypeLits
8+import Text.Regex
9+
10+
11+-- JSON types
12+data JText
13+data JNumber
14+data JArray
15+data JObject
16+data JNull
17+
18+type family Repr (ty :: k1) :: k2 where
19+ Repr JText = String -- because of matchRegex
20+ Repr JNumber = Double
21+
22+class Schema schema where
23+ type Term subschema
24+ predicate :: Repr (Term ty) -> Bool
25+
26+data Regexp (s :: Symbol) = Regexp
27+
28+instance KnownSymbol reg => Schema (Regexp reg) subschema where
29+ type Term (Regexp reg) subschema = Term ((), subschema)
30+ predicate = isJust . matchRegex (mkRegex $ symbolVal (Proxy :: Proxy reg))
31+
32+data LengthEqNat (n :: Nat)
33+data LengthGtNat (n :: Nat)
34+data LengthGeNat (n :: Nat)
35+data LengthLtNat (n :: Nat)
36+data LengthLeNat (n :: Nat)
37+
38+instance KnownNat n => Schema (LengthEqNat n) subschema where
39+ type Term (LengthEqNat n) s = Term s
40+ predicate s = natVal (Proxy :: Proxy n) == fromIntegral (length s)
41+ && predicate
42+
43+instance KnownNat n => Schema (LengthGtNat n) rest where
44+ type Term (LengthGtNat n) = JNumber
45+ predicate s = natVal (Proxy :: Proxy n) > fromIntegral (length s)
46+
47+instance KnownNat n => Schema (LengthGeNat n) rest where
48+ type Term (LengthGeNat n) = JNumber
49+ predicate s = natVal (Proxy :: Proxy n) >= fromIntegral (length s)
50+
51+instance KnownNat n => Schema (LengthLtNat n) rest where
52+ type Term (LengthLtNat n) = JNumber
53+ predicate s = natVal (Proxy :: Proxy n) < fromIntegral (length s)
54+
55+instance KnownNat n => Schema (LengthLeNat n) rest where
56+ type Term (LengthLeNat n) = JNumber
57+ predicate s = natVal (Proxy :: Proxy n) <= fromIntegral (length s)
58+
59+-- | Corresponds to [] or {} json values.
60+data EmptyObj = EmptyObj
61+
62+data ConsObj (s :: Symbol) jsval = ConsObj
63+
64+-- data Schema a where
65+-- (:*:) :: KnownSymbol label => label -> Schema l -> Schema r -> Schema a
66+-- (:%:) :: Schema c a => Schema a -> c a -> Schema a
67+-- Nil :: Schema a
68+
69+data (s :: Symbol) :+: obj = (:+:) a b
70+
71+infixl 6 :+:
72+infixl 6 :*:
73+infixl 9 :%:
74+
75+schema :: Schema ()
76+schema = "foo" :%: (Regexp "foo") :*: Nil
src/Data/Schematic/Schema.hsnew file+94
@@ -0,0 +1,94 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE InstanceSigs #-}
3+{-# LANGUAGE UndecidableInstances #-}
4+
5+module Data.Schematic.Schema where
6+
7+import Data.Functor.Foldable
8+import Data.Singletons.TH
9+import Data.Kind hiding (Type)
10+import Data.Proxy
11+import Data.Type.Equality
12+import Data.Vinyl
13+import Data.Vinyl.Functor
14+import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
15+
16+singletons [d|
17+ data Type
18+ = Text
19+ | Number
20+ | Array
21+ | Object
22+ | Null
23+
24+ |]
25+
26+type family CRepr (ty :: k) :: Type
27+
28+type family Repr (ty :: k1) :: k2 where
29+ Repr 'Text = String -- because of matchRegex
30+ Repr 'Number = Double
31+
32+class Constrained c ty | c -> ty where
33+ predicate :: Repr ty -> Bool
34+
35+data LengthEqNat nat
36+
37+instance KnownNat nat => Constrained (LengthEqNat nat) Text where
38+ predicate n = natVal (Proxy @nat) == fromIntegral (length n)
39+
40+type instance CRepr (LengthEqNat nat) = Number
41+
42+type family Verifiable (els :: k) (t :: z) :: Constraint where
43+ Verifiable '[] ty = ()
44+ Verifiable (e : els) ty = (Constrained e (CRepr e), Verifiable els ty)
45+
46+data Exists f where
47+ Exists :: f a -> Exists f
48+
49+data C els =
50+ forall els ty. Verifiable els ty => C (Rec Proxy els)
51+
52+data Schema where
53+ SchemaText :: Schema
54+ SchemaNumber :: Schema
55+ SchemaObjCons :: KnownSymbol label
56+ => Proxy label
57+ -> Schema -- new elem
58+ -> Schema -- tail
59+ -> Schema
60+ SchemaObjNil :: Schema
61+
62+class Schematic ty where
63+ rep :: Proxy ty -> Schema
64+
65+-- | Signals it's appropriate as a top-level json type
66+-- class Schematic ty => TopLevel ty
67+
68+data c :% s
69+
70+instance Schematic s => Schematic (c :% s) where
71+ rep _ = rep $ Proxy @s
72+
73+data NilObj
74+
75+instance Schematic NilObj where
76+ rep _ = SchemaObjNil
77+
78+data (:**) (label :: Symbol) e (s :: Type)
79+
80+instance (KnownSymbol label, Schematic e, Schematic s)
81+ => Schematic (label :** e s) where
82+ rep _ = SchemaObjCons
83+ (Proxy @label)
84+ (rep $ Proxy @e)
85+ (rep $ Proxy @s)
86+
87+data JText
88+
89+instance Schematic JText where
90+ rep _ = SchemaText
91+
92+-- type TestStruct
93+-- = "carrier" (JString :% LengthEqNat 2 :% Regexp "[a-zA-Z]+")
94+-- :& "booking_classes" (JArray :% (LengthArrLe 5) (JString :% Regexp "[a-zA-Z]{2}"))
src/Data/Schematic/Validatable.hsnew file+5
@@ -0,0 +1,5 @@
1+module Data.Schematic.Validatable where
2+
3+
4+class Validatable spec where
5+ type Schema a
stack.yamlnew file+66
@@ -0,0 +1,66 @@
1+# This file was automatically generated by 'stack init'
2+#
3+# Some commonly used options have been documented as comments in this file.
4+# For advanced use and comprehensive documentation of the format, please see:
5+# http://docs.haskellstack.org/en/stable/yaml_configuration/
6+
7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8+# A snapshot resolver dictates the compiler version and the set of packages
9+# to be used for project dependencies. For example:
10+#
11+# resolver: lts-3.5
12+# resolver: nightly-2015-09-21
13+# resolver: ghcjs-0.1.0_ghc-7.10.2
14+# resolver:
15+# name: custom-snapshot
16+# location: "./custom-snapshot.yaml"
17+resolver: lts-8.12
18+#resolver: ghc-8.0.2
19+
20+# User packages to be built.
21+# Various formats can be used as shown in the example below.
22+#
23+# packages:
24+# - some-directory
25+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
26+# - location:
27+# git: https://github.com/commercialhaskell/stack.git
28+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30+# extra-dep: true
31+# subdirs:
32+# - auto-update
33+# - wai
34+#
35+# A package marked 'extra-dep: true' will only be built if demanded by a
36+# non-dependency (i.e. a user package), and its test suites and benchmarks
37+# will not be run. This is useful for tweaking upstream packages.
38+packages:
39+- '.'
40+# Dependency packages to be pulled from upstream that are not in the resolver
41+# (e.g., acme-missiles-0.3)
42+extra-deps: []
43+
44+# Override default flag values for local packages and extra-deps
45+flags: {}
46+
47+# Extra package databases containing global packages
48+extra-package-dbs: []
49+
50+# Control whether we use the GHC we find on the path
51+# system-ghc: true
52+#
53+# Require a specific version of stack, using version ranges
54+# require-stack-version: -any # Default
55+# require-stack-version: ">=1.4"
56+#
57+# Override the architecture used by stack, especially useful on Windows
58+# arch: i386
59+# arch: x86_64
60+#
61+# Extra directories used by stack for building
62+# extra-include-dirs: [/path/to/dir]
63+# extra-lib-dirs: [/path/to/dir]
64+#
65+# Allow a newer minor version of GHC than the snapshot specifies
66+# compiler-check: newer-minor