├── .gitignore ├── .travis.yml ├── README.md ├── bower.json ├── package.json ├── src ├── Data │ ├── Accessor.purs │ ├── EqSet.purs │ └── OrdMap.purs ├── MRA.purs └── MRA │ ├── Combinators.purs │ ├── Core.purs │ ├── Data.purs │ └── Provenance.purs └── test └── Test └── Main.purs /.gitignore: -------------------------------------------------------------------------------- 1 | .psci 2 | .psci_modules 3 | .pulp-cache 4 | bower_components 5 | node_modules 6 | output 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: node_js 2 | sudo: false 3 | node_js: stable 4 | install: 5 | - npm install -g bower 6 | - npm install 7 | - bower install 8 | script: 9 | - npm run -s build 10 | - npm run -s test 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Introduction 3 | 4 | This is a definition and reference implementation for MRA (Multidimensional Relational Algebra), the core calculus for [Quasar](http://github.com/quasar-analytics/quasar), an analytics engine for semi-structured data. 5 | 6 | Quasar's support for SQL2 is layered atop MRA, and many features of the SQL dialect have a natural and high-level mapping to MRA. 7 | 8 | # Tests 9 | 10 | Tests for the reference implementation (such as they are) are located in `src/Test.purs`. 11 | 12 | # MRA Spec 13 | 14 | TODO: A higher-level mathematical specification of the work contained herein which elides irrelevant details of this implementation. 15 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-mra", 3 | "homepage": "https://github.com/quasar-analytics/purescript-mra", 4 | "description": "A formal specification for MRA", 5 | "keywords": [ 6 | "purescript" 7 | ], 8 | "license": "Apache 2", 9 | "ignore": [ 10 | "**/.*", 11 | "bower_components", 12 | "node_modules", 13 | "output", 14 | "tests", 15 | "tmp", 16 | "bower.json", 17 | "Gruntfile.js", 18 | "package.json" 19 | ], 20 | "dependencies": { 21 | "purescript-prelude": "^3.1.0", 22 | "purescript-monoid": "^3.1.0", 23 | "purescript-foldable-traversable": "^3.4.0", 24 | "purescript-lists": "^4.9.0", 25 | "purescript-profunctor": "^3.2.0", 26 | "purescript-strings": "^3.3.0", 27 | "purescript-maps": "^3.5.0", 28 | "purescript-sets": "^3.0.0", 29 | "purescript-console": "^3.0.0" 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-mra", 3 | "description": "A definition and reference implementation for MRA", 4 | "license": "Apache 2", 5 | "scripts": { 6 | "build": "pulp build", 7 | "test": "pulp test" 8 | }, 9 | "devDependencies": { 10 | "pulp": "^11.0.0", 11 | "purescript": "^0.11.6" 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /src/Data/Accessor.purs: -------------------------------------------------------------------------------- 1 | module Data.Accessor where 2 | 3 | import Prelude (class Category, class Semigroupoid, id, const) 4 | 5 | type Setter s a = s -> a -> s 6 | type Getter s a = s -> a 7 | 8 | data Accessor s a = Accessor (Setter s a) (Getter s a) 9 | 10 | instance semigroupoidAccessor :: Semigroupoid Accessor where 11 | compose (Accessor setC getC) (Accessor setB getB) = Accessor set' get' 12 | where 13 | set' a c = setB a (setC (getB a) c) 14 | 15 | get' a = getC (getB a) 16 | 17 | instance categoryAccessor :: Category Accessor where 18 | id = Accessor const id 19 | 20 | xmap :: forall s a b. (b -> a) -> (a -> b) -> Accessor s a -> Accessor s b 21 | xmap f g (Accessor setter getter) = Accessor setter' getter' 22 | where 23 | setter' s b = setter s (f b) 24 | getter' s = g (getter s) 25 | 26 | set :: forall s a. Accessor s a -> s -> a -> s 27 | set (Accessor f _) = f 28 | 29 | get :: forall s a. Accessor s a -> s -> a 30 | get (Accessor _ g) = g 31 | -------------------------------------------------------------------------------- /src/Data/EqSet.purs: -------------------------------------------------------------------------------- 1 | module Data.EqSet 2 | ( Set() 3 | , contains 4 | , toList 5 | , toSet 6 | ) where 7 | 8 | import Prelude (class Eq, class Semigroup, ($), (&&), append, eq, (<<<)) 9 | import Data.List as L 10 | import Data.Foldable(class Foldable, foldr, foldl, foldMap, all, any) 11 | import Data.Monoid(class Monoid, mempty) 12 | 13 | -- | An inefficient implementation of `Set` which does not require ordering on the values. 14 | newtype Set a = Set (L.List a) 15 | 16 | toSet :: forall f a. Foldable f => Eq a => f a -> Set a 17 | toSet = Set <<< L.nub <<< foldr L.Cons L.Nil 18 | 19 | toList :: forall a. Set a -> L.List a 20 | toList (Set v) = v 21 | 22 | contains :: forall a. (Eq a) => Set a -> Set a -> Boolean 23 | contains (Set ls) (Set rs) = all (\v -> any (eq v) ls) rs 24 | 25 | union :: forall a. (Eq a) => Set a -> Set a -> Set a 26 | union (Set l) (Set r) = Set $ L.union l r 27 | 28 | intersect :: forall a. (Eq a) => Set a -> Set a -> Set a 29 | intersect (Set l) (Set r) = Set $ L.intersect l r 30 | 31 | instance semigroupSet :: (Eq a) => Semigroup (Set a) where 32 | append (Set l) (Set r) = Set (append l r) 33 | 34 | instance monoidSet :: (Eq a) => Monoid (Set a) where 35 | mempty = Set mempty 36 | 37 | instance eqSet :: (Eq a) => Eq (Set a) where 38 | eq l r = (l `contains` r) && (r `contains` l) 39 | 40 | instance foldableSet :: Foldable Set where 41 | foldr f z (Set v) = foldr f z v 42 | 43 | foldl f z (Set v) = foldl f z v 44 | 45 | foldMap f (Set v) = foldMap f v 46 | -------------------------------------------------------------------------------- /src/Data/OrdMap.purs: -------------------------------------------------------------------------------- 1 | module Data.OrdMap 2 | ( Map() 3 | , alter 4 | , empty 5 | , fromList 6 | , insert 7 | , keys 8 | , lookup 9 | , singleton 10 | , toList 11 | , unionWith 12 | , values ) where 13 | 14 | import Prelude(class Eq, class Functor, class Ord, class Semigroup, class Show, ($), (<$>), (<>), (>>>), (==), (&&), compare, eq, flip, map, pure, show) 15 | 16 | import Data.Map as M 17 | import Data.Monoid(class Monoid) 18 | import Data.Maybe(Maybe(), maybe) 19 | import Data.Tuple(Tuple(..), fst, snd) 20 | import Data.List(List(..), nub, reverse) 21 | import Data.Foldable(foldl, any) 22 | 23 | data Map k v = Map { reversed :: List k, values :: M.Map k v } 24 | 25 | alter :: forall k v. (Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v 26 | alter f k (Map r) = Map $ { reversed : if any (eq k) r.reversed then r.reversed else Cons k r.reversed, values : M.alter f k r.values } 27 | 28 | empty :: forall k v. Map k v 29 | empty = Map { reversed : Nil, values : M.empty } 30 | 31 | fromList :: forall k v. (Ord k) => List (Tuple k v) -> Map k v 32 | fromList l = Map { reversed : fst <$> reverse l, values : M.fromFoldable l } 33 | 34 | insert :: forall k v. (Ord k) => k -> v -> Map k v -> Map k v 35 | insert k v (Map r) = Map { reversed : Cons k r.reversed, values : M.insert k v r.values } 36 | 37 | lookup :: forall k v. (Ord k) => k -> Map k v -> Maybe v 38 | lookup k (Map r) = M.lookup k r.values 39 | 40 | singleton :: forall k v. (Ord k) => k -> v -> Map k v 41 | singleton k v = Map { reversed : pure k, values : M.singleton k v } 42 | 43 | toList :: forall k v. (Ord k) => Map k v -> List (Tuple k v) 44 | toList (Map r) = foldl (\l k -> maybe l (Tuple k >>> flip Cons l) $ M.lookup k r.values) Nil r.reversed 45 | 46 | unionWith :: forall k v. (Ord k) => (v -> v -> v) -> Map k v -> Map k v -> Map k v 47 | unionWith f (Map r1) (Map r2) = Map { reversed : nub (r1.reversed <> r2.reversed), values : M.unionWith f r1.values r2.values } 48 | 49 | values :: forall k v. (Ord k) => Map k v -> List v 50 | values = toList >>> map snd 51 | 52 | keys :: forall k v. (Ord k) => Map k v -> List k 53 | keys = toList >>> map fst 54 | 55 | instance semigroupMap :: (Ord k) => Semigroup (Map k v) where 56 | append (Map l) (Map r) = Map { reversed : nub (l.reversed <> r.reversed), values : l.values <> r.values } 57 | 58 | instance monoidMap :: (Ord k) => Monoid (Map k v) where 59 | mempty = empty 60 | 61 | instance eqMap :: (Ord k, Eq v) => Eq (Map k v) where 62 | eq (Map l) (Map r) = l.values == r.values && l.reversed == r.reversed 63 | 64 | instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where 65 | compare l r = toList l `compare` toList r 66 | 67 | instance showMap :: (Ord k, Show k, Show v) => Show (Map k v) where 68 | show m = "fromList (" <> show (toList m) <> ")" 69 | 70 | instance functorMap :: (Ord k) => Functor (Map k) where 71 | map f (Map r) = Map r { values = map f r.values } 72 | -------------------------------------------------------------------------------- /src/MRA.purs: -------------------------------------------------------------------------------- 1 | module MRA 2 | ( module MRA.Combinators 3 | , module MRA.Core 4 | , module MRA.Data 5 | , module MRA.Provenance 6 | ) where 7 | 8 | import MRA.Combinators 9 | import MRA.Core (Dataset, autojoin_d, dimensionality, filter_d, identities, literal_d, lshift_d, map_d, nest_d, project_d, reduce_d, swap_d, values) 10 | import MRA.Data (Data, Primitive, DataAccessor, DataGetter, isDefined, isWhollyDefined, foldData, definedWith, primInt, primNull, primChar, primString, makeMap, pretty, emptyMap, fieldAccessor, indexAccessor, keyAccessor) 11 | import MRA.Provenance (Provenance(..), JoinKeys(..), (\/), (/\), (>>), _Both, _Left, _OneOf, _Right, _Then, both, joinKeys, makeBoth, makeOneOfLeft, makeOneOfRight, makeThen, oneOf, then0, unJoinKeys) 12 | -------------------------------------------------------------------------------- /src/MRA/Combinators.purs: -------------------------------------------------------------------------------- 1 | module MRA.Combinators where 2 | 3 | import Prelude ((>>>), (<$>), (+), (-), eq, id) 4 | 5 | import Data.OrdMap as M 6 | import Data.Maybe(fromMaybe) 7 | import Data.Tuple(Tuple(..)) 8 | import Data.List((!!), (..), zipWith, length) 9 | 10 | import MRA.Data (Data(Map, Array, Primitive, Undefined), Primitive(PrimInt, PrimChar, PrimNull), primString, primInt) 11 | import MRA.Core (Dataset, autojoin_d, lshift_d, map_d, nest_d, swap_d, reduce_d, project_d) 12 | 13 | -- | Fractures maps and arrays, no matter how deeply nested, into path 14 | -- | segments that terminate in leaves, stored in an array. 15 | fracture :: Dataset -> Dataset 16 | fracture = map_d id -- TODO 17 | 18 | -- | Inverse of `fracture`. 19 | -- | `fracture >>> unfracture = id` 20 | unfracture :: Dataset -> Dataset 21 | unfracture = map_d id -- TODO 22 | 23 | -- | Replicates the next dimension of information. 24 | replicate :: Dataset -> Dataset 25 | replicate = map_d f 26 | where 27 | f (Map v) = (M.fromList >>> Map) ((\(Tuple k v) -> Tuple k k) <$> M.toList v) 28 | f (Array v0) = let v = zipWith Tuple (primInt <$> (0 .. (length v0 - 1))) v0 in (M.fromList >>> Map) ((\(Tuple i e) -> Tuple i i) <$> v) 29 | f v = Map (M.singleton v Undefined) 30 | 31 | -- | Pulls the domain out of the partial functions described by maps and arrays. 32 | domain :: Dataset -> Dataset 33 | domain = replicate >>> lshift_d 34 | 35 | -- | Forms a new dimension by transforming the values. 36 | -- | 37 | -- | This dimension is swapped with the last one in the dimensional stack, 38 | -- | so that the next reduction eliminates whatever was the last dimension 39 | -- | prior to the grouping operation. 40 | group :: (Data -> Data) -> Dataset -> Dataset 41 | group f = map_d (\d -> Map (M.singleton (f d) d)) >>> lshift_d >>> swap_d 0 1 42 | 43 | -- | Flattens arrays and maps, without increasing the dimensionality of the 44 | -- | dataset. 45 | flatten :: Dataset -> Dataset 46 | flatten = lshift_d >>> nest_d 47 | 48 | -- | Flattens arrays and maps, returning the values of the new dimension, and 49 | -- | without increasing the dimensionality of the datset. 50 | flatten_id :: Dataset -> Dataset 51 | flatten_id = domain >>> nest_d 52 | 53 | -- | Coerces to some type. 54 | coerce :: (Data -> Boolean) -> Dataset -> Dataset 55 | coerce f = map_d (\d -> if f d then d else Undefined) 56 | 57 | -- | Coerce to ints. 58 | coerce_ints :: Dataset -> Dataset 59 | coerce_ints = coerce (typeOf >>> eq (primString "int")) 60 | 61 | -- | Coerce to chars. 62 | coerce_chars :: Dataset -> Dataset 63 | coerce_chars = coerce (typeOf >>> eq (primString "char")) 64 | 65 | -- | Coerces to maps. :: 'Map 66 | coerce_maps :: Dataset -> Dataset 67 | coerce_maps = coerce (typeOf >>> eq (primString "map")) 68 | 69 | -- | Coerces to arrays. :: 'Array 70 | coerce_arrays :: Dataset -> Dataset 71 | coerce_arrays = coerce (typeOf >>> eq (primString "array")) 72 | 73 | -- | Zooms into and returns the keys of maps. {_:} 74 | map_zoom_keys :: Dataset -> Dataset 75 | map_zoom_keys = coerce_maps >>> domain 76 | 77 | -- | Zooms into and returns the values of maps. {_} / {:_} 78 | map_zoom_values :: Dataset -> Dataset 79 | map_zoom_values = coerce_maps >>> lshift_d 80 | 81 | -- | Zooms into and returns the indices of array elements. [_:] 82 | array_zoom_indices :: Dataset -> Dataset 83 | array_zoom_indices = coerce_arrays >>> domain 84 | 85 | -- | Zooms into and returns the values of array elements. [_] / [:_] 86 | array_zoom_values :: Dataset -> Dataset 87 | array_zoom_values = coerce_arrays >>> lshift_d 88 | 89 | -- | Flattens maps and returns the values. {*} / {:*} 90 | map_flatten_values :: Dataset -> Dataset 91 | map_flatten_values = coerce_maps >>> flatten 92 | 93 | -- | Flattens maps and returns the keys. {*:} 94 | map_flatten_keys :: Dataset -> Dataset 95 | map_flatten_keys = coerce_maps >>> flatten_id 96 | 97 | -- | Flattens arrays and returns the values. [*] / [:*] 98 | array_flatten_values :: Dataset -> Dataset 99 | array_flatten_values = coerce_arrays >>> flatten 100 | 101 | -- | Flattens arrays and returns the indices. [*:] 102 | array_flatten_indices :: Dataset -> Dataset 103 | array_flatten_indices = coerce_arrays >>> flatten_id 104 | 105 | -- | Projects a single statically known value. \foo\bar\baz\0\ 106 | static_project :: Data -> Dataset -> Dataset 107 | static_project = project_d 108 | 109 | -- | Projects dynamic keys from maps. foo{bar} 110 | dynamic_project_key :: Dataset -> Dataset -> Dataset 111 | dynamic_project_key = autojoin_d f 112 | where 113 | f k (Map m) = fromMaybe Undefined (M.lookup k m) 114 | f _ _ = Undefined 115 | 116 | -- | Projects dynamic indices from arrays. foo[bar] 117 | dynamic_project_index :: Dataset -> Dataset -> Dataset 118 | dynamic_project_index = autojoin_d f 119 | where 120 | f (Primitive (PrimInt idx)) (Array a) = fromMaybe Undefined (a !! idx) 121 | f _ _ = Undefined 122 | 123 | -- | Computes the type of a value, as a string. Note that the type of 124 | -- | `Undefined` is not defined (i.e. is `Undefined`). 125 | typeOf :: Data -> Data 126 | typeOf = f 127 | where 128 | f Undefined = Undefined 129 | f (Primitive (PrimNull )) = primString "null" 130 | f (Primitive (PrimChar _)) = primString "char" 131 | f (Primitive (PrimInt _)) = primString "int" 132 | f (Array _ ) = primString "array" 133 | f (Map _ ) = primString "map" 134 | 135 | -- | Count reduction. 136 | count :: Dataset -> Dataset 137 | count = reduce_d f (primInt 0) 138 | where 139 | f (Primitive (PrimInt v)) _ = primInt (v + 1) 140 | f ( _) _ = Undefined 141 | 142 | -- join :: (Data -> Data -> Data) -> (Data -> Data -> Boolean) -> Dataset -> Dataset -> Dataset 143 | -------------------------------------------------------------------------------- /src/MRA/Core.purs: -------------------------------------------------------------------------------- 1 | module MRA.Core 2 | ( Dataset() 3 | , autojoin_d 4 | , dimensionality 5 | , filter_d 6 | , identities 7 | , literal_d 8 | , lshift_d 9 | , map_d 10 | , nest_d 11 | , project_d 12 | , reduce_d 13 | , swap_d 14 | , values 15 | ) where 16 | 17 | import Prelude (class Ord, class Show, (>>=), (<$>), (>>>), (<<<), (<*>), (<>), ($), (-), (>), (<), bind, flip, id, pure, map, show) 18 | 19 | import Data.List (List(Nil, Cons), length, (..), zipWith, drop, take, (!!), filter, reverse, updateAt) 20 | import Data.OrdMap as M 21 | import Data.Set(Set(), fromFoldable) 22 | import Data.Maybe (Maybe(Just, Nothing), fromMaybe) 23 | import Data.Tuple (Tuple(Tuple)) 24 | import Data.Monoid(mempty) 25 | import Data.Accessor(Accessor(..), xmap, set, get) 26 | import Data.Foldable(foldl) 27 | 28 | import MRA.Provenance (Provenance(..), JoinKeys(..), joinKeys, makeBoth, makeThen, makeOneOfLeft, makeOneOfRight) 29 | import MRA.Data (Data(Map, Undefined, Array, Primitive), Primitive(PrimInt), emptyMap, primInt, fieldAccessor, isWhollyDefined) 30 | 31 | data Dataset = Dataset { dims :: List Provenance, values :: List Data } 32 | 33 | -- | Returns the static dimensionality of the dataset, AKA the length of the 34 | -- | dimensional stack. 35 | dimensionality :: Dataset -> Int 36 | dimensionality (Dataset r) = length r.dims 37 | 38 | -- | Applies a 1-to-1 value transformation over a dataset. 39 | map_d :: (Data -> Data) -> Dataset -> Dataset 40 | map_d f (Dataset r) = Dataset $ r { values = bimapIdentityValue id f r.values } 41 | 42 | -- | Filters a dataset based on a boolean predicate applied to the values. 43 | filter_d :: (Data -> Boolean) -> Dataset -> Dataset 44 | filter_d f (Dataset r) = Dataset $ r { values = filter (get _Value >>> f) r.values } 45 | 46 | -- | Projects a key / index from arrays and maps. 47 | project_d :: Data -> Dataset -> Dataset 48 | project_d d (Dataset r) = 49 | Dataset { values : bimapIdentityValue (extend makeThen d) f r.values, dims : extend Then (Proj d) r.dims } 50 | where 51 | f (Map v) = fromMaybe Undefined (M.lookup d v) 52 | f (Array v) = case d of 53 | (Primitive (PrimInt idx)) -> fromMaybe Undefined $ v !! idx 54 | _ -> Undefined 55 | f (_ ) = Undefined 56 | 57 | -- | Swaps two dimensions in the dimensional stack. The dimension with index 58 | -- | `0` is the dimension at the top / head of the stack, i.e. the *current* 59 | -- | dimension. 60 | swap_d :: Int -> Int -> Dataset -> Dataset 61 | swap_d n m (Dataset r) = 62 | Dataset { values : liftToIdentity (listSwap n m) <$> r.values, dims : listSwap n m r.dims } 63 | 64 | -- | Performs a left dimensional shift, peeling off a dimension from value 65 | -- | space and pushing it on as a new dimension of identity space. 66 | -- | 67 | -- | The new dimension is added to the head of the dimensional stack. 68 | lshift_d :: Dataset -> Dataset 69 | lshift_d (Dataset r) = 70 | Dataset { values : r.values >>= f, dims : Cons Value r.dims } 71 | where 72 | f v = 73 | let 74 | i = get _Identity v 75 | x = get _Value v 76 | in case x of 77 | Array l -> lshiftd1 i $ zipWith Tuple (primInt <$> (0 .. (length l - 1))) l 78 | Map m -> lshiftd1 i $ M.toList m 79 | _ -> Cons (makeIdentityValue (Cons x i) Undefined) Nil 80 | 81 | lshiftd1 :: List Data -> List (Tuple Data Data) -> List Data 82 | lshiftd1 i = map (\(Tuple i0 v) -> makeIdentityValue (Cons i0 i) v) 83 | 84 | -- | Nests the current dimension within the previous dimension. 85 | -- | AKA "squash1". 86 | nest_d :: Dataset -> Dataset 87 | nest_d (Dataset r) = 88 | Dataset { values : liftToIdentity (squash makeThen) <$> r.values, dims : (squash Then) r.dims } 89 | where 90 | squash :: forall a. (a -> a -> a) -> List a -> List a 91 | squash f (Cons x xs) = extend f x xs 92 | squash f Nil = Nil 93 | 94 | -- | Performs a cartesian cross product of the specified datasets, passing 95 | -- | each pair to the provided function to obtain a new value. 96 | -- | 97 | -- | The resulting dataset has dimensionality equal to the greater 98 | -- | dimensionality of the two input datasets. 99 | cross_d :: (Data -> Data -> Data) -> Dataset -> Dataset -> Dataset 100 | cross_d f (Dataset l) (Dataset r) = 101 | Dataset { values : do 102 | left <- l.values 103 | right <- r.values 104 | let i = zipBackwardsWithPadding makeBoth id id (get _Identity left) (get _Identity right) 105 | let x = f (get _Value left) (get _Value right) 106 | pure $ makeIdentityValue i x, dims : zipBackwardsWithPadding Both id id l.dims r.dims } 107 | 108 | -- | Performs a set union of the two datasets. 109 | union_d :: Dataset -> Dataset -> Dataset 110 | union_d (Dataset l) (Dataset r) = 111 | Dataset { 112 | values : bimapIdentityValue (map makeOneOfLeft) id l.values <> bimapIdentityValue (map makeOneOfRight) id r.values, 113 | dims : zipBackwardsWithPadding OneOf (\l -> OneOf l Nada) (\r -> OneOf Nada r) l.dims r.dims } 114 | 115 | type JoinMap = M.Map (Set Data) (List Data) 116 | 117 | -- | Performs an auto-join between two datasets, using the specified function 118 | -- | to combine the values. 119 | autojoin_d :: (Data -> Data -> Data) -> Dataset -> Dataset -> Dataset 120 | autojoin_d f (Dataset l) (Dataset r) = 121 | let 122 | allKeys :: List { left :: List Data -> Data, right :: List Data -> Data } 123 | allKeys = 124 | let 125 | zipped :: List JoinKeys 126 | zipped = zipWith joinKeys l.dims r.dims 127 | 128 | zipped' :: List (Tuple Int JoinKeys) 129 | zipped' = zipWith Tuple (0 .. (length zipped - 1)) zipped 130 | 131 | f :: Tuple Int JoinKeys -> List { left :: List Data -> Data, right :: List Data -> Data } 132 | f (Tuple idx (JoinKeys jk)) = (\k -> { left : get (_index idx) >>> k.left, 133 | right : get (_index idx) >>> k.right }) <$> jk 134 | in 135 | zipped' >>= f 136 | 137 | groupByJoinKeys :: List (List Data -> Data) -> List Data -> JoinMap 138 | groupByJoinKeys fs vs = groupBy f vs 139 | where 140 | f v = fromFoldable <<< filter isWhollyDefined $ fs <*> pure (get _Identity v) 141 | 142 | leftGrouped :: JoinMap 143 | leftGrouped = groupByJoinKeys (_.left <$> allKeys) l.values 144 | 145 | rightGrouped :: JoinMap 146 | rightGrouped = groupByJoinKeys (_.right <$> allKeys) r.values 147 | 148 | grouped :: List (Tuple (List Data) (List Data)) 149 | grouped = M.values (M.unionWith (\(Tuple l1 r1) (Tuple l2 r2) -> Tuple (l1 <> l2) (r1 <> r2)) 150 | (flip Tuple Nil <$> leftGrouped) (Tuple Nil <$> rightGrouped)) 151 | 152 | newDims :: List Provenance 153 | newDims = zipBackwardsWithPadding Both id id l.dims r.dims 154 | 155 | f' :: Data -> Data -> Data 156 | f' l r = 157 | let 158 | i = zipBackwardsWithPadding makeBoth id id (get _Identity l) (get _Identity r) 159 | x = f (get _Value l) (get _Value r) 160 | in 161 | makeIdentityValue i x 162 | 163 | joiner :: Tuple (List Data) (List Data) -> List Data 164 | joiner (Tuple (l @ Nil) (r @ Nil)) = pure (f' Undefined Undefined) 165 | joiner (Tuple (l @ Nil) (r )) = f' <$> (pure Undefined) <*> r 166 | joiner (Tuple (l ) (r @ Nil)) = f' <$> l <*> (pure Undefined) 167 | joiner (Tuple (l ) (r )) = f' <$> l <*> r 168 | 169 | newVals :: List Data 170 | newVals = reverse $ foldl (\l e -> l <> joiner e) Nil grouped 171 | in 172 | Dataset { dims : newDims, values : newVals } 173 | 174 | -- | Peels off the current dimension by reducing over all values that have the 175 | -- | same position in (n-1)th dimensional space. 176 | -- | 177 | -- | NOTE: This definition is currently broken, in the sense that it attempts 178 | -- | no normalization, so two points in the same (n-1th) location 179 | -- | may not fall in the same reduction bucket because the structural 180 | -- | representation of their location may be different. 181 | reduce_d :: (Data -> Data -> Data) -> Data -> Dataset -> Dataset 182 | reduce_d f z (Dataset r) = 183 | let 184 | reduce :: M.Map (List Data) (List Data) -> List Data 185 | reduce = M.toList >>> (map $ \(Tuple i vs) -> makeIdentityValue i (foldl (\z d -> f z (get _Value d)) z vs)) 186 | in 187 | Dataset { 188 | dims : drop 1 r.dims, 189 | values : reduce $ groupBy (\d -> drop 1 (get _Identity d)) r.values } 190 | 191 | -- | Lifts a literal value into a data set. This is the only possible way of 192 | -- | constructing a dataset. 193 | literal_d :: Data -> Dataset 194 | literal_d d = Dataset { dims : Nil, values : pure (makeIdentityValue Nil d) } 195 | 196 | values :: Dataset -> List Data 197 | values (Dataset r) = (get _Value) <$> r.values 198 | 199 | identities :: Dataset -> List (List Data) 200 | identities (Dataset r) = (get _Identity) <$> r.values 201 | 202 | -- | Values are stored in a "Value" fieldAccessor of a top-level map. 203 | _Value :: Accessor Data Data 204 | _Value = fieldAccessor "Value" 205 | 206 | -- | Identity is stored in a "Identity" fieldAccessor of a top-level map. 207 | -- | 208 | -- | The dimensions of identity are stored in a stack, here represented by 209 | -- | a list. 210 | _Identity :: Accessor Data (List Data) 211 | _Identity = xmap Array d (fieldAccessor "Identity") 212 | where 213 | d (Array v) = v 214 | d _ = Nil 215 | 216 | _index :: Int -> Accessor (List Data) Data 217 | _index idx = Accessor set get 218 | where 219 | set l e = fromMaybe Nil (updateAt idx e l) 220 | 221 | get l = fromMaybe Undefined (l !! idx) 222 | 223 | groupBy :: forall k v. (Ord k) => (v -> k) -> List v -> M.Map k (List v) 224 | groupBy f = foldl (flip \v -> M.alter (\old -> Just $ fromMaybe mempty old <> pure v) (f v)) M.empty 225 | 226 | zipBackwardsWithPadding :: forall a b c. (a -> b -> c) -> (a -> c) -> (b -> c) -> List a -> List b -> List c 227 | zipBackwardsWithPadding fab fa fb l r = zip0 (reverse l) (reverse r) 228 | where 229 | zip0 (Cons a as) (Nil ) = Cons (fa a) (zip0 as Nil) 230 | zip0 (Cons a as) (Cons b bs) = Cons (fab a b) (zip0 as bs) 231 | zip0 (Nil ) (Cons b bs) = Cons (fb b) (zip0 Nil bs) 232 | zip0 (Nil ) (Nil ) = Nil 233 | 234 | liftToValue :: (Data -> Data) -> (Data -> Data) 235 | liftToValue f = \d -> set _Value d (f (get _Value d)) 236 | 237 | liftToIdentity :: (List Data -> List Data) -> (Data -> Data) 238 | liftToIdentity f = \d -> set _Identity d (f (get _Identity d)) 239 | 240 | makeIdentityValue :: List Data -> Data -> Data 241 | makeIdentityValue i v = set _Value (set _Identity emptyMap i) v 242 | 243 | bimapIdentityValue :: (List Data -> List Data) -> (Data -> Data) -> List Data -> List Data 244 | bimapIdentityValue fi fv v = liftToIdentity fi >>> liftToValue fv <$> v 245 | 246 | extend :: forall a. (a -> a -> a) -> a -> List a -> List a 247 | extend f x0 (Cons x xs) = Cons (f x0 x) xs 248 | extend f x0 (Nil ) = Cons x0 Nil 249 | 250 | listSwap :: forall a. Int -> Int -> List a -> List a 251 | listSwap n m l = 252 | let 253 | n' = if n < m then n else m 254 | m' = if m > n then m else n 255 | 256 | list :: forall b. Maybe b -> List b 257 | list Nothing = Nil 258 | list (Just a) = Cons a Nil 259 | 260 | listIdx :: forall b. Int -> List b -> List b 261 | listIdx idx l = list $ l !! idx 262 | in 263 | (take n' l <> 264 | listIdx m' l <> 265 | take (m' - n' - 1) (drop n' l) <> 266 | listIdx n' l <> 267 | drop m' l) 268 | 269 | instance showDataset :: Show Dataset where 270 | show (Dataset r) = "Dataset { values : " <> show r.values <> ", dims : " <> show r.dims <> "}" 271 | -------------------------------------------------------------------------------- /src/MRA/Data.purs: -------------------------------------------------------------------------------- 1 | module MRA.Data where 2 | 3 | import Prelude (class Eq, class Ord, class Semigroup, class Show, Ordering(GT, LT, EQ), (==), (<$>), (>>>), (<<<), (<>), (<=), ($), (+), (-), compare, map, pure, show) 4 | 5 | import Data.Monoid (class Monoid) 6 | import Data.Accessor (Getter, Accessor(Accessor)) 7 | import Data.Maybe (Maybe(..), fromMaybe) 8 | import Data.Foldable(foldr, foldl) 9 | import Data.String(singleton, toCharArray) 10 | import Data.Tuple(Tuple(..), snd) 11 | 12 | import Data.OrdMap as M 13 | import Data.List as L 14 | 15 | data Primitive = PrimNull | PrimInt Int | PrimChar Char -- etc 16 | 17 | data Data = 18 | Undefined | -- Error!!! 19 | Primitive Primitive | 20 | Array (L.List Data) | 21 | Map (M.Map Data Data) 22 | 23 | type DataAccessor = Accessor Data Data 24 | 25 | type DataGetter = Getter Data Data 26 | 27 | isDefined :: Data -> Boolean 28 | isDefined Undefined = false 29 | isDefined _ = true 30 | 31 | isWhollyDefined :: Data -> Boolean 32 | isWhollyDefined = foldData f true 33 | where 34 | f b Undefined = false 35 | f b _ = b 36 | 37 | foldData :: forall z. (z -> Data -> z) -> z -> Data -> z 38 | foldData f = foldData0 39 | where 40 | foldData0 z (Array l) = foldl foldData0 z l 41 | foldData0 z (Map m) = foldl foldData0 (foldl foldData0 z (M.keys m)) (M.values m) 42 | foldData0 z v = f z v 43 | 44 | definedWith :: Data -> Data -> Data 45 | definedWith d1 d2 = if isDefined d1 then d1 else d2 46 | 47 | primInt :: Int -> Data 48 | primInt = Primitive <<< PrimInt 49 | 50 | primNull :: Data 51 | primNull = Primitive PrimNull 52 | 53 | primChar :: Char -> Data 54 | primChar = Primitive <<< PrimChar 55 | 56 | primString :: String -> Data 57 | primString = Array <<< foldr L.Cons L.Nil <<< map primChar <<< toCharArray 58 | 59 | makeMap :: Array (Tuple Data Data) -> Data 60 | makeMap = L.fromFoldable >>> M.fromList >>> Map 61 | 62 | spaces :: Int -> String 63 | spaces n = if n <= 0 then "" else " " <> spaces (n - 1) 64 | 65 | prettyArray :: Int -> Tuple Int String -> Data -> Tuple Int String 66 | prettyArray n (Tuple i z) v = Tuple (i + 1) (z <> if i == 0 then " " else ",\n" <> spaces n <> (pretty v (n + 2))) 67 | 68 | prettyMap :: Int -> Tuple Int String -> Tuple Data Data -> Tuple Int String 69 | prettyMap n (Tuple i z) (Tuple k v) = Tuple (i + 1) (z <> if i == 0 then " " else ",\n" <> spaces n <> pretty k (n + 2) <> " : " <> pretty v (n + 2)) 70 | 71 | pretty :: Data -> Int -> String 72 | pretty (Undefined ) _ = "undefined" 73 | pretty (Primitive (PrimNull )) _ = "null" 74 | pretty (Primitive (PrimInt v)) _ = show v 75 | pretty (Primitive (PrimChar v)) _ = "'" <> show v <> "'" 76 | pretty (Array v) n = "[" <> snd (foldl (prettyArray n) (Tuple 0 "") v) <> " ]" 77 | pretty (Map v) n = "{" <> snd (foldl (prettyMap n) (Tuple 0 "") (M.toList v)) <> " }" 78 | 79 | emptyMap :: Data 80 | emptyMap = Map M.empty 81 | 82 | fieldAccessor :: String -> Accessor Data Data 83 | fieldAccessor = primString >>> keyAccessor 84 | 85 | asString :: Data -> Maybe String 86 | asString d = 87 | case d of 88 | Array cs -> foldl (\s c -> s <> singleton c) "" <$> asString0 cs 89 | _ -> Nothing 90 | where 91 | asString0 :: L.List Data -> Maybe (L.List Char) 92 | asString0 (L.Cons (Primitive (PrimChar c)) cs) = L.Cons c <$> asString0 cs 93 | asString0 L.Nil = Just L.Nil 94 | asString0 _ = Nothing 95 | 96 | indexAccessor :: Int -> Accessor Data Data 97 | indexAccessor idx = Accessor set get 98 | where 99 | set (Array l) v = fromMaybe Undefined (Array <$> L.insertAt idx v l) 100 | set _ _ = Undefined 101 | 102 | get (Array l) = fromMaybe Undefined (l L.!! idx) 103 | get _ = Undefined 104 | 105 | keyAccessor :: Data -> Accessor Data Data 106 | keyAccessor k = Accessor set get 107 | where 108 | set (Map m) v = Map $ M.insert k v m 109 | set _ _ = Undefined 110 | 111 | get (Map m) = fromMaybe Undefined (M.lookup k m) 112 | get _ = Undefined 113 | 114 | instance eqPrimitive :: Eq Primitive where 115 | eq PrimNull PrimNull = true 116 | eq (PrimInt x) (PrimInt y) = x == y 117 | eq (PrimChar x) (PrimChar y) = x == y 118 | eq _ _ = false 119 | 120 | instance ordPrimitive :: Ord Primitive where 121 | compare PrimNull PrimNull = EQ 122 | compare PrimNull _ = LT 123 | compare (PrimInt x) (PrimInt y) = compare x y 124 | compare (PrimInt _) (PrimNull) = GT 125 | compare (PrimInt _) _ = LT 126 | compare (PrimChar x) (PrimChar y) = compare x y 127 | compare (PrimChar _) (PrimNull) = GT 128 | compare (PrimChar _) (PrimInt _) = GT 129 | 130 | instance eqData :: Eq Data where 131 | eq Undefined Undefined = true 132 | eq (Primitive x) (Primitive y) = x == y 133 | eq (Array x) (Array y) = x == y 134 | eq (Map x) (Map y) = x == y 135 | eq _ _ = false 136 | 137 | instance ordData :: Ord Data where 138 | compare Undefined Undefined = EQ 139 | compare Undefined _ = LT 140 | compare _ Undefined = GT 141 | compare (Primitive x) (Primitive y) = compare x y 142 | compare (Primitive _) _ = LT 143 | compare _ (Primitive _) = GT 144 | compare (Array x) (Array y) = compare x y 145 | compare (Array x) _ = LT 146 | compare _ (Array y) = GT 147 | compare (Map x) (Map y) = compare x y 148 | 149 | instance semigroupData :: Semigroup Data where 150 | append Undefined y = y 151 | append x Undefined = x 152 | append (Array x) (Array y) = Array $ x <> y 153 | append (Array x) y = Array $ x <> (pure y) 154 | append (x) (Array y) = Array $ (pure x) <> y 155 | append (x) (y) = Array $ (pure x) <> (pure y) 156 | 157 | instance monoidData :: Monoid Data where 158 | mempty = Undefined 159 | 160 | instance showData :: Show Data where 161 | show (Undefined ) = "Undefined" 162 | show (Primitive (PrimNull )) = "primNull" 163 | show (Primitive (PrimInt v)) = "(primInt " <> show v <> ")" 164 | show (Primitive (PrimChar v)) = "(primChar " <> show v <> ")" 165 | show (Array v) = fromMaybe ("(Array (" <> show v <> "))") ((\s -> "(primString " <> show s <> ")") <$> asString (Array v)) 166 | show (Map v) = "(Map (" <> show v <> "))" 167 | -------------------------------------------------------------------------------- /src/MRA/Provenance.purs: -------------------------------------------------------------------------------- 1 | module MRA.Provenance 2 | ( Provenance(..) 3 | , JoinKeys(..) 4 | , (\/) 5 | , (/\) 6 | , (>>) 7 | , _Both 8 | , _Left 9 | , _OneOf 10 | , _Right 11 | , _Then 12 | , both 13 | , joinKeys 14 | , makeBoth 15 | , makeOneOfLeft 16 | , makeOneOfRight 17 | , makeThen 18 | , oneOf 19 | , then0 20 | , unJoinKeys 21 | ) where 22 | 23 | import Prelude (class Eq, class Semigroup, class Show, (<$>), (==), (/=), map, (>>>), (<<<), (<>), (>), ($), bind, eq, id, pure, show, const, discard) 24 | 25 | import Data.List (List(Nil), length, take, filter, takeWhile, zipWith) 26 | import Data.Tuple (Tuple(Tuple), fst, snd) 27 | import Data.EqSet (toSet) 28 | import Data.Monoid(class Monoid, mempty) 29 | import Data.Profunctor.Strong(first) 30 | import Control.MonadPlus(guard) 31 | 32 | import Data.Accessor (get, set) 33 | import MRA.Data (DataGetter, Data, DataAccessor, fieldAccessor, emptyMap) 34 | 35 | data Provenance 36 | = Nada 37 | | Value 38 | | Proj Data 39 | | Both Provenance Provenance 40 | | OneOf Provenance Provenance 41 | | Then Provenance Provenance 42 | 43 | data JoinKeys = JoinKeys (List { left :: DataGetter, right :: DataGetter }) 44 | 45 | unJoinKeys :: JoinKeys -> (List { left :: DataGetter, right :: DataGetter }) 46 | unJoinKeys (JoinKeys jk) = jk 47 | 48 | oneOf :: Provenance -> Provenance -> Provenance 49 | oneOf = OneOf 50 | 51 | both :: Provenance -> Provenance -> Provenance 52 | both = Both 53 | 54 | then0 :: Provenance -> Provenance -> Provenance 55 | then0 = Then 56 | 57 | infix 6 oneOf as \/ 58 | infix 6 both as /\ 59 | infix 6 then0 as >> 60 | 61 | _Left :: DataAccessor 62 | _Left = fieldAccessor "Left" 63 | 64 | _Right :: DataAccessor 65 | _Right = fieldAccessor "Right" 66 | 67 | _Both :: DataAccessor 68 | _Both = fieldAccessor "Both" 69 | 70 | _Then :: DataAccessor 71 | _Then = fieldAccessor "Then" 72 | 73 | _OneOf :: DataAccessor 74 | _OneOf = fieldAccessor "OneOf" 75 | 76 | makeBoth :: Data -> Data -> Data 77 | makeBoth = makeTwo _Both 78 | 79 | makeThen :: Data -> Data -> Data 80 | makeThen = makeTwo _Then 81 | 82 | makeOneOfLeft :: Data -> Data 83 | makeOneOfLeft v = set _OneOf emptyMap (set _Left emptyMap v) 84 | 85 | makeOneOfRight :: Data -> Data 86 | makeOneOfRight v = set _OneOf emptyMap (set _Right emptyMap v) 87 | 88 | makeTwo :: DataAccessor -> Data -> Data -> Data 89 | makeTwo d l r = set d emptyMap (set _Left (set _Right emptyMap r) l) 90 | 91 | valueJoin :: JoinKeys 92 | valueJoin = JoinKeys (pure { left : id :: DataGetter, right : id :: DataGetter }) 93 | 94 | joinKeys :: Provenance -> Provenance -> JoinKeys 95 | joinKeys (Nada ) r = mempty 96 | joinKeys l (Nada ) = mempty 97 | joinKeys (Value ) (Value ) = valueJoin 98 | joinKeys (Proj d1) (Proj d2) = if d1 == d2 then valueJoin else mempty 99 | joinKeys (Value ) (Proj d2) = JoinKeys (pure { left : id :: DataGetter, right : const d2 }) 100 | joinKeys (Proj d1) (Value ) = JoinKeys (pure { left : const d1, right : id :: DataGetter }) 101 | joinKeys l @ (Both _ _) r = joinBoths l r 102 | joinKeys l r @ (Both _ _) = joinBoths l r 103 | joinKeys l @ (OneOf _ _) r = joinOneOfs l r 104 | joinKeys l r @ (OneOf _ _) = joinOneOfs l r 105 | joinKeys l @ (Then _ _) r = joinThens l r 106 | joinKeys l r @ (Then _ _) = joinThens l r 107 | 108 | joinBoths :: Provenance -> Provenance -> JoinKeys 109 | joinBoths l r = JoinKeys do 110 | lefts <- flattenBoth l 111 | rights <- flattenBoth r 112 | left <- lefts 113 | right <- rights 114 | guard (snd left == snd right) 115 | key <- unJoinKeys $ joinKeys (snd left) (snd right) 116 | pure { left : fst left >>> key.left, right : fst right >>> key.right } 117 | 118 | joinOneOfs :: Provenance -> Provenance -> JoinKeys 119 | joinOneOfs l r = JoinKeys do 120 | left <- flattenOneOf l 121 | right <- flattenOneOf r 122 | guard (snd left == snd right) 123 | key <- unJoinKeys $ joinKeys (snd left) (snd right) 124 | pure { left : fst left >>> key.left, right : fst right >>> key.right } 125 | 126 | joinThens :: Provenance -> Provenance -> JoinKeys 127 | joinThens l r = JoinKeys do 128 | lefts <- flattenThen l 129 | rights <- flattenThen r 130 | let n = longestPrefix (snd <$> lefts) (snd <$> rights) 131 | guard (n > 0) 132 | let boths = zipWith Tuple ((take n) lefts) ((take n) rights) 133 | Tuple left right <- boths 134 | key <- unJoinKeys $ joinKeys (snd left) (snd right) 135 | pure { left : fst left >>> key.left, right : fst right >>> key.right } 136 | where 137 | longestPrefix :: forall a. (Eq a) => List a -> List a -> Int 138 | longestPrefix l' r' = length <<< takeWhile id $ zipWith eq l' r' 139 | 140 | type Alternatives a = List a 141 | 142 | type Flattening = Alternatives (List (Tuple DataGetter Provenance)) 143 | 144 | nest0 :: DataGetter -> List (Tuple DataGetter Provenance) -> List (Tuple DataGetter Provenance) 145 | nest0 root v = first ((>>>) root) <$> v 146 | 147 | nest :: DataGetter -> Flattening -> Flattening 148 | nest root alts = nest0 root <$> alts 149 | 150 | -- | Flattens products, correctly handling the distributivity of sums. 151 | -- | The result is a sum (Alternatives) of the flattened terms in the product. 152 | flattenBoth :: Provenance -> Alternatives (List (Tuple DataGetter Provenance)) 153 | flattenBoth (Both l r) = 154 | do 155 | l' <- flattenBoth l 156 | r' <- flattenBoth r 157 | pure $ nest0 (get _Both >>> get _Left) l' <> nest0 (get _Both >>> get _Right) r' 158 | flattenBoth (OneOf l r) = nest (get _OneOf >>> get _Left) (flattenBoth l) <> nest (get _OneOf >>> get _Right) (flattenBoth r) 159 | flattenBoth v = pure (pure (Tuple id v)) 160 | 161 | -- | Flattens sequences, correctly handling the distributivity of sums. 162 | -- | The result is a sum (Alternatives) of the flattened terms in the sequence. 163 | flattenThen :: Provenance -> Alternatives (List (Tuple DataGetter Provenance)) 164 | flattenThen (Then l r) = do 165 | l' <- flattenThen l 166 | r' <- flattenThen r 167 | pure $ nest0 (get _Then >>> get _Left) l' <> nest0 (get _Then >>> get _Right) r' 168 | flattenThen (OneOf l r) = nest (get _OneOf >>> get _Left) (flattenThen l) <> nest (get _OneOf >>> get _Right) (flattenThen r) 169 | flattenThen v = pure (pure (Tuple id v)) 170 | 171 | -- | Flattens sums, correctly handling the distributivity of sums. 172 | -- | The result is a sum (Alternatives) of the flattened terms. 173 | flattenOneOf :: Provenance -> Alternatives (Tuple DataGetter Provenance) 174 | flattenOneOf (Both l r) = nest0 (get _Both >>> get _Left) (flattenOneOf l) <> nest0 (get _Both >>> get _Right) (flattenOneOf r) 175 | flattenOneOf (Then l r) = nest0 (get _Then >>> get _Left) (flattenOneOf l) <> nest0 (get _Then >>> get _Right) (flattenOneOf r) 176 | flattenOneOf (OneOf l r) = nest0 (get _OneOf >>> get _Left) (flattenOneOf l) <> nest0 (get _OneOf >>> get _Right) (flattenOneOf r) 177 | flattenOneOf v = pure (Tuple id v) 178 | 179 | nubNadas :: List Provenance -> List Provenance 180 | nubNadas = filter ((/=) Nada) 181 | 182 | instance semigroupJoinKeys :: Semigroup JoinKeys where 183 | append (JoinKeys l) (JoinKeys r) = 184 | JoinKeys (l <> r) 185 | 186 | instance monoidJoinKeys :: Monoid JoinKeys where 187 | mempty = JoinKeys Nil 188 | 189 | instance eqProvenance :: Eq Provenance where 190 | eq (Nada ) (Nada ) = true 191 | eq (Value ) (Value ) = true 192 | eq (Proj l) (Proj r) = l == r 193 | eq l @ (Both _ _) r = bothEq l r 194 | eq l r @ (Both _ _) = bothEq l r 195 | eq l @ (OneOf _ _) r = oneOfEq l r 196 | eq l r @ (OneOf _ _) = oneOfEq l r 197 | eq l @ (Then _ _) r = thenEq l r 198 | eq l r @ (Then _ _) = thenEq l r 199 | eq _ _ = false 200 | 201 | instance showProvenance :: Show Provenance where 202 | show (Nada ) = "Nada" 203 | show (Value ) = "Value" 204 | show (Proj v ) = "(Proj " <> show v <> ")" 205 | show (Both l r) = "(" <> show l <> ") /\\ (" <> show r <> ")" 206 | show (OneOf l r) = "(" <> show l <> ") \\/ (" <> show r <> ")" 207 | show (Then l r) = "(" <> show l <> ") >> (" <> show r <> ")" 208 | 209 | thenEq :: Provenance -> Provenance -> Boolean 210 | thenEq l r = toSet (map snd <$> flattenThen l) == toSet (map snd <$> flattenThen r) 211 | 212 | bothEq :: Provenance -> Provenance -> Boolean 213 | bothEq l r = toSet (map snd >>> nubNadas >>> toSet <$> flattenBoth l) == toSet (map snd >>> nubNadas >>> toSet <$> flattenBoth r) 214 | 215 | oneOfEq :: Provenance -> Provenance -> Boolean 216 | oneOfEq l r = toSet (nubNadas (snd <$> flattenOneOf l)) == toSet (nubNadas (snd <$> flattenOneOf r)) 217 | -------------------------------------------------------------------------------- /test/Test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | import Prelude(Unit, class Show, class Eq, ($), (==), (/=), (<>), const, pure, show, discard) 3 | 4 | import Data.Tuple(Tuple(..)) 5 | 6 | import Data.Foldable(foldl) 7 | import Data.List as L 8 | 9 | import Control.Monad.Eff(Eff) 10 | import Control.Monad.Eff.Console(CONSOLE, log) 11 | 12 | import MRA.Provenance(Provenance(..), (/\), (\/), (>>)) 13 | import MRA.Data(Data(), makeMap, primString, primInt) 14 | import MRA.Core(Dataset(), dimensionality, literal_d, lshift_d, map_d, project_d, values) 15 | import MRA.Combinators(count, map_flatten_values, domain) 16 | 17 | type TestResult = forall r. Eff (console :: CONSOLE | r) Unit 18 | 19 | assertEqual :: forall a r. Show a => Eq a => a -> a -> Eff (console :: CONSOLE | r) Unit 20 | assertEqual l r = 21 | if l == r then log $ "Pass: " <> show l <> " == " <> show r 22 | else log $ "FAIL: Expected " <> show l <> " but found " <> show r 23 | 24 | assertNotEqual :: forall a r. Show a => Eq a => a -> a -> Eff (console :: CONSOLE | r) Unit 25 | assertNotEqual l r = 26 | if l /= r then log $ "Pass: " <> show l <> " /= " <> show r 27 | else log $ "FAIL: " <> show l <> " == " <> show r 28 | 29 | toArray :: forall a. L.List a -> Array a 30 | toArray = foldl (\as a -> as <> pure a) [] 31 | 32 | assertValues :: Array Data -> Dataset -> TestResult 33 | assertValues a d = assertEqual a (toArray $ values d) 34 | 35 | entuple :: forall a b. a -> b -> Tuple a b 36 | entuple = Tuple 37 | 38 | infix 6 entuple as ~ 39 | 40 | universe :: Dataset 41 | universe = literal_d $ makeMap [ 42 | primString "olympics" ~ makeMap [ 43 | primInt 1 ~ makeMap [primString "year" ~ primInt 1924, primString "city" ~ primString "Boulder", primString "sport" ~ primString "Skating", primString "country" ~ primString "USA" ], 44 | primInt 2 ~ makeMap [primString "year" ~ primInt 1926, primString "city" ~ primString "Boulder", primString "sport" ~ primString "Bodybuilding", primString "country" ~ primString "USA"], 45 | primInt 3 ~ makeMap [primString "year" ~ primInt 1928, primString "city" ~ primString "Billings", primString "sport" ~ primString "Skating", primString "country" ~ primString "USA", primString "gender" ~ primString "M"] 46 | ] ] 47 | 48 | olympics :: Dataset 49 | olympics = map_flatten_values $ project_d (primString "olympics") universe 50 | 51 | test_project_d :: TestResult 52 | test_project_d = do 53 | assertValues [primInt 1924, primInt 1926, primInt 1928] (project_d (primString "year") olympics) 54 | assertValues [primString "Boulder", primString "Boulder", primString "Billings"] (project_d (primString "city") olympics) 55 | 56 | test_map_d :: TestResult 57 | test_map_d = do 58 | assertValues [primInt 1, primInt 1, primInt 1] (map_d (const $ primInt 1) olympics) 59 | 60 | test_dimensionality :: TestResult 61 | test_dimensionality = do 62 | assertEqual 1 (dimensionality olympics) 63 | assertEqual 2 (dimensionality $ lshift_d olympics) 64 | 65 | test_domain :: TestResult 66 | test_domain = do 67 | assertValues [primInt 1, primInt 2, primInt 3] (domain $ project_d (primString "olympics") universe) 68 | 69 | test_provenance :: TestResult 70 | test_provenance = 71 | let 72 | projPrimInt4 = Proj (primInt 4) 73 | projPrimInt3 = Proj (primInt 3) 74 | projPrimInt2 = Proj (primInt 2) 75 | in do 76 | assertEqual (Value /\ Value) Value 77 | assertEqual Value (Value \/ Value) 78 | 79 | assertEqual (Nada \/ Value) Value 80 | assertEqual Value (Nada \/ Value) 81 | 82 | -- primitive equality 83 | assertEqual projPrimInt4 projPrimInt4 84 | assertNotEqual projPrimInt4 projPrimInt3 85 | 86 | -- associativity of sums 87 | assertEqual (projPrimInt4 \/ projPrimInt3) (projPrimInt3 \/ projPrimInt4) 88 | 89 | -- associativity of products 90 | assertEqual (projPrimInt4 /\ projPrimInt3) (projPrimInt3 /\ projPrimInt4) 91 | 92 | -- non-associativity of seqs 93 | assertNotEqual (projPrimInt4 >> projPrimInt3) (projPrimInt3 >> projPrimInt4) 94 | 95 | -- distributivity of sums through products 96 | assertEqual (projPrimInt4 /\ (projPrimInt3 \/ projPrimInt2)) ((projPrimInt4 /\ projPrimInt3) \/ (projPrimInt4 /\ projPrimInt2)) 97 | 98 | -- distributivity of sums through seqs 99 | assertEqual (projPrimInt4 >> (projPrimInt3 \/ projPrimInt2)) (projPrimInt4 >> projPrimInt3 \/ projPrimInt4 >> projPrimInt2) 100 | 101 | test_join_keys 102 | 103 | test_join_keys :: TestResult 104 | test_join_keys = do 105 | log "Testing join keys" 106 | 107 | test_reduce_d :: TestResult 108 | test_reduce_d = do 109 | assertValues [primInt 3] (count olympics) 110 | 111 | test_mra_core :: TestResult 112 | test_mra_core = do 113 | log "Testing MRA core" 114 | test_dimensionality 115 | 116 | test_project_d 117 | test_map_d 118 | test_reduce_d 119 | 120 | test_mra_combinators :: TestResult 121 | test_mra_combinators = do 122 | log "Testing MRA combinators" 123 | test_domain 124 | 125 | test_data :: TestResult 126 | test_data = do 127 | log "Testing Data" 128 | test_domain 129 | 130 | main :: forall r. Eff (console :: CONSOLE | r) Unit 131 | main = do 132 | test_data 133 | 134 | test_provenance 135 | 136 | test_mra_core 137 | 138 | test_mra_combinators 139 | --------------------------------------------------------------------------------