From 4d5b5484b71fae08b1c359ba43ae30839169af2b Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Thu, 2 Mar 2017 18:25:36 +0300 Subject: [PATCH 01/19] constructors --- src/Main.purs | 9 ----- src/SqlSquare/AST.purs | 91 +++++++++++++++++++++++------------------- 2 files changed, 51 insertions(+), 49 deletions(-) delete mode 100644 src/Main.purs diff --git a/src/Main.purs b/src/Main.purs deleted file mode 100644 index abe68ec..0000000 --- a/src/Main.purs +++ /dev/null @@ -1,9 +0,0 @@ -module Main where - -import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) - -main :: forall e. Eff (console :: CONSOLE | e) Unit -main = do - log "Hello sailor!" diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index 2c3c49d..2b8551f 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -5,13 +5,14 @@ import Prelude import Data.Bifunctor (bimap) import Data.Either (Either, either) import Data.Foldable as F +import Data.Functor.Mu (Mu) import Data.Maybe (Maybe(..)) import Data.List (List, fromFoldable) import Data.NonEmpty as NE import Data.Tuple (Tuple(..)) import Data.Path.Pathy (AbsFile, RelFile, Unsandboxed, unsafePrintPath) -import Matryoshka (class Recursive, class Corecursive, Algebra, cata, embed, Mu) +import Matryoshka (class Recursive, class Corecursive, Algebra, cata, embed) infixr 4 type Tuple as × infixr 1 Tuple as × @@ -114,7 +115,7 @@ newtype OrderBy a = OrderBy (NE.NonEmpty List (OrderType × a)) printOrderBy ∷ Algebra OrderBy String printOrderBy (OrderBy lst) = - F.intercalate ", " $ lst <#> \(ot × a) → printOrderType ot <> a + F.intercalate ", " $ lst <#> \(ot × a) → printOrderType ot <> " " <> a derive instance functorOrderBy ∷ Functor OrderBy @@ -363,8 +364,8 @@ printF = case _ of Vari s → ":" <> s Select { isDistinct, projections, relations, filter, groupBy, orderBy } → - "select" - <> (if isDistinct then " distinct " else "") + "select " + <> (if isDistinct then "distinct " else "") <> (F.intercalate ", " $ map printProjection projections) <> (relations # F.foldMap \rs → " from " <> printRelation rs) @@ -379,48 +380,51 @@ print ∷ ∀ t. Recursive t SqlF ⇒ t → String print = cata printF -- | constructors -vari ∷ ∀ t. Corecursive t SqlF ⇒ String → t -vari s = embed $ Vari s +vari_ ∷ ∀ t. Corecursive t SqlF ⇒ String → t +vari_ s = embed $ Vari s -bool ∷ ∀ t. Corecursive t SqlF ⇒ Boolean → t -bool b = embed $ BoolLiteral b +bool_ ∷ ∀ t. Corecursive t SqlF ⇒ Boolean → t +bool_ b = embed $ BoolLiteral b -null ∷ ∀ t. Corecursive t SqlF ⇒ t -null = embed NullLiteral +null_ ∷ ∀ t. Corecursive t SqlF ⇒ t +null_ = embed NullLiteral -int ∷ ∀ t. Corecursive t SqlF ⇒ Int → t -int i = embed $ IntLiteral i +int_ ∷ ∀ t. Corecursive t SqlF ⇒ Int → t +int_ i = embed $ IntLiteral i -num ∷ ∀ t. Corecursive t SqlF ⇒ Number → t -num i = embed $ FloatLiteral i +num_ ∷ ∀ t. Corecursive t SqlF ⇒ Number → t +num_ i = embed $ FloatLiteral i -unop ∷ ∀ t. Corecursive t SqlF ⇒ UnaryOperator → t → t -unop op expr = embed $ Unop { op, expr } +unop_ ∷ ∀ t. Corecursive t SqlF ⇒ UnaryOperator → t → t +unop_ op expr = embed $ Unop { op, expr } -binop ∷ ∀ t. Corecursive t SqlF ⇒ BinaryOperator → t → t → t -binop op lhs rhs = embed $ Binop { op, lhs, rhs } +binop_ ∷ ∀ t. Corecursive t SqlF ⇒ BinaryOperator → t → t → t +binop_ op lhs rhs = embed $ Binop { op, lhs, rhs } -set ∷ ∀ t. (Corecursive t SqlF, F.Foldable f) ⇒ f t → t -set l = embed $ SetLiteral $ fromFoldable f +set_ ∷ ∀ t f. (Corecursive t SqlF, F.Foldable f) ⇒ f t → t +set_ l = embed $ SetLiteral $ fromFoldable l -array ∷ ∀ t. (Corecursive t SqlF, F.Foldable f) ⇒ f t → t -array l = embed $ ArrayLiteral $ fromFoldable l +array_ ∷ ∀ t f. (Corecursive t SqlF, F.Foldable f) ⇒ f t → t +array_ l = embed $ ArrayLiteral $ fromFoldable l -splice ∷ ∀ t. Corecursive t SqlF ⇒ Maybe t → t -splice m = embed $ Splice m +splice_ ∷ ∀ t. Corecursive t SqlF ⇒ Maybe t → t +splice_ m = embed $ Splice m -ident ∷ ∀ t. Corecursive t SqlF ⇒ String → t -ident i = embed $ Ident i +ident_ ∷ ∀ t. Corecursive t SqlF ⇒ String → t +ident_ i = embed $ Ident i -match ∷ ∀ t. Corecursive t SqlF ⇒ t → List (Case t) → Maybe t → t -match expr cases default_ = embed $ Match { expr, cases, default_ } +match_ ∷ ∀ t. Corecursive t SqlF ⇒ t → List (Case t) → Maybe t → t +match_ expr cases default_ = embed $ Match { expr, cases, default_ } -switch ∷ ∀ t. Corecursive t SqlF ⇒ List (Case t) → Maybe t → t -switch cases default_ = embed $ Switch { cases, default_ } +switch_ ∷ ∀ t. Corecursive t SqlF ⇒ List (Case t) → Maybe t → t +switch_ cases default_ = embed $ Switch { cases, default_ } let_ ∷ ∀ t. Corecursive t SqlF ⇒ String → t → t → t let_ ident bindTo in_ = embed $ Let { ident, bindTo, in_ } +invokeFunction_ ∷ ∀ t. Corecursive t SqlF ⇒ String → List t → t +invokeFunction_ name args = embed $ InvokeFunction {name, args} + -- when_ (bool true) # then_ (num 1.0) :P when_ ∷ ∀ t. t → (t → Case t) when_ cond = Case <<< { cond, expr: _ } @@ -428,17 +432,24 @@ when_ cond = Case <<< { cond, expr: _ } then_ ∷ ∀ t. (t → Case t) → t → Case t then_ f t = f t -select - ∷ ∀ t - . Corecursive t SqlF +select_ + ∷ ∀ t f + . (Corecursive t SqlF, F.Foldable f) ⇒ Boolean - → List (Projection t) + → f (Projection t) → Maybe (SqlRelation t) - → Maybe a - → Maybe (GroupBy a) - → Maybe (OrderBy a) -select isDistinct projections relations filter groupBy orderBy = - embed $ Select { isDistinct, projections, relations, filter, groupBy, orderBy } + → Maybe t + → Maybe (GroupBy t) + → Maybe (OrderBy t) + → t +select_ isDistinct projections relations filter groupBy orderBy = + embed $ Select { isDistinct + , projections: fromFoldable projections + , relations + , filter + , groupBy + , orderBy + } -- project_ (ident "foo") # as_ "bar" @@ -449,7 +460,7 @@ project_ expr = Projection {expr, alias: Nothing} as_ ∷ ∀ t. String → Projection t → Projection t as_ s (Projection r) = Projection r { alias = Just s } -groupBy_ ∷ ∀ t f. Foldable f ⇒ f t → GroupBy t +groupBy_ ∷ ∀ t f. F.Foldable f ⇒ f t → GroupBy t groupBy_ f = GroupBy { keys: fromFoldable f, having: Nothing } having_ ∷ ∀ t. t → GroupBy t → GroupBy t From dabcbab719d4c66511af90b4e0082060ef59d090 Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Thu, 2 Mar 2017 23:07:14 +0300 Subject: [PATCH 02/19] wip --- bower.json | 4 ++- package.json | 18 ++++++---- src/SqlSquare/AST.purs | 75 ++++++++++++++++++++++++++++++++++++++---- test/src/Main.purs | 34 ++++++++++++------- 4 files changed, 106 insertions(+), 25 deletions(-) diff --git a/bower.json b/bower.json index 2aba6c5..a420ae0 100644 --- a/bower.json +++ b/bower.json @@ -10,6 +10,8 @@ "purescript-prelude": "^2.4.0", "purescript-matryoshka": "^0.1.1", "purescript-pathy": "^3.0.2", - "purescript-debug": "^2.0.0" + "purescript-debug": "^2.0.0", + "purescript-profunctor": "^2.0.0", + "purescript-profunctor-lenses": "^2.6.0" } } diff --git a/package.json b/package.json index 40750d5..7f6c3b1 100644 --- a/package.json +++ b/package.json @@ -1,9 +1,13 @@ { - "name": "purescript-sqlsquare", - "license": "Apache-2.0", - "dependencies": { - "pulp": "^10.0.1", - "purescript": "^0.10.7", - "purescript-psa": "^0.4.0" - } + "name": "purescript-sqlsquare", + "license": "Apache-2.0", + "scripts": { + "build": "pulp build -- --censor-lib --strict --stash", + "test": "pulp test -- --censor-lib --strict --stash" + }, + "dependencies": { + "pulp": "^10.0.1", + "purescript": "^0.10.7", + "purescript-psa": "^0.4.0" + } } diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index 2b8551f..82ae947 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -8,9 +8,11 @@ import Data.Foldable as F import Data.Functor.Mu (Mu) import Data.Maybe (Maybe(..)) import Data.List (List, fromFoldable) +import Data.Newtype (class Newtype, wrap, unwrap) import Data.NonEmpty as NE import Data.Tuple (Tuple(..)) import Data.Path.Pathy (AbsFile, RelFile, Unsandboxed, unsafePrintPath) +import Data.Lens (Lens', lens, Iso', iso) import Matryoshka (class Recursive, class Corecursive, Algebra, cata, embed) @@ -97,34 +99,95 @@ data UnaryOperator derive instance eqUnaryOperator ∷ Eq UnaryOperator newtype GroupBy a = GroupBy { keys ∷ List a, having ∷ Maybe a } +derive instance newtypeGroupBy ∷ Newtype (GroupBy a) _ +derive instance functorGroupBy ∷ Functor GroupBy + +_keys ∷ ∀ a nt r. Newtype nt { keys ∷ a | r } ⇒ Lens' nt a +_keys = lens get set + where + get ∷ nt → a + get = unwrap >>> _.keys + + set ∷ nt → a → nt + set nt a = + wrap $ _{ keys = a } $ unwrap nt + +_having ∷ ∀ a nt r. Newtype nt { having ∷ a |r} ⇒ Lens' nt a +_having = lens get set + where + get ∷ nt → a + get = unwrap >>> _.having + + set ∷ nt → a → nt + set nt a = + wrap $ _{ having = a } $ unwrap nt printGroupBy ∷ Algebra GroupBy String printGroupBy (GroupBy { keys, having }) = F.intercalate ", " keys <> F.foldMap (" having " <> _) having -derive instance functorGroupBy ∷ Functor GroupBy newtype Case a = Case { cond ∷ a, expr ∷ a } +derive instance functorCase ∷ Functor Case +derive instance newtypeCase ∷ Newtype (Case a) _ + +_cond ∷ ∀ a nt r. Newtype nt { cond ∷ a |r } ⇒ Lens' nt a +_cond = lens get set + where + get ∷ nt → a + get = unwrap >>> _.cond + + set ∷ nt → a → nt + set nt a = + wrap $ _{ cond = a } $ unwrap nt + + +_expr ∷ ∀ a nt r. Newtype nt { expr ∷ a|r} ⇒ Lens' nt a +_expr = lens get set + where + get ∷ nt → a + get = unwrap >>> _.expr + + set ∷ nt → a → nt + set nt a = + wrap $ _{ expr = a } $ unwrap nt + + printCase ∷ Algebra Case String printCase (Case { cond, expr }) = " when " <> cond <> " then " <> expr -derive instance functorCase ∷ Functor Case - newtype OrderBy a = OrderBy (NE.NonEmpty List (OrderType × a)) +_orderBy ∷ ∀ a. Iso' (OrderBy a) (NE.NonEmpty List (OrderType × a)) +_orderBy = iso unwrap wrap + +derive instance functorOrderBy ∷ Functor OrderBy +derive instance newtypeOrderBy ∷ Newtype (OrderBy a) _ + printOrderBy ∷ Algebra OrderBy String printOrderBy (OrderBy lst) = F.intercalate ", " $ lst <#> \(ot × a) → printOrderType ot <> " " <> a -derive instance functorOrderBy ∷ Functor OrderBy - newtype Projection a = Projection { expr ∷ a, alias ∷ Maybe String } +derive instance functorProjection ∷ Functor Projection +derive instance newtypeProjection ∷ Newtype (Projection a) _ + + +_alias ∷ ∀ a nt r. Newtype nt { alias ∷ a|r} ⇒ Lens' nt a +_alias = lens get set + where + get ∷ nt → a + get = unwrap >>> _.alias + + set ∷ nt → a → nt + set nt a = + wrap $ _{ alias = a } $ unwrap nt + printProjection ∷ Algebra Projection String printProjection (Projection { expr, alias }) = expr <> F.foldMap (" as " <> _) alias -derive instance functorProjection ∷ Functor Projection data SqlRelation a = JoinRelation diff --git a/test/src/Main.purs b/test/src/Main.purs index 656964c..14a3f30 100644 --- a/test/src/Main.purs +++ b/test/src/Main.purs @@ -3,22 +3,34 @@ module Test.Main where import Prelude import Control.Monad.Eff (Eff) -import Data.List (List) -import Data.Functor.Mu (Mu) +import Data.Either (Either(..)) +import Data.Maybe (Maybe(..)) +import Data.NonEmpty as NE +import Data.Path.Pathy as Pt import Debug.Trace (traceAnyA) +import Data.Tuple (Tuple(..)) import SqlSquare.AST as S -import Matryoshka (class Corecursive, embed, cata) -num ∷ ∀ t. Corecursive t S.AST ⇒ Number → t -num n = embed (S.FloatLiteral n) +someExpr ∷ S.Sql +someExpr = S.invokeFunction_ "foo" $ pure $ S.num_ 12.0 -invokeFunction ∷ ∀ t. Corecursive t S.AST ⇒ String → List t → t -invokeFunction name args = embed (S.InvokeFunction { name, args }) +otherExpr ∷ S.Sql +otherExpr = + S.select_ + false + [ S.project_ (S.ident_ "foo") # S.as_ "field" + , S.project_ $ S.splice_ $ Just $ S.binop_ S.FieldDeref (S.ident_ "bar") (S.ident_ "baz") + ] + ( map + (S.TableRelationAST <<< { alias: Nothing, tablePath: _ } <<< Right) + $ Pt.parseAbsFile "/mongo/testDb/patients" ) + ( Just $ S.binop_ S.Eq (S.ident_ "quux") (S.num_ 12.0) ) + ( Just $ S.groupBy_ [ S.ident_ "zzz" ] # S.having_ ( S.binop_ S.Gt (S.ident_ "ooo") ( S.int_ 2)) ) + ( Just $ S.OrderBy $ NE.singleton $ Tuple S.ASC (S.ident_ "zzz") ) -someExpr ∷ ∀ t. Corecursive t S.AST ⇒ t -someExpr = invokeFunction "foo" $ pure $ num 12.0 main ∷ ∀ e. Eff e Unit main = do - traceAnyA (someExpr ∷ Mu S.AST) - traceAnyA $ cata S.print (someExpr ∷ Mu S.AST) + traceAnyA someExpr + traceAnyA $ S.print someExpr + traceAnyA $ S.print otherExpr From d54e4a8dfbc12f1bbfb4c0a9083a5896d10a9e4f Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Fri, 3 Mar 2017 16:46:01 +0300 Subject: [PATCH 03/19] lenses --- src/SqlSquare/AST.purs | 435 +++++++++++++++++++++++++++++------------ 1 file changed, 312 insertions(+), 123 deletions(-) diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index 82ae947..3ced142 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -12,12 +12,18 @@ import Data.Newtype (class Newtype, wrap, unwrap) import Data.NonEmpty as NE import Data.Tuple (Tuple(..)) import Data.Path.Pathy (AbsFile, RelFile, Unsandboxed, unsafePrintPath) -import Data.Lens (Lens', lens, Iso', iso) +import Data.Lens (Prism', prism', Lens', lens, Iso', iso) -import Matryoshka (class Recursive, class Corecursive, Algebra, cata, embed) +import Matryoshka (class Recursive, class Corecursive, Algebra, cata, embed, project) infixr 4 type Tuple as × infixr 1 Tuple as × +infixr 9 compose as ∘ + +composeFlipped ∷ ∀ a b c d. Semigroupoid a ⇒ a b c → a c d → a b d +composeFlipped f g = compose g f + +infixr 9 composeFlipped as ⋙ type FUPath = Either (RelFile Unsandboxed) (AbsFile Unsandboxed) @@ -98,29 +104,15 @@ data UnaryOperator derive instance eqUnaryOperator ∷ Eq UnaryOperator +_Newtype ∷ ∀ n t. Newtype n t ⇒ Iso' n t +_Newtype = iso unwrap wrap + newtype GroupBy a = GroupBy { keys ∷ List a, having ∷ Maybe a } derive instance newtypeGroupBy ∷ Newtype (GroupBy a) _ derive instance functorGroupBy ∷ Functor GroupBy -_keys ∷ ∀ a nt r. Newtype nt { keys ∷ a | r } ⇒ Lens' nt a -_keys = lens get set - where - get ∷ nt → a - get = unwrap >>> _.keys - - set ∷ nt → a → nt - set nt a = - wrap $ _{ keys = a } $ unwrap nt - -_having ∷ ∀ a nt r. Newtype nt { having ∷ a |r} ⇒ Lens' nt a -_having = lens get set - where - get ∷ nt → a - get = unwrap >>> _.having - - set ∷ nt → a → nt - set nt a = - wrap $ _{ having = a } $ unwrap nt +_GroupBy ∷ ∀ a. Iso' (GroupBy a) {keys ∷ List a, having ∷ Maybe a} +_GroupBy = _Newtype printGroupBy ∷ Algebra GroupBy String printGroupBy (GroupBy { keys, having }) = @@ -132,39 +124,21 @@ newtype Case a = Case { cond ∷ a, expr ∷ a } derive instance functorCase ∷ Functor Case derive instance newtypeCase ∷ Newtype (Case a) _ -_cond ∷ ∀ a nt r. Newtype nt { cond ∷ a |r } ⇒ Lens' nt a -_cond = lens get set - where - get ∷ nt → a - get = unwrap >>> _.cond - - set ∷ nt → a → nt - set nt a = - wrap $ _{ cond = a } $ unwrap nt - - -_expr ∷ ∀ a nt r. Newtype nt { expr ∷ a|r} ⇒ Lens' nt a -_expr = lens get set - where - get ∷ nt → a - get = unwrap >>> _.expr - - set ∷ nt → a → nt - set nt a = - wrap $ _{ expr = a } $ unwrap nt - +_Case ∷ ∀ a. Iso' (Case a) { cond ∷ a, expr ∷ a } +_Case = _Newtype printCase ∷ Algebra Case String printCase (Case { cond, expr }) = " when " <> cond <> " then " <> expr -newtype OrderBy a = OrderBy (NE.NonEmpty List (OrderType × a)) -_orderBy ∷ ∀ a. Iso' (OrderBy a) (NE.NonEmpty List (OrderType × a)) -_orderBy = iso unwrap wrap +newtype OrderBy a = OrderBy (NE.NonEmpty List (OrderType × a)) derive instance functorOrderBy ∷ Functor OrderBy derive instance newtypeOrderBy ∷ Newtype (OrderBy a) _ +_OrderBy ∷ ∀ a. Iso' (OrderBy a) (NE.NonEmpty List (OrderType × a)) +_OrderBy = _Newtype + printOrderBy ∷ Algebra OrderBy String printOrderBy (OrderBy lst) = F.intercalate ", " $ lst <#> \(ot × a) → printOrderType ot <> " " <> a @@ -174,44 +148,71 @@ newtype Projection a = Projection { expr ∷ a, alias ∷ Maybe String } derive instance functorProjection ∷ Functor Projection derive instance newtypeProjection ∷ Newtype (Projection a) _ - -_alias ∷ ∀ a nt r. Newtype nt { alias ∷ a|r} ⇒ Lens' nt a -_alias = lens get set - where - get ∷ nt → a - get = unwrap >>> _.alias - - set ∷ nt → a → nt - set nt a = - wrap $ _{ alias = a } $ unwrap nt +_Projection ∷ ∀ a. Iso' (Projection a) { expr ∷ a, alias ∷ Maybe String } +_Projection = _Newtype printProjection ∷ Algebra Projection String printProjection (Projection { expr, alias }) = expr <> F.foldMap (" as " <> _) alias +type JoinRelR a = + { left ∷ SqlRelation a + , right ∷ SqlRelation a + , joinType ∷ JoinType + , clause ∷ a + } + +type ExprRelR a = + { expr ∷ a + , aliasName ∷ String + } + +type TableRelR a = + { tablePath ∷ FUPath + , alias ∷ Maybe String + } + +type VariRelR a = + { vari ∷ String + , alias ∷ Maybe String + } + +type IdentRelR = + { ident ∷ String + , alias ∷ Maybe String + } + data SqlRelation a - = JoinRelation - { left ∷ SqlRelation a - , right ∷ SqlRelation a - , joinType ∷ JoinType - , clause ∷ a - } - | ExprRelationAST - { expr ∷ a - , aliasName ∷ String - } - | TableRelationAST - { tablePath ∷ FUPath - , alias ∷ Maybe String - } - | VariRelation - { vari ∷ String - , alias ∷ Maybe String - } - | IdentRelation - { ident ∷ String - , alias ∷ Maybe String - } + = JoinRelation (JoinRelR a) + | ExprRelationAST (ExprRelR a) + | TableRelationAST (TableRelR a) + | VariRelation (VariRelR a) + | IdentRelation IdentRelR + +_JoinRelation ∷ ∀ a. Prism' (SqlRelation a) (JoinRelR a) +_JoinRelation = prism' JoinRelation case _ of + JoinRelation r → Just r + _ → Nothing + +_ExprRelation ∷ ∀ a. Prism' (SqlRelation a) (ExprRelR a) +_ExprRelation = prism' ExprRelationAST case _ of + ExprRelationAST r → Just r + _ → Nothing + +_TableRelation ∷ ∀ a. Prism' (SqlRelation a) (TableRelR a) +_TableRelation = prism' TableRelationAST case _ of + TableRelationAST r → Just r + _ → Nothing + +_VariRelation ∷ ∀ a. Prism' (SqlRelation a) (VariRelR a) +_VariRelation = prism' VariRelation case _ of + VariRelation r → Just r + _ → Nothing + +_IdentRelation ∷ ∀ a. Prism' (SqlRelation a) IdentRelR +_IdentRelation = prism' IdentRelation case _ of + IdentRelation r → Just r + _ → Nothing derive instance functorSqlRelation ∷ Functor SqlRelation @@ -237,53 +238,241 @@ printRelation = case _ of <> " on " <> clause +type BinopR a = + { lhs ∷ a + , rhs ∷ a + , op ∷ BinaryOperator + } + +type UnopR a = + { expr ∷ a + , op ∷ UnaryOperator + } + +type InvokeFunctionR a = + { name ∷ String + , args ∷ List a + } + +type MatchR a = + { expr ∷ a + , cases ∷ List (Case a) + , else_ ∷ Maybe a + } + +type SwitchR a = + { cases ∷ List (Case a) + , else_ ∷ Maybe a + } + +type LetR a = + { ident ∷ String + , bindTo ∷ a + , in_ ∷ a + } + +type SelectR a = + { isDistinct ∷ Boolean + , projections ∷ List (Projection a) + , relations ∷ Maybe (SqlRelation a) + , filter ∷ Maybe a + , groupBy ∷ Maybe (GroupBy a) + , orderBy ∷ Maybe (OrderBy a) + } + + +_lhs ∷ ∀ a r. Lens' { lhs ∷ a |r } a +_lhs = lens _.lhs _{ lhs = _ } + +_rhs ∷ ∀ a r. Lens' { rhs ∷ a |r } a +_rhs = lens _.rhs _{ rhs = _ } + +_op ∷ ∀ a r. Lens' { op ∷ a | r } a +_op = lens _.op _{ op = _ } + +_expr ∷ ∀ a r. Lens' { expr ∷ a|r } a +_expr = lens _.expr _{ expr = _ } + +_name ∷ ∀ a r. Lens' { name ∷ a|r } a +_name = lens _.name _{ name = _ } + +_args ∷ ∀ a r. Lens' { args ∷ a|r } a +_args = lens _.args _{ args = _ } + +_cases ∷ ∀ a r. Lens' { cases ∷ a|r } a +_cases = lens _.cases _{ cases = _ } + +_else ∷ ∀ a r. Lens' { else_ ∷ a|r } a +_else = lens _.else_ _{ else_ = _ } + +_ident ∷ ∀ a r. Lens' { ident ∷ a|r } a +_ident = lens _.ident _{ ident = _ } + +_bindTo ∷ ∀ a r. Lens' { bindTo ∷ a|r } a +_bindTo = lens _.bindTo _{ bindTo = _ } + +_in ∷ ∀ a r. Lens' { in_ ∷ a|r } a +_in = lens _.in_ _{ in_ = _ } -- __O_M_G__ + +_isDistinct ∷ ∀ a r. Lens' { isDistinct ∷ a|r } a +_isDistinct = lens _.isDistinct _{ isDistinct = _ } + +_projections ∷ ∀ a r. Lens' { projections ∷ a|r } a +_projections = lens _.projections _{ projections = _ } + +_relations ∷ ∀ a r. Lens' { relations ∷ a|r } a +_relations = lens _.relations _{ relations = _ } + +_filter ∷ ∀ a r. Lens' { filter ∷ a|r } a +_filter = lens _.filter _{ filter = _ } + +_groupBy ∷ ∀ a r. Lens' { groupBy ∷ a|r } a +_groupBy = lens _.groupBy _{ groupBy = _ } + +_orderBy ∷ ∀ a r. Lens' { orderBy ∷ a|r } a +_orderBy = lens _.orderBy _{ orderBy = _ } + +_keys ∷ ∀ a r. Lens' { keys ∷ a|r } a +_keys = lens _.keys _{ keys = _ } + +_having ∷ ∀ a r. Lens' { having ∷ a|r } a +_having = lens _.having _{ having = _ } + +_cond ∷ ∀ a r. Lens' { cond ∷ a|r } a +_cond = lens _.cond _{ cond = _ } + +_alias ∷ ∀ a r. Lens' { alias ∷ a|r } a +_alias = lens _.alias _{ alias = _ } + +_aliasName ∷ ∀ a r. Lens' { aliasName ∷ a|r } a +_aliasName = lens _.aliasName _{ aliasName = _ } + +_left ∷ ∀ a r. Lens' { left ∷ a|r } a +_left = lens _.left _{ left = _ } + +_right ∷ ∀ a r. Lens' { right ∷ a|r } a +_right = lens _.right _{ right = _ } + +_joinType ∷ ∀ a r. Lens' { joinType ∷ a|r } a +_joinType = lens _.joinType _{ joinType = _ } + +_clause ∷ ∀ a r. Lens' { clause ∷ a|r } a +_clause = lens _.clause _{ clause = _ } + +_tablePath ∷ ∀ a r. Lens' { tablePath ∷ a|r } a +_tablePath = lens _.tablePath _{ tablePath = _ } + data SqlF a = SetLiteral (List a) | ArrayLiteral (List a) | MapLiteral (List (a × a)) | Splice (Maybe a) - | Binop - { lhs ∷ a - , rhs ∷ a - , op ∷ BinaryOperator - } - | Unop - { expr ∷ a - , op ∷ UnaryOperator - } + | Binop (BinopR a) + | Unop (UnopR a) | Ident String - | InvokeFunction - { name ∷ String - , args ∷ List a - } - | Match - { expr ∷ a - , cases ∷ List (Case a) - , default_ ∷ Maybe a - } - | Switch - { cases ∷ List (Case a) - , default_ ∷ Maybe a - } - | Let - { ident ∷ String - , bindTo ∷ a - , in_ ∷ a - } + | InvokeFunction (InvokeFunctionR a) + | Match (MatchR a) + | Switch (SwitchR a) + | Let (LetR a) | IntLiteral Int | FloatLiteral Number | StringLiteral String | NullLiteral | BoolLiteral Boolean | Vari String - | Select - { isDistinct ∷ Boolean - , projections ∷ List (Projection a) - , relations ∷ Maybe (SqlRelation a) - , filter ∷ Maybe a - , groupBy ∷ Maybe (GroupBy a) - , orderBy ∷ Maybe (OrderBy a) - } + | Select (SelectR a) + + +_SetLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List t) +_SetLiteral = prism' (embed ∘ SetLiteral) $ project ⋙ case _ of + SetLiteral lst → Just lst + _ → Nothing + +_ArrayLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List t) +_ArrayLiteral = prism' (embed ∘ ArrayLiteral) $ project ⋙ case _ of + ArrayLiteral lst → Just lst + _ → Nothing + +_MapLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List (t × t)) +_MapLiteral = prism' (embed ∘ MapLiteral) $ project ⋙ case _ of + MapLiteral tpls → Just tpls + _ → Nothing + +_Splice ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (Maybe t) +_Splice = prism' (embed ∘ Splice) $ project ⋙ case _ of + Splice m → Just m + _ → Nothing + +_Binop ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (BinopR t) +_Binop = prism' (embed ∘ Binop) $ project ⋙ case _ of + Binop b → Just b + _ → Nothing + +_Unop ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (UnopR t) +_Unop = prism' (embed ∘ Unop) $ project ⋙ case _ of + Unop r → Just r + _ → Nothing + +_Ident ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t String +_Ident = prism' (embed ∘ Ident) $ project ⋙ case _ of + Ident s → Just s + _ → Nothing + +_InvokeFunction ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (InvokeFunctionR t) +_InvokeFunction = prism' (embed ∘ InvokeFunction) $ project ⋙ case _ of + InvokeFunction r → Just r + _ → Nothing + +_Match ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (MatchR t) +_Match = prism' (embed ∘ Match) $ project ⋙ case _ of + Match r → Just r + _ → Nothing + +_Switch ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (SwitchR t) +_Switch = prism' (embed ∘ Switch) $ project ⋙ case _ of + Switch r → Just r + _ → Nothing + +_Let ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (LetR t) +_Let = prism' (embed ∘ Let) $ project ⋙ case _ of + Let r → Just r + _ → Nothing + +_IntLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Int +_IntLiteral = prism' (embed ∘ IntLiteral) $ project ⋙ case _ of + IntLiteral r → Just r + _ → Nothing + +_FloatLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Number +_FloatLiteral = prism' (embed ∘ FloatLiteral) $ project ⋙ case _ of + FloatLiteral r → Just r + _ → Nothing + +_StringLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t String +_StringLiteral = prism' (embed ∘ StringLiteral) $ project ⋙ case _ of + StringLiteral r → Just r + _ → Nothing + +_NullLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Unit +_NullLiteral = prism' (const $ embed $ NullLiteral) $ project ⋙ case _ of + NullLiteral → Just unit + _ → Nothing + +_BoolLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Boolean +_BoolLiteral = prism' (embed ∘ BoolLiteral) $ project ⋙ case _ of + BoolLiteral b → Just b + _ → Nothing + +_Vari ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t String +_Vari = prism' (embed ∘ Vari) $ project ⋙ case _ of + Vari r → Just r + _ → Nothing + +_Select ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (SelectR t) +_Select = prism' (embed ∘ Select) $ project ⋙ case _ of + Select r → Just r + _ → Nothing + instance functorAST ∷ Functor SqlF where map f = case _ of @@ -331,14 +520,14 @@ instance functorAST ∷ Functor SqlF where InvokeFunction { name , args: map f args } - Match { expr, cases, default_ } → + Match { expr, cases, else_ } → Match { expr: f expr , cases: map (map f) cases - , default_: map f default_ + , else_: map f else_ } - Switch { cases, default_ } → + Switch { cases, else_ } → Switch { cases: map (map f) cases - , default_: map f default_ + , else_: map f else_ } SetLiteral lst → SetLiteral $ map f lst @@ -403,15 +592,15 @@ printF = case _ of s InvokeFunction {name, args} → name <> "(" <> F.intercalate "," args <> ")" - Match { expr, cases, default_ } → + Match { expr, cases, else_ } → "case " <> expr <> F.intercalate " " (map printCase cases) - <> F.foldMap (" else " <> _) default_ - Switch { cases, default_ } → + <> F.foldMap (" else " <> _) else_ + Switch { cases, else_ } → "case " <> F.intercalate " " (map printCase cases) - <> F.foldMap (" else " <> _) default_ + <> F.foldMap (" else " <> _) else_ Let { ident, bindTo, in_ } → ident <> " := " <> bindTo <> "; " <> in_ IntLiteral int → @@ -477,10 +666,10 @@ ident_ ∷ ∀ t. Corecursive t SqlF ⇒ String → t ident_ i = embed $ Ident i match_ ∷ ∀ t. Corecursive t SqlF ⇒ t → List (Case t) → Maybe t → t -match_ expr cases default_ = embed $ Match { expr, cases, default_ } +match_ expr cases else_ = embed $ Match { expr, cases, else_ } switch_ ∷ ∀ t. Corecursive t SqlF ⇒ List (Case t) → Maybe t → t -switch_ cases default_ = embed $ Switch { cases, default_ } +switch_ cases else_ = embed $ Switch { cases, else_ } let_ ∷ ∀ t. Corecursive t SqlF ⇒ String → t → t → t let_ ident bindTo in_ = embed $ Let { ident, bindTo, in_ } @@ -490,7 +679,7 @@ invokeFunction_ name args = embed $ InvokeFunction {name, args} -- when_ (bool true) # then_ (num 1.0) :P when_ ∷ ∀ t. t → (t → Case t) -when_ cond = Case <<< { cond, expr: _ } +when_ cond = Case ∘ { cond, expr: _ } then_ ∷ ∀ t. (t → Case t) → t → Case t then_ f t = f t From c2461a9d4ac59c888bab7c9fba3641446e165d5a Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Fri, 3 Mar 2017 17:07:34 +0300 Subject: [PATCH 04/19] more lenses --- src/SqlSquare/AST.purs | 15 ++++++++++++++- test/src/Main.purs | 28 +++++++++++++++++++++++++++- 2 files changed, 41 insertions(+), 2 deletions(-) diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index 3ced142..410c190 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -7,7 +7,7 @@ import Data.Either (Either, either) import Data.Foldable as F import Data.Functor.Mu (Mu) import Data.Maybe (Maybe(..)) -import Data.List (List, fromFoldable) +import Data.List (List(..), fromFoldable) import Data.Newtype (class Newtype, wrap, unwrap) import Data.NonEmpty as NE import Data.Tuple (Tuple(..)) @@ -704,6 +704,9 @@ select_ isDistinct projections relations filter groupBy orderBy = } +select ∷ ∀ t f. Corecursive t SqlF ⇒ SelectR t → t +select = embed ∘ Select + -- project_ (ident "foo") # as_ "bar" -- project_ (ident "foo") project_ ∷ ∀ t. t → Projection t @@ -717,3 +720,13 @@ groupBy_ f = GroupBy { keys: fromFoldable f, having: Nothing } having_ ∷ ∀ t. t → GroupBy t → GroupBy t having_ t (GroupBy r) = GroupBy r{ having = Just t } + +buildSelect ∷ ∀ t. Corecursive t SqlF ⇒ (SelectR t → SelectR t) → t +buildSelect f = + select $ f { isDistinct: false + , projections: Nil + , relations: Nothing + , filter: Nothing + , groupBy: Nothing + , orderBy: Nothing + } diff --git a/test/src/Main.purs b/test/src/Main.purs index 14a3f30..c956084 100644 --- a/test/src/Main.purs +++ b/test/src/Main.purs @@ -4,12 +4,15 @@ import Prelude import Control.Monad.Eff (Eff) import Data.Either (Either(..)) +import Data.List as L import Data.Maybe (Maybe(..)) import Data.NonEmpty as NE import Data.Path.Pathy as Pt import Debug.Trace (traceAnyA) import Data.Tuple (Tuple(..)) +import SqlSquare.AST ((∘)) import SqlSquare.AST as S +import Data.Lens ((.~), (?~), (<>~)) someExpr ∷ S.Sql someExpr = S.invokeFunction_ "foo" $ pure $ S.num_ 12.0 @@ -22,15 +25,38 @@ otherExpr = , S.project_ $ S.splice_ $ Just $ S.binop_ S.FieldDeref (S.ident_ "bar") (S.ident_ "baz") ] ( map - (S.TableRelationAST <<< { alias: Nothing, tablePath: _ } <<< Right) + (S.TableRelationAST ∘ { alias: Nothing, tablePath: _ } ∘ Right) $ Pt.parseAbsFile "/mongo/testDb/patients" ) ( Just $ S.binop_ S.Eq (S.ident_ "quux") (S.num_ 12.0) ) ( Just $ S.groupBy_ [ S.ident_ "zzz" ] # S.having_ ( S.binop_ S.Gt (S.ident_ "ooo") ( S.int_ 2)) ) ( Just $ S.OrderBy $ NE.singleton $ Tuple S.ASC (S.ident_ "zzz") ) +thirdExpr ∷ S.Sql +thirdExpr = + S.buildSelect + $ (S._isDistinct .~ true) + ∘ (S._projections <>~ (L.singleton $ S.project_ (S.ident_ "foo") # S.as_ "field")) + ∘ (S._projections <>~ + (L.singleton + $ S.project_ + $ S.splice_ + $ Just + $ S.binop_ + S.FieldDeref + (S.ident_ "bar") + (S.ident_ "baz"))) + ∘ (S._relations .~ + (map (S.TableRelationAST ∘ { alias: Nothing, tablePath: _} ∘ Right) + $ Pt.parseAbsFile "/mongo/testDb/patients")) + ∘ (S._filter ?~ S.binop_ S.Eq (S.ident_ "quux") (S.num_ 12.0)) + ∘ (S._groupBy ?~ + (S.groupBy_ [ S.ident_ "zzz" ] # S.having_ (S.binop_ S.Gt (S.ident_ "ooo") (S.int_ 2)))) + ∘ (S._orderBy ?~ S.OrderBy (NE.singleton $ Tuple S.ASC (S.ident_ "zzz"))) + main ∷ ∀ e. Eff e Unit main = do traceAnyA someExpr traceAnyA $ S.print someExpr traceAnyA $ S.print otherExpr + traceAnyA $ S.print thirdExpr From df4e8d828e1840342c84b2e1ff18d9689ea95c0f Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Fri, 3 Mar 2017 17:38:00 +0300 Subject: [PATCH 05/19] ... --- src/SqlSquare/AST.purs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index 410c190..a237b37 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -184,8 +184,8 @@ type IdentRelR = data SqlRelation a = JoinRelation (JoinRelR a) - | ExprRelationAST (ExprRelR a) - | TableRelationAST (TableRelR a) + | ExprRelation (ExprRelR a) + | TableRelation (TableRelR a) | VariRelation (VariRelR a) | IdentRelation IdentRelR @@ -195,13 +195,13 @@ _JoinRelation = prism' JoinRelation case _ of _ → Nothing _ExprRelation ∷ ∀ a. Prism' (SqlRelation a) (ExprRelR a) -_ExprRelation = prism' ExprRelationAST case _ of - ExprRelationAST r → Just r +_ExprRelation = prism' ExprRelation case _ of + ExprRelation r → Just r _ → Nothing _TableRelation ∷ ∀ a. Prism' (SqlRelation a) (TableRelR a) -_TableRelation = prism' TableRelationAST case _ of - TableRelationAST r → Just r +_TableRelation = prism' TableRelation case _ of + TableRelation r → Just r _ → Nothing _VariRelation ∷ ∀ a. Prism' (SqlRelation a) (VariRelR a) @@ -730,3 +730,7 @@ buildSelect f = , groupBy: Nothing , orderBy: Nothing } + +buildProjection ∷ ∀ t. Corecursive t SqlF ⇒ (ProjectionR t → ProjectionR t) → t +buildProjection f = + embed $ Projection $ f { expr: From cf1fa71d03b7b18a2b9ab1d72704e88469f4ed63 Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Fri, 3 Mar 2017 21:25:16 +0300 Subject: [PATCH 06/19] wip examples --- bower.json | 3 +- src/SqlSquare/AST.purs | 50 ++++++++++++++------- src/SqlSquare/Json.purs | 34 +++++++++++++++ src/SqlSquare/Search.purs | 91 +++++++++++++++++++++++++++++++++++++++ src/SqlSquare/Utils.purs | 16 +++++++ test/src/Main.purs | 14 ++++-- 6 files changed, 188 insertions(+), 20 deletions(-) create mode 100644 src/SqlSquare/Json.purs create mode 100644 src/SqlSquare/Search.purs create mode 100644 src/SqlSquare/Utils.purs diff --git a/bower.json b/bower.json index a420ae0..c383721 100644 --- a/bower.json +++ b/bower.json @@ -12,6 +12,7 @@ "purescript-pathy": "^3.0.2", "purescript-debug": "^2.0.0", "purescript-profunctor": "^2.0.0", - "purescript-profunctor-lenses": "^2.6.0" + "purescript-profunctor-lenses": "^2.6.0", + "purescript-search": "^2.0.0" } } diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index a237b37..b5f2b75 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -6,6 +6,7 @@ import Data.Bifunctor (bimap) import Data.Either (Either, either) import Data.Foldable as F import Data.Functor.Mu (Mu) +import Data.Functor.Coproduct (Coproduct, coproduct, left, right) import Data.Maybe (Maybe(..)) import Data.List (List(..), fromFoldable) import Data.Newtype (class Newtype, wrap, unwrap) @@ -14,16 +15,9 @@ import Data.Tuple (Tuple(..)) import Data.Path.Pathy (AbsFile, RelFile, Unsandboxed, unsafePrintPath) import Data.Lens (Prism', prism', Lens', lens, Iso', iso) -import Matryoshka (class Recursive, class Corecursive, Algebra, cata, embed, project) +import SqlSquare.Utils (type (×), (×), (∘), (⋙)) -infixr 4 type Tuple as × -infixr 1 Tuple as × -infixr 9 compose as ∘ - -composeFlipped ∷ ∀ a b c d. Semigroupoid a ⇒ a b c → a c d → a b d -composeFlipped f g = compose g f - -infixr 9 composeFlipped as ⋙ +import Matryoshka (class Recursive, class Corecursive, Algebra, cata, embed, project, Coalgebra) type FUPath = Either (RelFile Unsandboxed) (AbsFile Unsandboxed) @@ -31,12 +25,14 @@ data OrderType = ASC | DESC + printOrderType ∷ OrderType → String printOrderType = case _ of ASC → "asc" DESC → "desc" derive instance eqOrderType ∷ Eq OrderType +derive instance ordOrderType ∷ Ord OrderType data JoinType = LeftJoin @@ -52,6 +48,7 @@ printJoinType = case _ of InnerJoin → "inner join" derive instance eqJoinType ∷ Eq JoinType +derive instance ordJoinType ∷ Ord JoinType data BinaryOperator = IfUndefined @@ -85,6 +82,7 @@ data BinaryOperator | UnshiftMap derive instance eqBinaryOperator ∷ Eq BinaryOperator +derive instance ordBinaryOperator ∷ Ord BinaryOperator data UnaryOperator = Not @@ -103,6 +101,7 @@ data UnaryOperator | UnshiftArray derive instance eqUnaryOperator ∷ Eq UnaryOperator +derive instance ordUnaryOperator ∷ Ord UnaryOperator _Newtype ∷ ∀ n t. Newtype n t ⇒ Iso' n t _Newtype = iso unwrap wrap @@ -110,6 +109,8 @@ _Newtype = iso unwrap wrap newtype GroupBy a = GroupBy { keys ∷ List a, having ∷ Maybe a } derive instance newtypeGroupBy ∷ Newtype (GroupBy a) _ derive instance functorGroupBy ∷ Functor GroupBy +derive instance eqGroupBy ∷ Eq a ⇒ Eq (GroupBy a) +derive instance ordGroupBy ∷ Ord a ⇒ Ord (GroupBy a) _GroupBy ∷ ∀ a. Iso' (GroupBy a) {keys ∷ List a, having ∷ Maybe a} _GroupBy = _Newtype @@ -123,6 +124,8 @@ newtype Case a = Case { cond ∷ a, expr ∷ a } derive instance functorCase ∷ Functor Case derive instance newtypeCase ∷ Newtype (Case a) _ +derive instance eqCase ∷ Eq a ⇒ Eq (Case a) +derive instance ordCase ∷ Ord a ⇒ Ord (Case a) _Case ∷ ∀ a. Iso' (Case a) { cond ∷ a, expr ∷ a } _Case = _Newtype @@ -135,6 +138,8 @@ newtype OrderBy a = OrderBy (NE.NonEmpty List (OrderType × a)) derive instance functorOrderBy ∷ Functor OrderBy derive instance newtypeOrderBy ∷ Newtype (OrderBy a) _ +derive instance eqOrderBy ∷ Eq a ⇒ Eq (OrderBy a) +derive instance ordOrderBy ∷ Ord a ⇒ Ord (OrderBy a) _OrderBy ∷ ∀ a. Iso' (OrderBy a) (NE.NonEmpty List (OrderType × a)) _OrderBy = _Newtype @@ -147,6 +152,8 @@ newtype Projection a = Projection { expr ∷ a, alias ∷ Maybe String } derive instance functorProjection ∷ Functor Projection derive instance newtypeProjection ∷ Newtype (Projection a) _ +derive instance eqProjection ∷ Eq a ⇒ Eq (Projection a) +derive instance ordProjection ∷ Ord a ⇒ Ord (Projection a) _Projection ∷ ∀ a. Iso' (Projection a) { expr ∷ a, alias ∷ Maybe String } _Projection = _Newtype @@ -215,14 +222,16 @@ _IdentRelation = prism' IdentRelation case _ of _ → Nothing derive instance functorSqlRelation ∷ Functor SqlRelation +derive instance eqSqlRelation ∷ Eq a ⇒ Eq (SqlRelation a) +derive instance ordSqlRelation ∷ Ord a ⇒ Ord (SqlRelation a) printRelation ∷ Algebra SqlRelation String printRelation = case _ of - ExprRelationAST {expr, aliasName} → + ExprRelation {expr, aliasName} → "(" <> expr <> ") as " <> aliasName VariRelation { vari, alias} → vari <> F.foldMap (" as " <> _) alias - TableRelationAST { tablePath, alias } → + TableRelation { tablePath, alias } → "`" <> either unsafePrintPath unsafePrintPath tablePath <> "`" @@ -381,7 +390,10 @@ data SqlF a | BoolLiteral Boolean | Vari String | Select (SelectR a) + | Parens a +derive instance eqSqlF ∷ Eq a ⇒ Eq (SqlF a) +derive instance ordSqlF ∷ Ord a ⇒ Ord (SqlF a) _SetLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List t) _SetLiteral = prism' (embed ∘ SetLiteral) $ project ⋙ case _ of @@ -473,6 +485,10 @@ _Select = prism' (embed ∘ Select) $ project ⋙ case _ of Select r → Just r _ → Nothing +_Parens ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t t +_Parens = prism' (embed ∘ Parens) $ project ⋙ case _ of + Parens t → Just t + _ → Nothing instance functorAST ∷ Functor SqlF where map f = case _ of @@ -533,6 +549,8 @@ instance functorAST ∷ Functor SqlF where SetLiteral $ map f lst ArrayLiteral lst → ArrayLiteral $ map f lst + Parens t → + Parens $ f t printF ∷ Algebra SqlF String @@ -624,7 +642,8 @@ printF = case _ of <> (filter # F.foldMap \f → " where " <> f) <> (groupBy # F.foldMap \gb → " group by " <> printGroupBy gb) <> (orderBy # F.foldMap \ob → " order by " <> printOrderBy ob) - + Parens t → + "(" <> t <> ")" type Sql = Mu SqlF @@ -704,7 +723,7 @@ select_ isDistinct projections relations filter groupBy orderBy = } -select ∷ ∀ t f. Corecursive t SqlF ⇒ SelectR t → t +select ∷ ∀ t. Corecursive t SqlF ⇒ SelectR t → t select = embed ∘ Select -- project_ (ident "foo") # as_ "bar" @@ -731,6 +750,5 @@ buildSelect f = , orderBy: Nothing } -buildProjection ∷ ∀ t. Corecursive t SqlF ⇒ (ProjectionR t → ProjectionR t) → t -buildProjection f = - embed $ Projection $ f { expr: +pars_ ∷ ∀ t. Corecursive t SqlF ⇒ t → t +pars_ = embed ∘ Parens diff --git a/src/SqlSquare/Json.purs b/src/SqlSquare/Json.purs new file mode 100644 index 0000000..3c3bfe6 --- /dev/null +++ b/src/SqlSquare/Json.purs @@ -0,0 +1,34 @@ +module SqlSquare.Json where + +import Prelude + +import Data.Argonaut (JCursor(..)) +import Data.Argonaut as JS +import Data.Set as Set +import Data.List as L +import Data.Foldable as F +import Data.Tuple (fst) +import Data.Maybe (Maybe(..)) + +import SqlSquare.AST as S +import SqlSquare.Utils ((∘), (⋙)) + +import Matryoshka (ana, Coalgebra) + +data UnfoldableJC = JC JCursor | S String | I Int + +jcCoalgebra ∷ Coalgebra S.SqlF UnfoldableJC +jcCoalgebra = case _ of + S s → S.StringLiteral s + I i → S.IntLiteral i + JC cursor → case cursor of + JCursorTop → S.Splice Nothing + JIndex i c → S.Binop { op: S.IndexDeref, lhs: JC c, rhs: I i } + JField f c → S.Binop { op: S.FieldDeref, lhs: JC c, rhs: S f } + +jcursorToSql ∷ JCursor → S.Sql +jcursorToSql = JC ⋙ ana jcCoalgebra + +fields ∷ JS.JArray → L.List S.Sql +fields arr = + map jcursorToSql $ L.fromFoldable $ F.foldMap (Set.fromFoldable ∘ map fst) $ map JS.toPrims arr diff --git a/src/SqlSquare/Search.purs b/src/SqlSquare/Search.purs new file mode 100644 index 0000000..16ba78c --- /dev/null +++ b/src/SqlSquare/Search.purs @@ -0,0 +1,91 @@ +-- | This is temp module just to be sure that it works fine + +module SqlSquare.Search where + +import Prelude + +import Data.Lens ((.~), (?~)) +import Data.List ((:)) +import Data.List as L +import Data.Maybe (Maybe(..)) +import Data.Monoid (class Monoid) +import Data.Newtype (unwrap) +import Data.Foldable as F + +import SqlSquare.Utils ((∘), type (×), (×), (⋙)) +import SqlSquare.AST (SqlF(..), Sql, buildSelect, FUPath, SqlRelation(..)) +import SqlSquare.AST as S + +import Matryoshka (cata, Algebra, project, cata) + +import Text.SlamSearch.Types as SS + +data TopFieldMark + = Init + | Uno + | Duo + +isTop ∷ TopFieldMark → Boolean +isTop Duo = false +isTop _ = true + +topFieldF ∷ Algebra SqlF TopFieldMark +topFieldF = case _ of + Splice Nothing → Init + StringLiteral _ → Uno + Ident _ → Uno + IntLiteral _ → Uno + Binop { op: S.FieldDeref, lhs: Init, rhs: Uno } → Uno + Binop { op: S.IndexDeref, lhs: Init, rhs: Uno } → Uno + _ → Duo + +topField ∷ Sql → Boolean +topField = isTop ∘ cata topFieldF + +queryToSql + ∷ L.List Sql + → SS.SearchQuery + → FUPath + → Sql +queryToSql fields query tablePath = + buildSelect + $ (S._isDistinct .~ isDistinct) + ∘ (S._projections .~ topFields) + ∘ (S._relations ?~ TableRelation {alias: Nothing, tablePath}) + ∘ (S._filter ?~ filter) + + where + topFields = map (S.Projection ∘ { expr: _, alias: Nothing }) $ L.filter topField fields + + isDistinct = false + + filter = + ands + $ map ors + $ unwrap + $ map (termToSql fields) query + +ors ∷ L.List Sql → Sql +ors = case _ of + L.Nil → S.bool_ false + hd : L.Nil → S.pars_ hd + hd : tl → F.foldl (\acc sql → S.binop_ S.Or acc $ S.pars_ sql) hd tl + +ands ∷ L.List Sql → Sql +ands = case _ of + L.Nil → S.bool_ true + hd : L.Nil → S.pars_ hd + hd : tl → F.foldl (\acc sql → S.binop_ S.And acc $ S.pars_ sql) hd tl + +termToSql ∷ L.List Sql → SS.Term → Sql +termToSql fields (SS.Term {include, predicate, labels}) + | not include = + S.unop_ S.Not $ S.pars_ $ termToSql fields (SS.Term {include: true, predicate, labels}) + | otherwise = S.bool_ false --ors $ map (predicateToSql predicate) $ labelsProjection fields labels + + +--labelsProjection +-- ∷ L.List Sql +-- → Array SS.Label +-- → L.List Sql +--labelsProjection fields ls = diff --git a/src/SqlSquare/Utils.purs b/src/SqlSquare/Utils.purs new file mode 100644 index 0000000..a770fea --- /dev/null +++ b/src/SqlSquare/Utils.purs @@ -0,0 +1,16 @@ +module SqlSquare.Utils where + +import Prelude +import Data.Tuple (Tuple(..)) +import Data.Functor.Coproduct (Coproduct, coproduct) + +infixr 4 type Tuple as × +infixr 1 Tuple as × +infixr 9 compose as ∘ +infixr 4 type Coproduct as ⨁ +infixr 5 coproduct as ⨁ + +composeFlipped ∷ ∀ a b c d. Semigroupoid a ⇒ a b c → a c d → a b d +composeFlipped f g = compose g f + +infixr 9 composeFlipped as ⋙ diff --git a/test/src/Main.purs b/test/src/Main.purs index c956084..83a8323 100644 --- a/test/src/Main.purs +++ b/test/src/Main.purs @@ -3,6 +3,7 @@ module Test.Main where import Prelude import Control.Monad.Eff (Eff) +import Data.Argonaut (JCursor(..)) import Data.Either (Either(..)) import Data.List as L import Data.Maybe (Maybe(..)) @@ -10,9 +11,11 @@ import Data.NonEmpty as NE import Data.Path.Pathy as Pt import Debug.Trace (traceAnyA) import Data.Tuple (Tuple(..)) -import SqlSquare.AST ((∘)) +import SqlSquare.Utils ((∘), (⋙)) import SqlSquare.AST as S import Data.Lens ((.~), (?~), (<>~)) +import Matryoshka (class Recursive, class Corecursive, Coalgebra, ana) + someExpr ∷ S.Sql someExpr = S.invokeFunction_ "foo" $ pure $ S.num_ 12.0 @@ -25,7 +28,7 @@ otherExpr = , S.project_ $ S.splice_ $ Just $ S.binop_ S.FieldDeref (S.ident_ "bar") (S.ident_ "baz") ] ( map - (S.TableRelationAST ∘ { alias: Nothing, tablePath: _ } ∘ Right) + (S.TableRelation ∘ { alias: Nothing, tablePath: _ } ∘ Right) $ Pt.parseAbsFile "/mongo/testDb/patients" ) ( Just $ S.binop_ S.Eq (S.ident_ "quux") (S.num_ 12.0) ) ( Just $ S.groupBy_ [ S.ident_ "zzz" ] # S.having_ ( S.binop_ S.Gt (S.ident_ "ooo") ( S.int_ 2)) ) @@ -47,16 +50,21 @@ thirdExpr = (S.ident_ "bar") (S.ident_ "baz"))) ∘ (S._relations .~ - (map (S.TableRelationAST ∘ { alias: Nothing, tablePath: _} ∘ Right) + (map (S.TableRelation ∘ { alias: Nothing, tablePath: _} ∘ Right) $ Pt.parseAbsFile "/mongo/testDb/patients")) ∘ (S._filter ?~ S.binop_ S.Eq (S.ident_ "quux") (S.num_ 12.0)) ∘ (S._groupBy ?~ (S.groupBy_ [ S.ident_ "zzz" ] # S.having_ (S.binop_ S.Gt (S.ident_ "ooo") (S.int_ 2)))) ∘ (S._orderBy ?~ S.OrderBy (NE.singleton $ Tuple S.ASC (S.ident_ "zzz"))) +field ∷ S.Sql +field = S.binop_ S.FieldDeref (S.splice_ Nothing) (S.ident_ "field") + main ∷ ∀ e. Eff e Unit main = do traceAnyA someExpr traceAnyA $ S.print someExpr traceAnyA $ S.print otherExpr traceAnyA $ S.print thirdExpr + traceAnyA $ S.print field + traceAnyA $ S.print $ jcursorToSql $ JField "foo" $ JIndex 1 $ JIndex 2 $ JField "bar" $ JCursorTop From 976802be4ff488f07469b43a8ca3631a89a13f43 Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Mon, 6 Mar 2017 18:49:35 +0300 Subject: [PATCH 07/19] search example --- bower.json | 9 +- src/SqlSquare/AST.purs | 29 ++++- src/SqlSquare/Search.purs | 224 ++++++++++++++++++++++++++++++++++++-- 3 files changed, 244 insertions(+), 18 deletions(-) diff --git a/bower.json b/bower.json index c383721..5f47ba3 100644 --- a/bower.json +++ b/bower.json @@ -10,9 +10,12 @@ "purescript-prelude": "^2.4.0", "purescript-matryoshka": "^0.1.1", "purescript-pathy": "^3.0.2", - "purescript-debug": "^2.0.0", "purescript-profunctor": "^2.0.0", - "purescript-profunctor-lenses": "^2.6.0", - "purescript-search": "^2.0.0" + "purescript-profunctor-lenses": "^2.6.0" + }, + "devDependencies": { + "purescript-argonaut": "^2.0.0", + "purescript-search": "^2.0.0", + "purescript-debug": "^2.0.0" } } diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index b5f2b75..2bed1e3 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -6,18 +6,19 @@ import Data.Bifunctor (bimap) import Data.Either (Either, either) import Data.Foldable as F import Data.Functor.Mu (Mu) -import Data.Functor.Coproduct (Coproduct, coproduct, left, right) import Data.Maybe (Maybe(..)) import Data.List (List(..), fromFoldable) import Data.Newtype (class Newtype, wrap, unwrap) import Data.NonEmpty as NE -import Data.Tuple (Tuple(..)) import Data.Path.Pathy (AbsFile, RelFile, Unsandboxed, unsafePrintPath) import Data.Lens (Prism', prism', Lens', lens, Iso', iso) +import Data.String.Regex as RX +import Data.String.Regex.Flags as RXF +import Data.String.Regex.Unsafe as URX import SqlSquare.Utils (type (×), (×), (∘), (⋙)) -import Matryoshka (class Recursive, class Corecursive, Algebra, cata, embed, project, Coalgebra) +import Matryoshka (class Recursive, class Corecursive, Algebra, cata, embed, project) type FUPath = Either (RelFile Unsandboxed) (AbsFile Unsandboxed) @@ -607,7 +608,7 @@ printF = case _ of ShiftArrayValues → expr <> "[_]" UnshiftArray → "[" <> expr <> "...]" Ident s → - s + "`" <> s <> "`" InvokeFunction {name, args} → name <> "(" <> F.intercalate "," args <> ")" Match { expr, cases, else_ } → @@ -626,7 +627,7 @@ printF = case _ of FloatLiteral n → show n StringLiteral s → - show s + renderString s NullLiteral → "null" BoolLiteral b → @@ -644,6 +645,21 @@ printF = case _ of <> (orderBy # F.foldMap \ob → " order by " <> printOrderBy ob) Parens t → "(" <> t <> ")" + where + replaceAll + ∷ String + → String + → String + → String + replaceAll i = + RX.replace $ URX.unsafeRegex i RXF.global + + renderString + ∷ String + → String + renderString str = + "\"" <> replaceAll "\"" "\\\"" str <> "\"" + type Sql = Mu SqlF @@ -666,6 +682,9 @@ int_ i = embed $ IntLiteral i num_ ∷ ∀ t. Corecursive t SqlF ⇒ Number → t num_ i = embed $ FloatLiteral i +string_ ∷ ∀ t. Corecursive t SqlF ⇒ String → t +string_ s = embed $ StringLiteral s + unop_ ∷ ∀ t. Corecursive t SqlF ⇒ UnaryOperator → t → t unop_ op expr = embed $ Unop { op, expr } diff --git a/src/SqlSquare/Search.purs b/src/SqlSquare/Search.purs index 16ba78c..f90e344 100644 --- a/src/SqlSquare/Search.purs +++ b/src/SqlSquare/Search.purs @@ -4,22 +4,79 @@ module SqlSquare.Search where import Prelude +import Control.MonadZero (guard) + +import Data.Int as Int import Data.Lens ((.~), (?~)) import Data.List ((:)) import Data.List as L -import Data.Maybe (Maybe(..)) -import Data.Monoid (class Monoid) +import Data.Maybe (Maybe(..), fromMaybe, isJust) import Data.Newtype (unwrap) import Data.Foldable as F +import Data.Tuple (Tuple) +import Data.String as Str +import Data.String.Regex as RX +import Data.String.Regex.Unsafe as URX +import Data.String.Regex.Flags as RXF + +import Global (readFloat, isNaN) -import SqlSquare.Utils ((∘), type (×), (×), (⋙)) +import SqlSquare.Utils ((∘), (×), (⋙)) import SqlSquare.AST (SqlF(..), Sql, buildSelect, FUPath, SqlRelation(..)) import SqlSquare.AST as S -import Matryoshka (cata, Algebra, project, cata) +import Matryoshka (Algebra, Transform, ElgotAlgebra, cata, transAna, elgotZygo) import Text.SlamSearch.Types as SS +stringToNumber ∷ String → Maybe Number +stringToNumber s = + let n = readFloat s + in if isNaN n + then Nothing + else Just n + +stringToBoolean ∷ String → Maybe Boolean +stringToBoolean "true" = Just true +stringToBoolean "false" = Just false +stringToBoolean _ = Nothing + + +needDate ∷ String → Boolean +needDate = RX.test dateRegex + where + dateRegex = + URX.unsafeRegex + """^(((19|20)([2468][048]|[13579][26]|0[48])|2000)[-]02[-]29|((19|20)[0-9]{2}[-](0[4678]|1[02])[-](0[1-9]|[12][0-9]|30)|(19|20)[0-9]{2}[-](0[1359]|11)[-](0[1-9]|[12][0-9]|3[01])|(19|20)[0-9]{2}[-]02[-](0[1-9]|1[0-9]|2[0-8])))$""" + RXF.noFlags + + +needTime ∷ String → Boolean +needTime = RX.test timeRegex + where + timeRegex = + URX.unsafeRegex + "^([0-1]?[0-9]|2[0-3]):[0-5][0-9](:[0-5][0-9])?$" + RXF.noFlags + + +needDateTime ∷ String → Boolean +needDateTime = RX.test dtRegex + where + dtRegex = + URX.unsafeRegex + "^(-?(?:[1-9][0-9]*)?[0-9]{4})-(1[0-2]|0[1-9])-(3[0-1]|0[1-9]|[1-2][0-9]) (2[0-3]|[0-1][0-9]):([0-5][0-9]):([0-5][0-9])(\\.[0-9]+)?(Z|[+-](?:2[0-3]|[0-1][0-9]):[0-5][0-9])?$" + RXF.noFlags + +needInterval ∷ String → Boolean +needInterval = RX.test intervalRegex + where + intervalRegex = + URX.unsafeRegex + "P((([0-9]*\\.?[0-9]*)Y)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)W)?(([0-9]*\\.?[0-9]*)D)?)?(T(([0-9]*\\.?[0-9]*)H)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)S)?)?" + RXF.noFlags + + data TopFieldMark = Init | Uno @@ -42,6 +99,14 @@ topFieldF = case _ of topField ∷ Sql → Boolean topField = isTop ∘ cata topFieldF +flattenIndexF ∷ ∀ t. Transform t SqlF SqlF +flattenIndexF = case _ of + Binop { op: S.IndexDeref, lhs } → Unop { op: S.FlattenArrayValues, expr: lhs } + s → s + +flattenIndex ∷ Sql → Sql +flattenIndex = transAna flattenIndexF + queryToSql ∷ L.List Sql → SS.SearchQuery @@ -81,11 +146,150 @@ termToSql ∷ L.List Sql → SS.Term → Sql termToSql fields (SS.Term {include, predicate, labels}) | not include = S.unop_ S.Not $ S.pars_ $ termToSql fields (SS.Term {include: true, predicate, labels}) - | otherwise = S.bool_ false --ors $ map (predicateToSql predicate) $ labelsProjection fields labels + | otherwise = ors $ flip predicateToSql predicate <$> L.filter (labelsPredicate labels) fields + +predicateToSql ∷ Sql → SS.Predicate → Sql +predicateToSql field = case _ of + SS.Contains (SS.Text v) → + ors + $ map S.pars_ + $ (pure $ S.invokeFunction_ "search" + $ field : (S.string_ $ globToRegex $ containsToGlob v) : S.bool_ true : L.Nil + ) + <> (sqlsFromSearchStr v <#> S.binop_ S.Eq field) + SS.Range (SS.Text v) (SS.Text vv) → + ors + $ map S.pars_ + $ ( pure $ S.binop_ S.And + ( S.pars_ $ S.binop_ S.Ge (lower_ field) (lower_ $ S.string_ v)) + ( S.pars_ $ S.binop_ S.Le (lower_ field) (lower_ $ S.string_ vv)) + ) + <> do + start ← sqlsFromSearchStr v + end ← sqlsFromSearchStr vv + pure $ S.binop_ S.And + ( S.pars_ $ S.binop_ S.Ge field start ) + ( S.pars_ $ S.binop_ S.Le field end ) + SS.Range (SS.Tag val) vv → + predicateToSql field $ SS.Range (SS.Text val) vv + SS.Range val (SS.Tag vv) → + predicateToSql field $ SS.Range val (SS.Text vv) + SS.Contains (SS.Tag v) → + predicateToSql field $ SS.Contains $ SS.Text v + + SS.Eq v → renderBinRel S.Eq $ valueToString v + SS.Gt v → renderBinRel S.Gt $ valueToString v + SS.Gte v → renderBinRel S.Ge $ valueToString v + SS.Lt v → renderBinRel S.Lt $ valueToString v + SS.Lte v → renderBinRel S.Le $ valueToString v + SS.Ne v → renderBinRel S.Neq $ valueToString v + SS.Like v → + S.invokeFunction_ "search" + $ field : S.string_ v : S.bool_ true : L.Nil + where + valueToString ∷ SS.Value → String + valueToString = case _ of + SS.Text v → v + SS.Tag v → v + + renderBinRel ∷ S.BinaryOperator → String → Sql + renderBinRel op v = + ors + $ map S.pars_ + ( pure $ S.binop_ op (lower_ field) (lower_ $ S.string_ v)) + <> ( sqlsFromSearchStr v <#> S.binop_ op field) + + + sqlsFromSearchStr ∷ String → L.List Sql + sqlsFromSearchStr v = + (flip F.foldMap (stringToNumber v) $ pure ∘ S.num_) + <> (flip F.foldMap (Int.fromString v) $ pure ∘ S.int_) + <> (flip F.foldMap (stringToBoolean v) $ pure ∘ S.bool_) + <> ((guard ((not $ needDateTime v) && needDate v)) $> + S.invokeFunction_ "DATE" (S.string_ v : L.Nil)) + <> (guard (needTime v) $> + S.invokeFunction_ "TIME" (S.string_ v : L.Nil)) + <> (guard (needDateTime v) $> + S.invokeFunction_ "TIMESTAMP" (S.string_ v : L.Nil)) + <> (guard (needInterval v) $> + S.invokeFunction_ "INTERVAL" (S.string_ v : L.Nil)) + + lower_ ∷ Sql → Sql + lower_ = S.invokeFunction_ "LOWER" ∘ pure + +globToRegex ∷ String → String +globToRegex = + (\x → "^" <> x <> "$") + ∘ RX.replace askRegex "." + ∘ RX.replace starRegex ".*" + ∘ RX.replace globEscapeRegex "\\$&" + where + globEscapeRegex = + URX.unsafeRegex + "[\\-\\[\\]\\/\\{\\}\\(\\)\\+\\.\\\\\\^\\$\\|]" + RXF.global + + starRegex = + URX.unsafeRegex + "\\*" RXF.global + askRegex = + URX.unsafeRegex + "\\?" RXF.global + +containsToGlob ∷ String → String +containsToGlob v + | hasSpecialChars v = v + | otherwise = "*" <> v <> "*" + +hasSpecialChars ∷ String → Boolean +hasSpecialChars v = + isJust (Str.indexOf (Str.Pattern "*") v) || isJust (Str.indexOf (Str.Pattern "?") v) + +listIndexF ∷ Algebra SqlF (Maybe Int) +listIndexF = case _ of + Splice Nothing → Just 0 + Splice (Just i) → map (add one) i + Binop { op: S.FieldDeref, lhs: Just i } → Just $ i + one + Binop { op: S.IndexDeref, lhs: Just i } → Just $ i + one + Unop { op: S.FlattenArrayValues, expr: Just i } → Just $ i + one + Unop { op: S.FlattenMapValues, expr: Just i } → Just $ i + one + _ → Nothing + + +identOrString ∷ ∀ a. SqlF a → Maybe String +identOrString (Ident s) = Just s +identOrString (StringLiteral s) = Just s +identOrString _ = Nothing + +labelPredicateF ∷ L.List String → ElgotAlgebra (Tuple (Maybe Int)) SqlF Boolean +labelPredicateF labelsString (mbIx × sqlF) = case sqlF of + Splice acc → + fromMaybe false acc && ixedLabel == Just "*" + IntLiteral i → + fromMaybe false $ ixedLabel >>= Int.fromString ⋙ map (eq i) + StringLiteral i → + ixedLabel == Just i + Ident i → + ixedLabel == Just i + Unop {op: S.FlattenArrayValues, expr} → + expr && (ixedLabel == Just "*" || ixedLabel == Just "[*]") + Unop {op: S.FlattenMapValues, expr} → + expr && (ixedLabel == Just "*" || ixedLabel == Just "{*}") + Binop { op: S.FieldDeref, lhs, rhs } → + lhs && rhs + Binop { op: S.IndexDeref, lhs, rhs } → + lhs && rhs + _ → + false + where + ixedLabel ∷ Maybe String + ixedLabel = mbIx >>= L.index labelsString + +labelsPredicate ∷ L.List SS.Label → Sql → Boolean +labelsPredicate ls = elgotZygo listIndexF (labelPredicateF $ labelStrings ls ) ---labelsProjection --- ∷ L.List Sql --- → Array SS.Label --- → L.List Sql ---labelsProjection fields ls = +labelStrings ∷ ∀ f. Functor f ⇒ f SS.Label → f String +labelStrings = map case _ of + SS.Meta l → l + SS.Common l → l From 86a2fab022f99fb82a385f3529eab9d30da46621 Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Mon, 6 Mar 2017 19:26:03 +0300 Subject: [PATCH 08/19] joggling packages wip --- src/SqlSquare/AST.purs | 572 +++--------------------------- src/SqlSquare/BinaryOperator.purs | 37 ++ src/SqlSquare/Case.purs | 17 + src/SqlSquare/Constructors.purs | 116 ++++++ src/SqlSquare/GroupBy.purs | 20 ++ src/SqlSquare/JoinType.purs | 19 + src/SqlSquare/Lenses.purs | 231 ++++++++++++ src/SqlSquare/OrderBy.purs | 24 ++ src/SqlSquare/OrderType.purs | 13 + src/SqlSquare/Projection.purs | 19 + src/SqlSquare/Relation.purs | 74 ++++ src/SqlSquare/Search.purs | 3 +- src/SqlSquare/UnaryOperator.purs | 22 ++ 13 files changed, 637 insertions(+), 530 deletions(-) create mode 100644 src/SqlSquare/BinaryOperator.purs create mode 100644 src/SqlSquare/Case.purs create mode 100644 src/SqlSquare/Constructors.purs create mode 100644 src/SqlSquare/GroupBy.purs create mode 100644 src/SqlSquare/JoinType.purs create mode 100644 src/SqlSquare/Lenses.purs create mode 100644 src/SqlSquare/OrderBy.purs create mode 100644 src/SqlSquare/OrderType.purs create mode 100644 src/SqlSquare/Projection.purs create mode 100644 src/SqlSquare/Relation.purs create mode 100644 src/SqlSquare/UnaryOperator.purs diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index 2bed1e3..2402409 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -1,252 +1,50 @@ -module SqlSquare.AST where +module SqlSquare.AST + ( BinopR + , UnopR + , InvokeFunctionR + , MatchR + , SwitchR + , LetR + , SelectR + , SqlF(..) + , Sql + , printF + , print + , module SqlSquare.Utils + , module OT + , module JT + , module SqlSquare.BinaryOperator + , module SqlSquare.UnaryOperator + , module SqlSquare.GroupBy + , module SqlSquare.Case + , module SqlSquare.OrderBy + , module SqlSquare.Projection + , module SqlSquare.Relation + ) where import Prelude import Data.Bifunctor (bimap) -import Data.Either (Either, either) import Data.Foldable as F import Data.Functor.Mu (Mu) import Data.Maybe (Maybe(..)) -import Data.List (List(..), fromFoldable) -import Data.Newtype (class Newtype, wrap, unwrap) -import Data.NonEmpty as NE -import Data.Path.Pathy (AbsFile, RelFile, Unsandboxed, unsafePrintPath) -import Data.Lens (Prism', prism', Lens', lens, Iso', iso) +import Data.List as L import Data.String.Regex as RX import Data.String.Regex.Flags as RXF import Data.String.Regex.Unsafe as URX import SqlSquare.Utils (type (×), (×), (∘), (⋙)) - -import Matryoshka (class Recursive, class Corecursive, Algebra, cata, embed, project) - -type FUPath = Either (RelFile Unsandboxed) (AbsFile Unsandboxed) - -data OrderType - = ASC - | DESC - - -printOrderType ∷ OrderType → String -printOrderType = case _ of - ASC → "asc" - DESC → "desc" - -derive instance eqOrderType ∷ Eq OrderType -derive instance ordOrderType ∷ Ord OrderType - -data JoinType - = LeftJoin - | RightJoin - | InnerJoin - | FullJoin - -printJoinType ∷ JoinType → String -printJoinType = case _ of - LeftJoin → "left join" - RightJoin → "right join" - FullJoin → "full join" - InnerJoin → "inner join" - -derive instance eqJoinType ∷ Eq JoinType -derive instance ordJoinType ∷ Ord JoinType - -data BinaryOperator - = IfUndefined - | Range - | Or - | And - | Eq - | Neq - | Ge - | Gt - | Le - | Lt - | Concat - | Plus - | Minus - | Mult - | Div - | Mod - | Pow - | In - | FieldDeref - | IndexDeref - | Limit - | Offset - | Sample - | Union - | UnionAll - | Intersect - | IntersectAll - | Except - | UnshiftMap - -derive instance eqBinaryOperator ∷ Eq BinaryOperator -derive instance ordBinaryOperator ∷ Ord BinaryOperator - -data UnaryOperator - = Not - | Exists - | Positive - | Negative - | Distinct - | FlattenMapKeys - | FlattenMapValues - | ShiftMapKeys - | ShiftMapValues - | FlattenArrayIndices - | FlattenArrayValues - | ShiftArrayIndices - | ShiftArrayValues - | UnshiftArray - -derive instance eqUnaryOperator ∷ Eq UnaryOperator -derive instance ordUnaryOperator ∷ Ord UnaryOperator - -_Newtype ∷ ∀ n t. Newtype n t ⇒ Iso' n t -_Newtype = iso unwrap wrap - -newtype GroupBy a = GroupBy { keys ∷ List a, having ∷ Maybe a } -derive instance newtypeGroupBy ∷ Newtype (GroupBy a) _ -derive instance functorGroupBy ∷ Functor GroupBy -derive instance eqGroupBy ∷ Eq a ⇒ Eq (GroupBy a) -derive instance ordGroupBy ∷ Ord a ⇒ Ord (GroupBy a) - -_GroupBy ∷ ∀ a. Iso' (GroupBy a) {keys ∷ List a, having ∷ Maybe a} -_GroupBy = _Newtype - -printGroupBy ∷ Algebra GroupBy String -printGroupBy (GroupBy { keys, having }) = - F.intercalate ", " keys <> F.foldMap (" having " <> _) having - - -newtype Case a = Case { cond ∷ a, expr ∷ a } - -derive instance functorCase ∷ Functor Case -derive instance newtypeCase ∷ Newtype (Case a) _ -derive instance eqCase ∷ Eq a ⇒ Eq (Case a) -derive instance ordCase ∷ Ord a ⇒ Ord (Case a) - -_Case ∷ ∀ a. Iso' (Case a) { cond ∷ a, expr ∷ a } -_Case = _Newtype - -printCase ∷ Algebra Case String -printCase (Case { cond, expr }) = " when " <> cond <> " then " <> expr - - -newtype OrderBy a = OrderBy (NE.NonEmpty List (OrderType × a)) - -derive instance functorOrderBy ∷ Functor OrderBy -derive instance newtypeOrderBy ∷ Newtype (OrderBy a) _ -derive instance eqOrderBy ∷ Eq a ⇒ Eq (OrderBy a) -derive instance ordOrderBy ∷ Ord a ⇒ Ord (OrderBy a) - -_OrderBy ∷ ∀ a. Iso' (OrderBy a) (NE.NonEmpty List (OrderType × a)) -_OrderBy = _Newtype - -printOrderBy ∷ Algebra OrderBy String -printOrderBy (OrderBy lst) = - F.intercalate ", " $ lst <#> \(ot × a) → printOrderType ot <> " " <> a - -newtype Projection a = Projection { expr ∷ a, alias ∷ Maybe String } - -derive instance functorProjection ∷ Functor Projection -derive instance newtypeProjection ∷ Newtype (Projection a) _ -derive instance eqProjection ∷ Eq a ⇒ Eq (Projection a) -derive instance ordProjection ∷ Ord a ⇒ Ord (Projection a) - -_Projection ∷ ∀ a. Iso' (Projection a) { expr ∷ a, alias ∷ Maybe String } -_Projection = _Newtype - -printProjection ∷ Algebra Projection String -printProjection (Projection { expr, alias }) = expr <> F.foldMap (" as " <> _) alias - - -type JoinRelR a = - { left ∷ SqlRelation a - , right ∷ SqlRelation a - , joinType ∷ JoinType - , clause ∷ a - } - -type ExprRelR a = - { expr ∷ a - , aliasName ∷ String - } - -type TableRelR a = - { tablePath ∷ FUPath - , alias ∷ Maybe String - } - -type VariRelR a = - { vari ∷ String - , alias ∷ Maybe String - } - -type IdentRelR = - { ident ∷ String - , alias ∷ Maybe String - } - -data SqlRelation a - = JoinRelation (JoinRelR a) - | ExprRelation (ExprRelR a) - | TableRelation (TableRelR a) - | VariRelation (VariRelR a) - | IdentRelation IdentRelR - -_JoinRelation ∷ ∀ a. Prism' (SqlRelation a) (JoinRelR a) -_JoinRelation = prism' JoinRelation case _ of - JoinRelation r → Just r - _ → Nothing - -_ExprRelation ∷ ∀ a. Prism' (SqlRelation a) (ExprRelR a) -_ExprRelation = prism' ExprRelation case _ of - ExprRelation r → Just r - _ → Nothing - -_TableRelation ∷ ∀ a. Prism' (SqlRelation a) (TableRelR a) -_TableRelation = prism' TableRelation case _ of - TableRelation r → Just r - _ → Nothing - -_VariRelation ∷ ∀ a. Prism' (SqlRelation a) (VariRelR a) -_VariRelation = prism' VariRelation case _ of - VariRelation r → Just r - _ → Nothing - -_IdentRelation ∷ ∀ a. Prism' (SqlRelation a) IdentRelR -_IdentRelation = prism' IdentRelation case _ of - IdentRelation r → Just r - _ → Nothing - -derive instance functorSqlRelation ∷ Functor SqlRelation -derive instance eqSqlRelation ∷ Eq a ⇒ Eq (SqlRelation a) -derive instance ordSqlRelation ∷ Ord a ⇒ Ord (SqlRelation a) - -printRelation ∷ Algebra SqlRelation String -printRelation = case _ of - ExprRelation {expr, aliasName} → - "(" <> expr <> ") as " <> aliasName - VariRelation { vari, alias} → - vari <> F.foldMap (" as " <> _) alias - TableRelation { tablePath, alias } → - "`" - <> either unsafePrintPath unsafePrintPath tablePath - <> "`" - <> F.foldMap (" as " <> _) alias - IdentRelation { ident, alias } → - ident <> F.foldMap (" as " <> _) alias - JoinRelation { left, right, joinType, clause } → - printRelation left - <> " " - <> printJoinType joinType - <> " " - <> printRelation right - <> " on " - <> clause +import SqlSquare.OrderType as OT +import SqlSquare.JoinType as JT +import SqlSquare.BinaryOperator (BinaryOperator(..)) +import SqlSquare.UnaryOperator (UnaryOperator(..)) +import SqlSquare.GroupBy (GroupBy(..), printGroupBy) +import SqlSquare.Case (Case(..), printCase) +import SqlSquare.OrderBy (OrderBy(..), printOrderBy) +import SqlSquare.Projection (Projection(..), printProjection) +import SqlSquare.Relation (Relation(..), printRelation, FUPath) + +import Matryoshka (class Recursive, Algebra, cata) type BinopR a = { lhs ∷ a @@ -261,17 +59,17 @@ type UnopR a = type InvokeFunctionR a = { name ∷ String - , args ∷ List a + , args ∷ L.List a } type MatchR a = { expr ∷ a - , cases ∷ List (Case a) + , cases ∷ L.List (Case a) , else_ ∷ Maybe a } type SwitchR a = - { cases ∷ List (Case a) + { cases ∷ L.List (Case a) , else_ ∷ Maybe a } @@ -283,99 +81,17 @@ type LetR a = type SelectR a = { isDistinct ∷ Boolean - , projections ∷ List (Projection a) - , relations ∷ Maybe (SqlRelation a) + , projections ∷ L.List (Projection a) + , relations ∷ Maybe (Relation a) , filter ∷ Maybe a , groupBy ∷ Maybe (GroupBy a) , orderBy ∷ Maybe (OrderBy a) } - -_lhs ∷ ∀ a r. Lens' { lhs ∷ a |r } a -_lhs = lens _.lhs _{ lhs = _ } - -_rhs ∷ ∀ a r. Lens' { rhs ∷ a |r } a -_rhs = lens _.rhs _{ rhs = _ } - -_op ∷ ∀ a r. Lens' { op ∷ a | r } a -_op = lens _.op _{ op = _ } - -_expr ∷ ∀ a r. Lens' { expr ∷ a|r } a -_expr = lens _.expr _{ expr = _ } - -_name ∷ ∀ a r. Lens' { name ∷ a|r } a -_name = lens _.name _{ name = _ } - -_args ∷ ∀ a r. Lens' { args ∷ a|r } a -_args = lens _.args _{ args = _ } - -_cases ∷ ∀ a r. Lens' { cases ∷ a|r } a -_cases = lens _.cases _{ cases = _ } - -_else ∷ ∀ a r. Lens' { else_ ∷ a|r } a -_else = lens _.else_ _{ else_ = _ } - -_ident ∷ ∀ a r. Lens' { ident ∷ a|r } a -_ident = lens _.ident _{ ident = _ } - -_bindTo ∷ ∀ a r. Lens' { bindTo ∷ a|r } a -_bindTo = lens _.bindTo _{ bindTo = _ } - -_in ∷ ∀ a r. Lens' { in_ ∷ a|r } a -_in = lens _.in_ _{ in_ = _ } -- __O_M_G__ - -_isDistinct ∷ ∀ a r. Lens' { isDistinct ∷ a|r } a -_isDistinct = lens _.isDistinct _{ isDistinct = _ } - -_projections ∷ ∀ a r. Lens' { projections ∷ a|r } a -_projections = lens _.projections _{ projections = _ } - -_relations ∷ ∀ a r. Lens' { relations ∷ a|r } a -_relations = lens _.relations _{ relations = _ } - -_filter ∷ ∀ a r. Lens' { filter ∷ a|r } a -_filter = lens _.filter _{ filter = _ } - -_groupBy ∷ ∀ a r. Lens' { groupBy ∷ a|r } a -_groupBy = lens _.groupBy _{ groupBy = _ } - -_orderBy ∷ ∀ a r. Lens' { orderBy ∷ a|r } a -_orderBy = lens _.orderBy _{ orderBy = _ } - -_keys ∷ ∀ a r. Lens' { keys ∷ a|r } a -_keys = lens _.keys _{ keys = _ } - -_having ∷ ∀ a r. Lens' { having ∷ a|r } a -_having = lens _.having _{ having = _ } - -_cond ∷ ∀ a r. Lens' { cond ∷ a|r } a -_cond = lens _.cond _{ cond = _ } - -_alias ∷ ∀ a r. Lens' { alias ∷ a|r } a -_alias = lens _.alias _{ alias = _ } - -_aliasName ∷ ∀ a r. Lens' { aliasName ∷ a|r } a -_aliasName = lens _.aliasName _{ aliasName = _ } - -_left ∷ ∀ a r. Lens' { left ∷ a|r } a -_left = lens _.left _{ left = _ } - -_right ∷ ∀ a r. Lens' { right ∷ a|r } a -_right = lens _.right _{ right = _ } - -_joinType ∷ ∀ a r. Lens' { joinType ∷ a|r } a -_joinType = lens _.joinType _{ joinType = _ } - -_clause ∷ ∀ a r. Lens' { clause ∷ a|r } a -_clause = lens _.clause _{ clause = _ } - -_tablePath ∷ ∀ a r. Lens' { tablePath ∷ a|r } a -_tablePath = lens _.tablePath _{ tablePath = _ } - data SqlF a - = SetLiteral (List a) - | ArrayLiteral (List a) - | MapLiteral (List (a × a)) + = SetLiteral (L.List a) + | ArrayLiteral (L.List a) + | MapLiteral (L.List (a × a)) | Splice (Maybe a) | Binop (BinopR a) | Unop (UnopR a) @@ -396,101 +112,6 @@ data SqlF a derive instance eqSqlF ∷ Eq a ⇒ Eq (SqlF a) derive instance ordSqlF ∷ Ord a ⇒ Ord (SqlF a) -_SetLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List t) -_SetLiteral = prism' (embed ∘ SetLiteral) $ project ⋙ case _ of - SetLiteral lst → Just lst - _ → Nothing - -_ArrayLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List t) -_ArrayLiteral = prism' (embed ∘ ArrayLiteral) $ project ⋙ case _ of - ArrayLiteral lst → Just lst - _ → Nothing - -_MapLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List (t × t)) -_MapLiteral = prism' (embed ∘ MapLiteral) $ project ⋙ case _ of - MapLiteral tpls → Just tpls - _ → Nothing - -_Splice ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (Maybe t) -_Splice = prism' (embed ∘ Splice) $ project ⋙ case _ of - Splice m → Just m - _ → Nothing - -_Binop ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (BinopR t) -_Binop = prism' (embed ∘ Binop) $ project ⋙ case _ of - Binop b → Just b - _ → Nothing - -_Unop ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (UnopR t) -_Unop = prism' (embed ∘ Unop) $ project ⋙ case _ of - Unop r → Just r - _ → Nothing - -_Ident ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t String -_Ident = prism' (embed ∘ Ident) $ project ⋙ case _ of - Ident s → Just s - _ → Nothing - -_InvokeFunction ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (InvokeFunctionR t) -_InvokeFunction = prism' (embed ∘ InvokeFunction) $ project ⋙ case _ of - InvokeFunction r → Just r - _ → Nothing - -_Match ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (MatchR t) -_Match = prism' (embed ∘ Match) $ project ⋙ case _ of - Match r → Just r - _ → Nothing - -_Switch ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (SwitchR t) -_Switch = prism' (embed ∘ Switch) $ project ⋙ case _ of - Switch r → Just r - _ → Nothing - -_Let ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (LetR t) -_Let = prism' (embed ∘ Let) $ project ⋙ case _ of - Let r → Just r - _ → Nothing - -_IntLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Int -_IntLiteral = prism' (embed ∘ IntLiteral) $ project ⋙ case _ of - IntLiteral r → Just r - _ → Nothing - -_FloatLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Number -_FloatLiteral = prism' (embed ∘ FloatLiteral) $ project ⋙ case _ of - FloatLiteral r → Just r - _ → Nothing - -_StringLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t String -_StringLiteral = prism' (embed ∘ StringLiteral) $ project ⋙ case _ of - StringLiteral r → Just r - _ → Nothing - -_NullLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Unit -_NullLiteral = prism' (const $ embed $ NullLiteral) $ project ⋙ case _ of - NullLiteral → Just unit - _ → Nothing - -_BoolLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Boolean -_BoolLiteral = prism' (embed ∘ BoolLiteral) $ project ⋙ case _ of - BoolLiteral b → Just b - _ → Nothing - -_Vari ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t String -_Vari = prism' (embed ∘ Vari) $ project ⋙ case _ of - Vari r → Just r - _ → Nothing - -_Select ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (SelectR t) -_Select = prism' (embed ∘ Select) $ project ⋙ case _ of - Select r → Just r - _ → Nothing - -_Parens ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t t -_Parens = prism' (embed ∘ Parens) $ project ⋙ case _ of - Parens t → Just t - _ → Nothing - instance functorAST ∷ Functor SqlF where map f = case _ of Select { isDistinct, projections, relations, filter, groupBy, orderBy } → @@ -660,114 +281,7 @@ printF = case _ of renderString str = "\"" <> replaceAll "\"" "\\\"" str <> "\"" - type Sql = Mu SqlF print ∷ ∀ t. Recursive t SqlF ⇒ t → String print = cata printF - --- | constructors -vari_ ∷ ∀ t. Corecursive t SqlF ⇒ String → t -vari_ s = embed $ Vari s - -bool_ ∷ ∀ t. Corecursive t SqlF ⇒ Boolean → t -bool_ b = embed $ BoolLiteral b - -null_ ∷ ∀ t. Corecursive t SqlF ⇒ t -null_ = embed NullLiteral - -int_ ∷ ∀ t. Corecursive t SqlF ⇒ Int → t -int_ i = embed $ IntLiteral i - -num_ ∷ ∀ t. Corecursive t SqlF ⇒ Number → t -num_ i = embed $ FloatLiteral i - -string_ ∷ ∀ t. Corecursive t SqlF ⇒ String → t -string_ s = embed $ StringLiteral s - -unop_ ∷ ∀ t. Corecursive t SqlF ⇒ UnaryOperator → t → t -unop_ op expr = embed $ Unop { op, expr } - -binop_ ∷ ∀ t. Corecursive t SqlF ⇒ BinaryOperator → t → t → t -binop_ op lhs rhs = embed $ Binop { op, lhs, rhs } - -set_ ∷ ∀ t f. (Corecursive t SqlF, F.Foldable f) ⇒ f t → t -set_ l = embed $ SetLiteral $ fromFoldable l - -array_ ∷ ∀ t f. (Corecursive t SqlF, F.Foldable f) ⇒ f t → t -array_ l = embed $ ArrayLiteral $ fromFoldable l - -splice_ ∷ ∀ t. Corecursive t SqlF ⇒ Maybe t → t -splice_ m = embed $ Splice m - -ident_ ∷ ∀ t. Corecursive t SqlF ⇒ String → t -ident_ i = embed $ Ident i - -match_ ∷ ∀ t. Corecursive t SqlF ⇒ t → List (Case t) → Maybe t → t -match_ expr cases else_ = embed $ Match { expr, cases, else_ } - -switch_ ∷ ∀ t. Corecursive t SqlF ⇒ List (Case t) → Maybe t → t -switch_ cases else_ = embed $ Switch { cases, else_ } - -let_ ∷ ∀ t. Corecursive t SqlF ⇒ String → t → t → t -let_ ident bindTo in_ = embed $ Let { ident, bindTo, in_ } - -invokeFunction_ ∷ ∀ t. Corecursive t SqlF ⇒ String → List t → t -invokeFunction_ name args = embed $ InvokeFunction {name, args} - --- when_ (bool true) # then_ (num 1.0) :P -when_ ∷ ∀ t. t → (t → Case t) -when_ cond = Case ∘ { cond, expr: _ } - -then_ ∷ ∀ t. (t → Case t) → t → Case t -then_ f t = f t - -select_ - ∷ ∀ t f - . (Corecursive t SqlF, F.Foldable f) - ⇒ Boolean - → f (Projection t) - → Maybe (SqlRelation t) - → Maybe t - → Maybe (GroupBy t) - → Maybe (OrderBy t) - → t -select_ isDistinct projections relations filter groupBy orderBy = - embed $ Select { isDistinct - , projections: fromFoldable projections - , relations - , filter - , groupBy - , orderBy - } - - -select ∷ ∀ t. Corecursive t SqlF ⇒ SelectR t → t -select = embed ∘ Select - --- project_ (ident "foo") # as_ "bar" --- project_ (ident "foo") -project_ ∷ ∀ t. t → Projection t -project_ expr = Projection {expr, alias: Nothing} - -as_ ∷ ∀ t. String → Projection t → Projection t -as_ s (Projection r) = Projection r { alias = Just s } - -groupBy_ ∷ ∀ t f. F.Foldable f ⇒ f t → GroupBy t -groupBy_ f = GroupBy { keys: fromFoldable f, having: Nothing } - -having_ ∷ ∀ t. t → GroupBy t → GroupBy t -having_ t (GroupBy r) = GroupBy r{ having = Just t } - -buildSelect ∷ ∀ t. Corecursive t SqlF ⇒ (SelectR t → SelectR t) → t -buildSelect f = - select $ f { isDistinct: false - , projections: Nil - , relations: Nothing - , filter: Nothing - , groupBy: Nothing - , orderBy: Nothing - } - -pars_ ∷ ∀ t. Corecursive t SqlF ⇒ t → t -pars_ = embed ∘ Parens diff --git a/src/SqlSquare/BinaryOperator.purs b/src/SqlSquare/BinaryOperator.purs new file mode 100644 index 0000000..d0e9003 --- /dev/null +++ b/src/SqlSquare/BinaryOperator.purs @@ -0,0 +1,37 @@ +module SqlSquare.BinaryOperator where + +import Prelude + +data BinaryOperator + = IfUndefined + | Range + | Or + | And + | Eq + | Neq + | Ge + | Gt + | Le + | Lt + | Concat + | Plus + | Minus + | Mult + | Div + | Mod + | Pow + | In + | FieldDeref + | IndexDeref + | Limit + | Offset + | Sample + | Union + | UnionAll + | Intersect + | IntersectAll + | Except + | UnshiftMap + +derive instance eqBinaryOperator ∷ Eq BinaryOperator +derive instance ordBinaryOperator ∷ Ord BinaryOperator diff --git a/src/SqlSquare/Case.purs b/src/SqlSquare/Case.purs new file mode 100644 index 0000000..e04fc30 --- /dev/null +++ b/src/SqlSquare/Case.purs @@ -0,0 +1,17 @@ +module SqlSquare.Case where + +import Prelude + +import Data.Newtype (class Newtype) + +import Matryoshka (Algebra) + +newtype Case a = Case { cond ∷ a, expr ∷ a } + +derive instance functorCase ∷ Functor Case +derive instance newtypeCase ∷ Newtype (Case a) _ +derive instance eqCase ∷ Eq a ⇒ Eq (Case a) +derive instance ordCase ∷ Ord a ⇒ Ord (Case a) + +printCase ∷ Algebra Case String +printCase (Case { cond, expr }) = " when " <> cond <> " then " <> expr diff --git a/src/SqlSquare/Constructors.purs b/src/SqlSquare/Constructors.purs new file mode 100644 index 0000000..491a676 --- /dev/null +++ b/src/SqlSquare/Constructors.purs @@ -0,0 +1,116 @@ +module SqlSquare.Constructors where + +import Prelude + +import Data.Foldable as F +import Data.List as L +import Data.Maybe (Maybe(..)) + +import Matryoshka (class Corecursive, embed) + +import SqlSquare.AST (SqlF(..), Relation, GroupBy(..), OrderBy, BinaryOperator, UnaryOperator, (∘), SelectR, Case(..), Projection(..)) + +vari ∷ ∀ t. Corecursive t SqlF ⇒ String → t +vari s = embed $ Vari s + +bool ∷ ∀ t. Corecursive t SqlF ⇒ Boolean → t +bool b = embed $ BoolLiteral b + +null ∷ ∀ t. Corecursive t SqlF ⇒ t +null = embed NullLiteral + +int ∷ ∀ t. Corecursive t SqlF ⇒ Int → t +int i = embed $ IntLiteral i + +num ∷ ∀ t. Corecursive t SqlF ⇒ Number → t +num i = embed $ FloatLiteral i + +string ∷ ∀ t. Corecursive t SqlF ⇒ String → t +string s = embed $ StringLiteral s + +unop ∷ ∀ t. Corecursive t SqlF ⇒ UnaryOperator → t → t +unop op expr = embed $ Unop { op, expr } + +binop ∷ ∀ t. Corecursive t SqlF ⇒ BinaryOperator → t → t → t +binop op lhs rhs = embed $ Binop { op, lhs, rhs } + +set ∷ ∀ t f. (Corecursive t SqlF, F.Foldable f) ⇒ f t → t +set l = embed $ SetLiteral $ L.fromFoldable l + +array ∷ ∀ t f. (Corecursive t SqlF, F.Foldable f) ⇒ f t → t +array l = embed $ ArrayLiteral $ L.fromFoldable l + +splice ∷ ∀ t. Corecursive t SqlF ⇒ Maybe t → t +splice m = embed $ Splice m + +ident ∷ ∀ t. Corecursive t SqlF ⇒ String → t +ident i = embed $ Ident i + +match ∷ ∀ t. Corecursive t SqlF ⇒ t → L.List (Case t) → Maybe t → t +match expr cases else_ = embed $ Match { expr, cases, else_ } + +switch ∷ ∀ t. Corecursive t SqlF ⇒ L.List (Case t) → Maybe t → t +switch cases else_ = embed $ Switch { cases, else_ } + +let_ ∷ ∀ t. Corecursive t SqlF ⇒ String → t → t → t +let_ id bindTo in_ = embed $ Let { ident: id, bindTo, in_ } + +invokeFunction ∷ ∀ t. Corecursive t SqlF ⇒ String → L.List t → t +invokeFunction name args = embed $ InvokeFunction {name, args} + +-- when (bool true) # then (num 1.0) :P +when ∷ ∀ t. t → (t → Case t) +when cond = Case ∘ { cond, expr: _ } + +then_ ∷ ∀ t. (t → Case t) → t → Case t +then_ f t = f t + +select_ + ∷ ∀ t f + . (Corecursive t SqlF, F.Foldable f) + ⇒ Boolean + → f (Projection t) + → Maybe (Relation t) + → Maybe t + → Maybe (GroupBy t) + → Maybe (OrderBy t) + → t +select_ isDistinct projections relations filter gb orderBy = + embed $ Select { isDistinct + , projections: L.fromFoldable projections + , relations + , filter + , groupBy: gb + , orderBy + } + + +select ∷ ∀ t. Corecursive t SqlF ⇒ SelectR t → t +select = embed ∘ Select + +-- project (ident "foo") # as "bar" +-- project (ident "foo") +project ∷ ∀ t. t → Projection t +project expr = Projection {expr, alias: Nothing} + +as ∷ ∀ t. String → Projection t → Projection t +as s (Projection r) = Projection r { alias = Just s } + +groupBy ∷ ∀ t f. F.Foldable f ⇒ f t → GroupBy t +groupBy f = GroupBy { keys: L.fromFoldable f, having: Nothing } + +having ∷ ∀ t. t → GroupBy t → GroupBy t +having t (GroupBy r) = GroupBy r{ having = Just t } + +buildSelect ∷ ∀ t. Corecursive t SqlF ⇒ (SelectR t → SelectR t) → t +buildSelect f = + select $ f { isDistinct: false + , projections: L.Nil + , relations: Nothing + , filter: Nothing + , groupBy: Nothing + , orderBy: Nothing + } + +pars ∷ ∀ t. Corecursive t SqlF ⇒ t → t +pars = embed ∘ Parens diff --git a/src/SqlSquare/GroupBy.purs b/src/SqlSquare/GroupBy.purs new file mode 100644 index 0000000..e12ad9f --- /dev/null +++ b/src/SqlSquare/GroupBy.purs @@ -0,0 +1,20 @@ +module SqlSquare.GroupBy where + +import Prelude + +import Data.Foldable as F +import Data.List as L +import Data.Maybe (Maybe) +import Data.Newtype (class Newtype) + +import Matryoshka (Algebra) + +newtype GroupBy a = GroupBy { keys ∷ L.List a, having ∷ Maybe a } +derive instance newtypeGroupBy ∷ Newtype (GroupBy a) _ +derive instance functorGroupBy ∷ Functor GroupBy +derive instance eqGroupBy ∷ Eq a ⇒ Eq (GroupBy a) +derive instance ordGroupBy ∷ Ord a ⇒ Ord (GroupBy a) + +printGroupBy ∷ Algebra GroupBy String +printGroupBy (GroupBy { keys, having }) = + F.intercalate ", " keys <> F.foldMap (" having " <> _) having diff --git a/src/SqlSquare/JoinType.purs b/src/SqlSquare/JoinType.purs new file mode 100644 index 0000000..29075db --- /dev/null +++ b/src/SqlSquare/JoinType.purs @@ -0,0 +1,19 @@ +module SqlSquare.JoinType where + +import Prelude + +data JoinType + = LeftJoin + | RightJoin + | InnerJoin + | FullJoin + +printJoinType ∷ JoinType → String +printJoinType = case _ of + LeftJoin → "left join" + RightJoin → "right join" + FullJoin → "full join" + InnerJoin → "inner join" + +derive instance eqJoinType ∷ Eq JoinType +derive instance ordJoinType ∷ Ord JoinType diff --git a/src/SqlSquare/Lenses.purs b/src/SqlSquare/Lenses.purs new file mode 100644 index 0000000..7d51821 --- /dev/null +++ b/src/SqlSquare/Lenses.purs @@ -0,0 +1,231 @@ +module SqlSquare.Lenses where + +import Data.Newtype (class Newtype, wrap, unwrap) + +import Data.Lens (Prism', prism', Lens', lens, Iso', iso) + +_Newtype ∷ ∀ n t. Newtype n t ⇒ Iso' n t +_Newtype = iso unwrap wrap + + +{- +_GroupBy ∷ ∀ a. Iso' (GroupBy a) {keys ∷ List a, having ∷ Maybe a} +_GroupBy = _Newtype + +_Case ∷ ∀ a. Iso' (Case a) { cond ∷ a, expr ∷ a } +_Case = _Newtype + +_OrderBy ∷ ∀ a. Iso' (OrderBy a) (NE.NonEmpty List (OrderType × a)) +_OrderBy = _Newtype + + +_Projection ∷ ∀ a. Iso' (Projection a) { expr ∷ a, alias ∷ Maybe String } +_Projection = _Newtype + + +_JoinRelation ∷ ∀ a. Prism' (SqlRelation a) (JoinRelR a) +_JoinRelation = prism' JoinRelation case _ of + JoinRelation r → Just r + _ → Nothing + +_ExprRelation ∷ ∀ a. Prism' (SqlRelation a) (ExprRelR a) +_ExprRelation = prism' ExprRelation case _ of + ExprRelation r → Just r + _ → Nothing + +_TableRelation ∷ ∀ a. Prism' (SqlRelation a) (TableRelR a) +_TableRelation = prism' TableRelation case _ of + TableRelation r → Just r + _ → Nothing + +_VariRelation ∷ ∀ a. Prism' (SqlRelation a) (VariRelR a) +_VariRelation = prism' VariRelation case _ of + VariRelation r → Just r + _ → Nothing + +_IdentRelation ∷ ∀ a. Prism' (SqlRelation a) IdentRelR +_IdentRelation = prism' IdentRelation case _ of + IdentRelation r → Just r + _ → Nothing +-} + +{- +_lhs ∷ ∀ a r. Lens' { lhs ∷ a |r } a +_lhs = lens _.lhs _{ lhs = _ } + +_rhs ∷ ∀ a r. Lens' { rhs ∷ a |r } a +_rhs = lens _.rhs _{ rhs = _ } + +_op ∷ ∀ a r. Lens' { op ∷ a | r } a +_op = lens _.op _{ op = _ } + +_expr ∷ ∀ a r. Lens' { expr ∷ a|r } a +_expr = lens _.expr _{ expr = _ } + +_name ∷ ∀ a r. Lens' { name ∷ a|r } a +_name = lens _.name _{ name = _ } + +_args ∷ ∀ a r. Lens' { args ∷ a|r } a +_args = lens _.args _{ args = _ } + +_cases ∷ ∀ a r. Lens' { cases ∷ a|r } a +_cases = lens _.cases _{ cases = _ } + +_else ∷ ∀ a r. Lens' { else_ ∷ a|r } a +_else = lens _.else_ _{ else_ = _ } + +_ident ∷ ∀ a r. Lens' { ident ∷ a|r } a +_ident = lens _.ident _{ ident = _ } + +_bindTo ∷ ∀ a r. Lens' { bindTo ∷ a|r } a +_bindTo = lens _.bindTo _{ bindTo = _ } + +_in ∷ ∀ a r. Lens' { in_ ∷ a|r } a +_in = lens _.in_ _{ in_ = _ } -- __O_M_G__ + +_isDistinct ∷ ∀ a r. Lens' { isDistinct ∷ a|r } a +_isDistinct = lens _.isDistinct _{ isDistinct = _ } + +_projections ∷ ∀ a r. Lens' { projections ∷ a|r } a +_projections = lens _.projections _{ projections = _ } + +_relations ∷ ∀ a r. Lens' { relations ∷ a|r } a +_relations = lens _.relations _{ relations = _ } + +_filter ∷ ∀ a r. Lens' { filter ∷ a|r } a +_filter = lens _.filter _{ filter = _ } + +_groupBy ∷ ∀ a r. Lens' { groupBy ∷ a|r } a +_groupBy = lens _.groupBy _{ groupBy = _ } + +_orderBy ∷ ∀ a r. Lens' { orderBy ∷ a|r } a +_orderBy = lens _.orderBy _{ orderBy = _ } + +_keys ∷ ∀ a r. Lens' { keys ∷ a|r } a +_keys = lens _.keys _{ keys = _ } + +_having ∷ ∀ a r. Lens' { having ∷ a|r } a +_having = lens _.having _{ having = _ } + +_cond ∷ ∀ a r. Lens' { cond ∷ a|r } a +_cond = lens _.cond _{ cond = _ } + +_alias ∷ ∀ a r. Lens' { alias ∷ a|r } a +_alias = lens _.alias _{ alias = _ } + +_aliasName ∷ ∀ a r. Lens' { aliasName ∷ a|r } a +_aliasName = lens _.aliasName _{ aliasName = _ } + +_left ∷ ∀ a r. Lens' { left ∷ a|r } a +_left = lens _.left _{ left = _ } + +_right ∷ ∀ a r. Lens' { right ∷ a|r } a +_right = lens _.right _{ right = _ } + +_joinType ∷ ∀ a r. Lens' { joinType ∷ a|r } a +_joinType = lens _.joinType _{ joinType = _ } + +_clause ∷ ∀ a r. Lens' { clause ∷ a|r } a +_clause = lens _.clause _{ clause = _ } + +_tablePath ∷ ∀ a r. Lens' { tablePath ∷ a|r } a +_tablePath = lens _.tablePath _{ tablePath = _ } + + +-} +{- +_SetLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List t) +_SetLiteral = prism' (embed ∘ SetLiteral) $ project ⋙ case _ of + SetLiteral lst → Just lst + _ → Nothing + +_ArrayLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List t) +_ArrayLiteral = prism' (embed ∘ ArrayLiteral) $ project ⋙ case _ of + ArrayLiteral lst → Just lst + _ → Nothing + +_MapLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List (t × t)) +_MapLiteral = prism' (embed ∘ MapLiteral) $ project ⋙ case _ of + MapLiteral tpls → Just tpls + _ → Nothing + +_Splice ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (Maybe t) +_Splice = prism' (embed ∘ Splice) $ project ⋙ case _ of + Splice m → Just m + _ → Nothing + +_Binop ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (BinopR t) +_Binop = prism' (embed ∘ Binop) $ project ⋙ case _ of + Binop b → Just b + _ → Nothing + +_Unop ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (UnopR t) +_Unop = prism' (embed ∘ Unop) $ project ⋙ case _ of + Unop r → Just r + _ → Nothing + +_Ident ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t String +_Ident = prism' (embed ∘ Ident) $ project ⋙ case _ of + Ident s → Just s + _ → Nothing + +_InvokeFunction ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (InvokeFunctionR t) +_InvokeFunction = prism' (embed ∘ InvokeFunction) $ project ⋙ case _ of + InvokeFunction r → Just r + _ → Nothing + +_Match ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (MatchR t) +_Match = prism' (embed ∘ Match) $ project ⋙ case _ of + Match r → Just r + _ → Nothing + +_Switch ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (SwitchR t) +_Switch = prism' (embed ∘ Switch) $ project ⋙ case _ of + Switch r → Just r + _ → Nothing + +_Let ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (LetR t) +_Let = prism' (embed ∘ Let) $ project ⋙ case _ of + Let r → Just r + _ → Nothing + +_IntLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Int +_IntLiteral = prism' (embed ∘ IntLiteral) $ project ⋙ case _ of + IntLiteral r → Just r + _ → Nothing + +_FloatLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Number +_FloatLiteral = prism' (embed ∘ FloatLiteral) $ project ⋙ case _ of + FloatLiteral r → Just r + _ → Nothing + +_StringLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t String +_StringLiteral = prism' (embed ∘ StringLiteral) $ project ⋙ case _ of + StringLiteral r → Just r + _ → Nothing + +_NullLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Unit +_NullLiteral = prism' (const $ embed $ NullLiteral) $ project ⋙ case _ of + NullLiteral → Just unit + _ → Nothing + +_BoolLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Boolean +_BoolLiteral = prism' (embed ∘ BoolLiteral) $ project ⋙ case _ of + BoolLiteral b → Just b + _ → Nothing + +_Vari ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t String +_Vari = prism' (embed ∘ Vari) $ project ⋙ case _ of + Vari r → Just r + _ → Nothing + +_Select ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (SelectR t) +_Select = prism' (embed ∘ Select) $ project ⋙ case _ of + Select r → Just r + _ → Nothing + +_Parens ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t t +_Parens = prism' (embed ∘ Parens) $ project ⋙ case _ of + Parens t → Just t + _ → Nothing +-} diff --git a/src/SqlSquare/OrderBy.purs b/src/SqlSquare/OrderBy.purs new file mode 100644 index 0000000..90a5b38 --- /dev/null +++ b/src/SqlSquare/OrderBy.purs @@ -0,0 +1,24 @@ +module SqlSquare.OrderBy where + +import Prelude + +import Data.Foldable as F +import Data.List as L +import Data.Newtype (class Newtype) +import Data.NonEmpty as NE + +import Matryoshka (Algebra) + +import SqlSquare.OrderType as OT +import SqlSquare.Utils ((×), type (×)) + +newtype OrderBy a = OrderBy (NE.NonEmpty L.List (OT.OrderType × a)) + +derive instance functorOrderBy ∷ Functor OrderBy +derive instance newtypeOrderBy ∷ Newtype (OrderBy a) _ +derive instance eqOrderBy ∷ Eq a ⇒ Eq (OrderBy a) +derive instance ordOrderBy ∷ Ord a ⇒ Ord (OrderBy a) + +printOrderBy ∷ Algebra OrderBy String +printOrderBy (OrderBy lst) = + F.intercalate ", " $ lst <#> \(ot × a) → OT.printOrderType ot <> " " <> a diff --git a/src/SqlSquare/OrderType.purs b/src/SqlSquare/OrderType.purs new file mode 100644 index 0000000..0356e0c --- /dev/null +++ b/src/SqlSquare/OrderType.purs @@ -0,0 +1,13 @@ +module SqlSquare.OrderType where + +import Prelude + +data OrderType = ASC | DESC + +printOrderType ∷ OrderType → String +printOrderType = case _ of + ASC → "asc" + DESC → "desc" + +derive instance eqOrderType ∷ Eq OrderType +derive instance ordOrderType ∷ Ord OrderType diff --git a/src/SqlSquare/Projection.purs b/src/SqlSquare/Projection.purs new file mode 100644 index 0000000..304c788 --- /dev/null +++ b/src/SqlSquare/Projection.purs @@ -0,0 +1,19 @@ +module SqlSquare.Projection where + +import Prelude + +import Data.Foldable as F +import Data.Maybe (Maybe) +import Data.Newtype (class Newtype) + +import Matryoshka (Algebra) + +newtype Projection a = Projection { expr ∷ a, alias ∷ Maybe String } + +derive instance functorProjection ∷ Functor Projection +derive instance newtypeProjection ∷ Newtype (Projection a) _ +derive instance eqProjection ∷ Eq a ⇒ Eq (Projection a) +derive instance ordProjection ∷ Ord a ⇒ Ord (Projection a) + +printProjection ∷ Algebra Projection String +printProjection (Projection { expr, alias }) = expr <> F.foldMap (" as " <> _) alias diff --git a/src/SqlSquare/Relation.purs b/src/SqlSquare/Relation.purs new file mode 100644 index 0000000..9779c02 --- /dev/null +++ b/src/SqlSquare/Relation.purs @@ -0,0 +1,74 @@ +module SqlSquare.Relation where + +import Prelude + +import Data.Either (Either, either) +import Data.Foldable as F +import Data.Maybe (Maybe) +import Data.Path.Pathy (AbsFile, RelFile, Unsandboxed, unsafePrintPath) + +import Matryoshka (Algebra) + +import SqlSquare.JoinType as JT + +type FUPath = Either (RelFile Unsandboxed) (AbsFile Unsandboxed) + +type JoinRelR a = + { left ∷ Relation a + , right ∷ Relation a + , joinType ∷ JT.JoinType + , clause ∷ a + } + +type ExprRelR a = + { expr ∷ a + , aliasName ∷ String + } + +type TableRelR a = + { tablePath ∷ FUPath + , alias ∷ Maybe String + } + +type VariRelR a = + { vari ∷ String + , alias ∷ Maybe String + } + +type IdentRelR = + { ident ∷ String + , alias ∷ Maybe String + } + +data Relation a + = JoinRelation (JoinRelR a) + | ExprRelation (ExprRelR a) + | TableRelation (TableRelR a) + | VariRelation (VariRelR a) + | IdentRelation IdentRelR + +derive instance functorRelation ∷ Functor Relation +derive instance eqRelation ∷ Eq a ⇒ Eq (Relation a) +derive instance ordRelation ∷ Ord a ⇒ Ord (Relation a) + +printRelation ∷ Algebra Relation String +printRelation = case _ of + ExprRelation {expr, aliasName} → + "(" <> expr <> ") as " <> aliasName + VariRelation { vari, alias} → + vari <> F.foldMap (" as " <> _) alias + TableRelation { tablePath, alias } → + "`" + <> either unsafePrintPath unsafePrintPath tablePath + <> "`" + <> F.foldMap (" as " <> _) alias + IdentRelation { ident, alias } → + ident <> F.foldMap (" as " <> _) alias + JoinRelation { left, right, joinType, clause } → + printRelation left + <> " " + <> JT.printJoinType joinType + <> " " + <> printRelation right + <> " on " + <> clause diff --git a/src/SqlSquare/Search.purs b/src/SqlSquare/Search.purs index f90e344..d99999e 100644 --- a/src/SqlSquare/Search.purs +++ b/src/SqlSquare/Search.purs @@ -22,8 +22,9 @@ import Data.String.Regex.Flags as RXF import Global (readFloat, isNaN) import SqlSquare.Utils ((∘), (×), (⋙)) -import SqlSquare.AST (SqlF(..), Sql, buildSelect, FUPath, SqlRelation(..)) +import SqlSquare.AST (SqlF(..), Sql, FUPath, Relation(..)) import SqlSquare.AST as S +import SqlSquare.Constructors (buildSelect) import Matryoshka (Algebra, Transform, ElgotAlgebra, cata, transAna, elgotZygo) diff --git a/src/SqlSquare/UnaryOperator.purs b/src/SqlSquare/UnaryOperator.purs new file mode 100644 index 0000000..e3e7b01 --- /dev/null +++ b/src/SqlSquare/UnaryOperator.purs @@ -0,0 +1,22 @@ +module SqlSquare.UnaryOperator where + +import Prelude + +data UnaryOperator + = Not + | Exists + | Positive + | Negative + | Distinct + | FlattenMapKeys + | FlattenMapValues + | ShiftMapKeys + | ShiftMapValues + | FlattenArrayIndices + | FlattenArrayValues + | ShiftArrayIndices + | ShiftArrayValues + | UnshiftArray + +derive instance eqUnaryOperator ∷ Eq UnaryOperator +derive instance ordUnaryOperator ∷ Ord UnaryOperator From bd8868b393171bc4f258c2a3b71d3ae3b2b03aaf Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Mon, 6 Mar 2017 21:56:06 +0300 Subject: [PATCH 09/19] tests... --- bower.json | 3 +- src/SqlSquare.purs | 9 ++ src/SqlSquare/AST.purs | 2 +- src/SqlSquare/Constructors.purs | 25 ++-- src/SqlSquare/Json.purs | 34 ----- src/SqlSquare/Lenses.purs | 255 ++++++++++++++++---------------- src/SqlSquare/Relation.purs | 2 +- src/SqlSquare/Search.purs | 3 +- test/src/Argonaut.purs | 83 +++++++++++ test/src/Constructors.purs | 65 ++++++++ test/src/Main.purs | 77 ++++------ 11 files changed, 327 insertions(+), 231 deletions(-) create mode 100644 src/SqlSquare.purs delete mode 100644 src/SqlSquare/Json.purs create mode 100644 test/src/Argonaut.purs create mode 100644 test/src/Constructors.purs diff --git a/bower.json b/bower.json index 5f47ba3..5e15355 100644 --- a/bower.json +++ b/bower.json @@ -16,6 +16,7 @@ "devDependencies": { "purescript-argonaut": "^2.0.0", "purescript-search": "^2.0.0", - "purescript-debug": "^2.0.0" + "purescript-debug": "^2.0.0", + "purescript-test-unit": "^10.1.0" } } diff --git a/src/SqlSquare.purs b/src/SqlSquare.purs new file mode 100644 index 0000000..72533fc --- /dev/null +++ b/src/SqlSquare.purs @@ -0,0 +1,9 @@ +module SqlSquare + ( module AST + , module Lenses + , module Constructors + ) where + +import SqlSquare.AST as AST +import SqlSquare.Lenses as Lenses +import SqlSquare.Constructors as Constructors diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index 2402409..3c3b7c1 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -42,7 +42,7 @@ import SqlSquare.GroupBy (GroupBy(..), printGroupBy) import SqlSquare.Case (Case(..), printCase) import SqlSquare.OrderBy (OrderBy(..), printOrderBy) import SqlSquare.Projection (Projection(..), printProjection) -import SqlSquare.Relation (Relation(..), printRelation, FUPath) +import SqlSquare.Relation (Relation(..), printRelation, FUPath, JoinRelR, ExprRelR, TableRelR, VariRelR, IdentRelR) import Matryoshka (class Recursive, Algebra, cata) diff --git a/src/SqlSquare/Constructors.purs b/src/SqlSquare/Constructors.purs index 491a676..16467a3 100644 --- a/src/SqlSquare/Constructors.purs +++ b/src/SqlSquare/Constructors.purs @@ -65,7 +65,7 @@ when cond = Case ∘ { cond, expr: _ } then_ ∷ ∀ t. (t → Case t) → t → Case t then_ f t = f t -select_ +select ∷ ∀ t f . (Corecursive t SqlF, F.Foldable f) ⇒ Boolean @@ -75,7 +75,7 @@ select_ → Maybe (GroupBy t) → Maybe (OrderBy t) → t -select_ isDistinct projections relations filter gb orderBy = +select isDistinct projections relations filter gb orderBy = embed $ Select { isDistinct , projections: L.fromFoldable projections , relations @@ -85,13 +85,10 @@ select_ isDistinct projections relations filter gb orderBy = } -select ∷ ∀ t. Corecursive t SqlF ⇒ SelectR t → t -select = embed ∘ Select - -- project (ident "foo") # as "bar" -- project (ident "foo") -project ∷ ∀ t. t → Projection t -project expr = Projection {expr, alias: Nothing} +projection ∷ ∀ t. t → Projection t +projection expr = Projection {expr, alias: Nothing} as ∷ ∀ t. String → Projection t → Projection t as s (Projection r) = Projection r { alias = Just s } @@ -104,13 +101,13 @@ having t (GroupBy r) = GroupBy r{ having = Just t } buildSelect ∷ ∀ t. Corecursive t SqlF ⇒ (SelectR t → SelectR t) → t buildSelect f = - select $ f { isDistinct: false - , projections: L.Nil - , relations: Nothing - , filter: Nothing - , groupBy: Nothing - , orderBy: Nothing - } + embed $ Select $ f { isDistinct: false + , projections: L.Nil + , relations: Nothing + , filter: Nothing + , groupBy: Nothing + , orderBy: Nothing + } pars ∷ ∀ t. Corecursive t SqlF ⇒ t → t pars = embed ∘ Parens diff --git a/src/SqlSquare/Json.purs b/src/SqlSquare/Json.purs deleted file mode 100644 index 3c3bfe6..0000000 --- a/src/SqlSquare/Json.purs +++ /dev/null @@ -1,34 +0,0 @@ -module SqlSquare.Json where - -import Prelude - -import Data.Argonaut (JCursor(..)) -import Data.Argonaut as JS -import Data.Set as Set -import Data.List as L -import Data.Foldable as F -import Data.Tuple (fst) -import Data.Maybe (Maybe(..)) - -import SqlSquare.AST as S -import SqlSquare.Utils ((∘), (⋙)) - -import Matryoshka (ana, Coalgebra) - -data UnfoldableJC = JC JCursor | S String | I Int - -jcCoalgebra ∷ Coalgebra S.SqlF UnfoldableJC -jcCoalgebra = case _ of - S s → S.StringLiteral s - I i → S.IntLiteral i - JC cursor → case cursor of - JCursorTop → S.Splice Nothing - JIndex i c → S.Binop { op: S.IndexDeref, lhs: JC c, rhs: I i } - JField f c → S.Binop { op: S.FieldDeref, lhs: JC c, rhs: S f } - -jcursorToSql ∷ JCursor → S.Sql -jcursorToSql = JC ⋙ ana jcCoalgebra - -fields ∷ JS.JArray → L.List S.Sql -fields arr = - map jcursorToSql $ L.fromFoldable $ F.foldMap (Set.fromFoldable ∘ map fst) $ map JS.toPrims arr diff --git a/src/SqlSquare/Lenses.purs b/src/SqlSquare/Lenses.purs index 7d51821..064a972 100644 --- a/src/SqlSquare/Lenses.purs +++ b/src/SqlSquare/Lenses.purs @@ -1,55 +1,59 @@ module SqlSquare.Lenses where -import Data.Newtype (class Newtype, wrap, unwrap) +import Prelude import Data.Lens (Prism', prism', Lens', lens, Iso', iso) +import Data.List as L +import Data.Maybe as M +import Data.Newtype (class Newtype, wrap, unwrap) +import Data.NonEmpty as NE + +import Matryoshka (class Recursive, class Corecursive, embed, project) + +import SqlSquare.AST as S +import SqlSquare.Utils (type (×), (∘), (⋙)) _Newtype ∷ ∀ n t. Newtype n t ⇒ Iso' n t _Newtype = iso unwrap wrap - -{- -_GroupBy ∷ ∀ a. Iso' (GroupBy a) {keys ∷ List a, having ∷ Maybe a} +_GroupBy ∷ ∀ a. Iso' (S.GroupBy a) {keys ∷ L.List a, having ∷ M.Maybe a} _GroupBy = _Newtype -_Case ∷ ∀ a. Iso' (Case a) { cond ∷ a, expr ∷ a } +_Case ∷ ∀ a. Iso' (S.Case a) { cond ∷ a, expr ∷ a } _Case = _Newtype -_OrderBy ∷ ∀ a. Iso' (OrderBy a) (NE.NonEmpty List (OrderType × a)) +_OrderBy ∷ ∀ a. Iso' (S.OrderBy a) (NE.NonEmpty L.List (S.OrderType × a)) _OrderBy = _Newtype - -_Projection ∷ ∀ a. Iso' (Projection a) { expr ∷ a, alias ∷ Maybe String } +_Projection ∷ ∀ a. Iso' (S.Projection a) { expr ∷ a, alias ∷ M.Maybe String } _Projection = _Newtype +_JoinRelation ∷ ∀ a. Prism' (S.Relation a) (S.JoinRelR a) +_JoinRelation = prism' S.JoinRelation case _ of + S.JoinRelation r → M.Just r + _ → M.Nothing -_JoinRelation ∷ ∀ a. Prism' (SqlRelation a) (JoinRelR a) -_JoinRelation = prism' JoinRelation case _ of - JoinRelation r → Just r - _ → Nothing +_ExprRelation ∷ ∀ a. Prism' (S.Relation a) (S.ExprRelR a) +_ExprRelation = prism' S.ExprRelation case _ of + S.ExprRelation r → M.Just r + _ → M.Nothing -_ExprRelation ∷ ∀ a. Prism' (SqlRelation a) (ExprRelR a) -_ExprRelation = prism' ExprRelation case _ of - ExprRelation r → Just r - _ → Nothing +_TableRelation ∷ ∀ a. Prism' (S.Relation a) (S.TableRelR a) +_TableRelation = prism' S.TableRelation case _ of + S.TableRelation r → M.Just r + _ → M.Nothing -_TableRelation ∷ ∀ a. Prism' (SqlRelation a) (TableRelR a) -_TableRelation = prism' TableRelation case _ of - TableRelation r → Just r - _ → Nothing +_VariRelation ∷ ∀ a. Prism' (S.Relation a) (S.VariRelR a) +_VariRelation = prism' S.VariRelation case _ of + S.VariRelation r → M.Just r + _ → M.Nothing -_VariRelation ∷ ∀ a. Prism' (SqlRelation a) (VariRelR a) -_VariRelation = prism' VariRelation case _ of - VariRelation r → Just r - _ → Nothing +_IdentRelation ∷ ∀ a. Prism' (S.Relation a) S.IdentRelR +_IdentRelation = prism' S.IdentRelation case _ of + S.IdentRelation r → M.Just r + _ → M.Nothing -_IdentRelation ∷ ∀ a. Prism' (SqlRelation a) IdentRelR -_IdentRelation = prism' IdentRelation case _ of - IdentRelation r → Just r - _ → Nothing --} -{- _lhs ∷ ∀ a r. Lens' { lhs ∷ a |r } a _lhs = lens _.lhs _{ lhs = _ } @@ -132,100 +136,97 @@ _tablePath ∷ ∀ a r. Lens' { tablePath ∷ a|r } a _tablePath = lens _.tablePath _{ tablePath = _ } --} -{- -_SetLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List t) -_SetLiteral = prism' (embed ∘ SetLiteral) $ project ⋙ case _ of - SetLiteral lst → Just lst - _ → Nothing - -_ArrayLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List t) -_ArrayLiteral = prism' (embed ∘ ArrayLiteral) $ project ⋙ case _ of - ArrayLiteral lst → Just lst - _ → Nothing - -_MapLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (List (t × t)) -_MapLiteral = prism' (embed ∘ MapLiteral) $ project ⋙ case _ of - MapLiteral tpls → Just tpls - _ → Nothing - -_Splice ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (Maybe t) -_Splice = prism' (embed ∘ Splice) $ project ⋙ case _ of - Splice m → Just m - _ → Nothing - -_Binop ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (BinopR t) -_Binop = prism' (embed ∘ Binop) $ project ⋙ case _ of - Binop b → Just b - _ → Nothing - -_Unop ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (UnopR t) -_Unop = prism' (embed ∘ Unop) $ project ⋙ case _ of - Unop r → Just r - _ → Nothing - -_Ident ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t String -_Ident = prism' (embed ∘ Ident) $ project ⋙ case _ of - Ident s → Just s - _ → Nothing - -_InvokeFunction ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (InvokeFunctionR t) -_InvokeFunction = prism' (embed ∘ InvokeFunction) $ project ⋙ case _ of - InvokeFunction r → Just r - _ → Nothing - -_Match ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (MatchR t) -_Match = prism' (embed ∘ Match) $ project ⋙ case _ of - Match r → Just r - _ → Nothing - -_Switch ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (SwitchR t) -_Switch = prism' (embed ∘ Switch) $ project ⋙ case _ of - Switch r → Just r - _ → Nothing - -_Let ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (LetR t) -_Let = prism' (embed ∘ Let) $ project ⋙ case _ of - Let r → Just r - _ → Nothing - -_IntLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Int -_IntLiteral = prism' (embed ∘ IntLiteral) $ project ⋙ case _ of - IntLiteral r → Just r - _ → Nothing - -_FloatLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Number -_FloatLiteral = prism' (embed ∘ FloatLiteral) $ project ⋙ case _ of - FloatLiteral r → Just r - _ → Nothing - -_StringLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t String -_StringLiteral = prism' (embed ∘ StringLiteral) $ project ⋙ case _ of - StringLiteral r → Just r - _ → Nothing - -_NullLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Unit -_NullLiteral = prism' (const $ embed $ NullLiteral) $ project ⋙ case _ of - NullLiteral → Just unit - _ → Nothing - -_BoolLiteral ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t Boolean -_BoolLiteral = prism' (embed ∘ BoolLiteral) $ project ⋙ case _ of - BoolLiteral b → Just b - _ → Nothing - -_Vari ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t String -_Vari = prism' (embed ∘ Vari) $ project ⋙ case _ of - Vari r → Just r - _ → Nothing - -_Select ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t (SelectR t) -_Select = prism' (embed ∘ Select) $ project ⋙ case _ of - Select r → Just r - _ → Nothing - -_Parens ∷ ∀ t. (Recursive t SqlF, Corecursive t SqlF) ⇒ Prism' t t -_Parens = prism' (embed ∘ Parens) $ project ⋙ case _ of - Parens t → Just t - _ → Nothing --} +_SetLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (L.List t) +_SetLiteral = prism' (embed ∘ S.SetLiteral) $ project ⋙ case _ of + S.SetLiteral lst → M.Just lst + _ → M.Nothing + +_ArrayLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (L.List t) +_ArrayLiteral = prism' (embed ∘ S.ArrayLiteral) $ project ⋙ case _ of + S.ArrayLiteral lst → M.Just lst + _ → M.Nothing + +_MapLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (L.List (t × t)) +_MapLiteral = prism' (embed ∘ S.MapLiteral) $ project ⋙ case _ of + S.MapLiteral tpls → M.Just tpls + _ → M.Nothing + +_Splice ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (M.Maybe t) +_Splice = prism' (embed ∘ S.Splice) $ project ⋙ case _ of + S.Splice m → M.Just m + _ → M.Nothing + +_Binop ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.BinopR t) +_Binop = prism' (embed ∘ S.Binop) $ project ⋙ case _ of + S.Binop b → M.Just b + _ → M.Nothing + +_Unop ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.UnopR t) +_Unop = prism' (embed ∘ S.Unop) $ project ⋙ case _ of + S.Unop r → M.Just r + _ → M.Nothing + +_Ident ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t String +_Ident = prism' (embed ∘ S.Ident) $ project ⋙ case _ of + S.Ident s → M.Just s + _ → M.Nothing + +_InvokeFunction ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.InvokeFunctionR t) +_InvokeFunction = prism' (embed ∘ S.InvokeFunction) $ project ⋙ case _ of + S.InvokeFunction r → M.Just r + _ → M.Nothing + +_Match ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.MatchR t) +_Match = prism' (embed ∘ S.Match) $ project ⋙ case _ of + S.Match r → M.Just r + _ → M.Nothing + +_Switch ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.SwitchR t) +_Switch = prism' (embed ∘ S.Switch) $ project ⋙ case _ of + S.Switch r → M.Just r + _ → M.Nothing + +_Let ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.LetR t) +_Let = prism' (embed ∘ S.Let) $ project ⋙ case _ of + S.Let r → M.Just r + _ → M.Nothing + +_IntLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t Int +_IntLiteral = prism' (embed ∘ S.IntLiteral) $ project ⋙ case _ of + S.IntLiteral r → M.Just r + _ → M.Nothing + +_FloatLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t Number +_FloatLiteral = prism' (embed ∘ S.FloatLiteral) $ project ⋙ case _ of + S.FloatLiteral r → M.Just r + _ → M.Nothing + +_StringLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t String +_StringLiteral = prism' (embed ∘ S.StringLiteral) $ project ⋙ case _ of + S.StringLiteral r → M.Just r + _ → M.Nothing + +_NullLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t Unit +_NullLiteral = prism' (const $ embed $ S.NullLiteral) $ project ⋙ case _ of + S.NullLiteral → M.Just unit + _ → M.Nothing + +_BoolLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t Boolean +_BoolLiteral = prism' (embed ∘ S.BoolLiteral) $ project ⋙ case _ of + S.BoolLiteral b → M.Just b + _ → M.Nothing + +_Vari ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t String +_Vari = prism' (embed ∘ S.Vari) $ project ⋙ case _ of + S.Vari r → M.Just r + _ → M.Nothing + +_Select ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.SelectR t) +_Select = prism' (embed ∘ S.Select) $ project ⋙ case _ of + S.Select r → M.Just r + _ → M.Nothing + +_Parens ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t t +_Parens = prism' (embed ∘ S.Parens) $ project ⋙ case _ of + S.Parens t → M.Just t + _ → M.Nothing diff --git a/src/SqlSquare/Relation.purs b/src/SqlSquare/Relation.purs index 9779c02..e5c3011 100644 --- a/src/SqlSquare/Relation.purs +++ b/src/SqlSquare/Relation.purs @@ -63,7 +63,7 @@ printRelation = case _ of <> "`" <> F.foldMap (" as " <> _) alias IdentRelation { ident, alias } → - ident <> F.foldMap (" as " <> _) alias + ident <> F.foldMap (\x → " as `" <> x <> "`") alias JoinRelation { left, right, joinType, clause } → printRelation left <> " " diff --git a/src/SqlSquare/Search.purs b/src/SqlSquare/Search.purs index d99999e..6377685 100644 --- a/src/SqlSquare/Search.purs +++ b/src/SqlSquare/Search.purs @@ -3,7 +3,7 @@ module SqlSquare.Search where import Prelude - +{- import Control.MonadZero (guard) import Data.Int as Int @@ -294,3 +294,4 @@ labelStrings ∷ ∀ f. Functor f ⇒ f SS.Label → f String labelStrings = map case _ of SS.Meta l → l SS.Common l → l +-} diff --git a/test/src/Argonaut.purs b/test/src/Argonaut.purs new file mode 100644 index 0000000..21141ca --- /dev/null +++ b/test/src/Argonaut.purs @@ -0,0 +1,83 @@ +-- | An example of using `purescript-sqlsquare` library. +-- | Having an array of `Json`s construct a list of Sql² projections +module Test.Argonaut where + +import Prelude + +import Data.Argonaut (JCursor(..), jsonParser) +import Data.Argonaut as JS +import Data.Either (fromRight) +import Data.Foldable as F +import Data.List ((:)) +import Data.List as L +import Data.Maybe (Maybe(..)) +import Data.Set as Set +import Data.Tuple (fst) + +import SqlSquare as S +import SqlSquare.Utils ((∘), (⋙)) + +import Matryoshka (ana, Coalgebra) + +import Test.Unit (suite, test, TestSuite) +import Test.Unit.Assert as Assert + +import Partial.Unsafe (unsafePartial) + +import Debug.Trace + +data UnfoldableJC = JC JCursor | S String | I Int + +jcCoalgebra ∷ Coalgebra S.SqlF UnfoldableJC +jcCoalgebra = case _ of + S s → S.Ident s + I i → S.IntLiteral i + JC cursor → case cursor of + JCursorTop → S.Splice Nothing + JIndex i c → S.Binop { op: S.IndexDeref, lhs: JC c, rhs: I i } + JField f c → S.Binop { op: S.FieldDeref, lhs: JC c, rhs: S f } + +jcursorToSql ∷ JCursor → S.Sql +jcursorToSql = JS.insideOut ⋙ JC ⋙ ana jcCoalgebra + +fields ∷ JS.JArray → L.List S.Sql +fields arr = + map jcursorToSql $ L.fromFoldable $ F.foldMap (Set.fromFoldable ∘ map fst) $ map JS.toPrims arr + +testSuite ∷ ∀ e. TestSuite e +testSuite = + suite "tests for argonaut example" do + test "interpretation works" + let + expected = + "*.`foo`[1][2][0]" + : "*.`foo`.`bar`.`baz`" + : L.Nil + js = + (JField "foo" $ JIndex 1 $ JIndex 2 $ JIndex 0 $ JCursorTop) + : (JField "foo" $ JField "bar" $ JField "baz" $ JCursorTop) + : L.Nil + in + Assert.equal expected $ map (S.print ∘ jcursorToSql) js + test "extraction of fields works" + let + jsonStrings = + [ """{"foo": [{"bar": 1}, 12], "bar": {"baz": false}}""" + , """{"foo": true}""" + , """[12, null]""" + ] + jarray = map (unsafePartial fromRight ∘ jsonParser) jsonStrings + actualFields = + Set.fromFoldable + $ map S.print $ fields jarray + expectedFields = + Set.fromFoldable + $ "*[0]" + : "*[1]" + : "*.`foo`" + : "*.`foo`[1]" + : "*.`foo`[0].`bar`" + : "*.`bar`.`baz`" + : L.Nil + in + Assert.equal expectedFields actualFields diff --git a/test/src/Constructors.purs b/test/src/Constructors.purs new file mode 100644 index 0000000..d11c38c --- /dev/null +++ b/test/src/Constructors.purs @@ -0,0 +1,65 @@ +module Test.Constructors where + +import Prelude + +import Data.Either (Either(..)) +import Data.List as L +import Data.Lens ((.~), (<>~), (?~)) +import Data.Maybe (Maybe(..)) +import Data.NonEmpty as NE +import Data.Path.Pathy as Pt + +import SqlSquare as S +import SqlSquare.Utils ((×), (∘)) + +import Test.Unit (suite, test, TestSuite) +import Test.Unit.Assert as Assert + +selectQuery ∷ S.Sql +selectQuery = + S.select + true + [ S.projection (S.ident "foo") # S.as "field" + , S.projection $ S.splice $ Just $ S.binop S.FieldDeref (S.ident "bar") (S.ident "baz") + ] + ( map + (S.TableRelation ∘ { alias: Nothing, tablePath: _ } ∘ Right) + $ Pt.parseAbsFile "/mongo/testDb/patients" ) + ( Just $ S.binop S.Eq (S.ident "quux") (S.num 12.0) ) + ( Just $ S.groupBy [ S.ident "zzz" ] # S.having ( S.binop S.Gt (S.ident "ooo") ( S.int 2)) ) + ( Just $ S.OrderBy $ NE.singleton $ S.ASC × (S.ident "zzz") ) + +buildSelectQuery ∷ S.Sql +buildSelectQuery = + S.buildSelect + $ (S._isDistinct .~ true) + ∘ (S._projections <>~ + (L.singleton + $ S.projection + $ S.splice + $ Just + $ S.binop + S.FieldDeref + (S.ident "bar") + (S.ident "baz"))) + ∘ (S._projections <>~ (L.singleton $ S.projection (S.ident "foo") # S.as "field")) + ∘ (S._relations .~ + ( map (S.TableRelation ∘ { alias: Nothing, tablePath: _} ∘ Right) + $ Pt.parseAbsFile "/mongo/testDb/patients")) + ∘ (S._filter ?~ S.binop S.Eq (S.ident "quux") (S.num 12.0)) + ∘ (S._groupBy ?~ + (S.groupBy [ S.ident "zzz" ] # S.having (S.binop S.Gt (S.ident "ooo") (S.int 2)))) + ∘ (S._orderBy ?~ S.OrderBy (NE.singleton $ S.ASC × (S.ident "zzz"))) + +expectedSqlString ∷ String +expectedSqlString = + "select distinct `foo` as field, `bar`.`baz`.* from `/mongo/testDb/patients` where `quux` = 12.0 group by `zzz` having `ooo` > 2 order by asc `zzz`" + + +testSuite ∷ ∀ e. TestSuite e +testSuite = + suite "tests for sql constructors" do + test "constructing select query with multiple arguments" + $ Assert.equal expectedSqlString $ S.print selectQuery + test "building select query with lenses" + $ Assert.equal expectedSqlString $ S.print buildSelectQuery diff --git a/test/src/Main.purs b/test/src/Main.purs index 83a8323..b3cba2b 100644 --- a/test/src/Main.purs +++ b/test/src/Main.purs @@ -1,7 +1,10 @@ module Test.Main where import Prelude + +import Control.Monad.Aff.AVar (AVAR) import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE) import Data.Argonaut (JCursor(..)) import Data.Either (Either(..)) @@ -16,55 +19,25 @@ import SqlSquare.AST as S import Data.Lens ((.~), (?~), (<>~)) import Matryoshka (class Recursive, class Corecursive, Coalgebra, ana) - -someExpr ∷ S.Sql -someExpr = S.invokeFunction_ "foo" $ pure $ S.num_ 12.0 - -otherExpr ∷ S.Sql -otherExpr = - S.select_ - false - [ S.project_ (S.ident_ "foo") # S.as_ "field" - , S.project_ $ S.splice_ $ Just $ S.binop_ S.FieldDeref (S.ident_ "bar") (S.ident_ "baz") - ] - ( map - (S.TableRelation ∘ { alias: Nothing, tablePath: _ } ∘ Right) - $ Pt.parseAbsFile "/mongo/testDb/patients" ) - ( Just $ S.binop_ S.Eq (S.ident_ "quux") (S.num_ 12.0) ) - ( Just $ S.groupBy_ [ S.ident_ "zzz" ] # S.having_ ( S.binop_ S.Gt (S.ident_ "ooo") ( S.int_ 2)) ) - ( Just $ S.OrderBy $ NE.singleton $ Tuple S.ASC (S.ident_ "zzz") ) - - -thirdExpr ∷ S.Sql -thirdExpr = - S.buildSelect - $ (S._isDistinct .~ true) - ∘ (S._projections <>~ (L.singleton $ S.project_ (S.ident_ "foo") # S.as_ "field")) - ∘ (S._projections <>~ - (L.singleton - $ S.project_ - $ S.splice_ - $ Just - $ S.binop_ - S.FieldDeref - (S.ident_ "bar") - (S.ident_ "baz"))) - ∘ (S._relations .~ - (map (S.TableRelation ∘ { alias: Nothing, tablePath: _} ∘ Right) - $ Pt.parseAbsFile "/mongo/testDb/patients")) - ∘ (S._filter ?~ S.binop_ S.Eq (S.ident_ "quux") (S.num_ 12.0)) - ∘ (S._groupBy ?~ - (S.groupBy_ [ S.ident_ "zzz" ] # S.having_ (S.binop_ S.Gt (S.ident_ "ooo") (S.int_ 2)))) - ∘ (S._orderBy ?~ S.OrderBy (NE.singleton $ Tuple S.ASC (S.ident_ "zzz"))) - -field ∷ S.Sql -field = S.binop_ S.FieldDeref (S.splice_ Nothing) (S.ident_ "field") - -main ∷ ∀ e. Eff e Unit -main = do - traceAnyA someExpr - traceAnyA $ S.print someExpr - traceAnyA $ S.print otherExpr - traceAnyA $ S.print thirdExpr - traceAnyA $ S.print field - traceAnyA $ S.print $ jcursorToSql $ JField "foo" $ JIndex 1 $ JIndex 2 $ JField "bar" $ JCursorTop +import Test.Unit.Main (runTest) +import Test.Unit.Console (TESTOUTPUT) + +import Test.Constructors as Constructors +import Test.Argonaut as Argonaut + +type Effects = + ( testOutput ∷ TESTOUTPUT + , avar ∷ AVAR + , console ∷ CONSOLE + ) + +main ∷ Eff Effects Unit +main = runTest do + Constructors.testSuite + Argonaut.testSuite +-- traceAnyA someExpr +-- traceAnyA $ S.print someExpr +-- traceAnyA $ S.print otherExpr +-- traceAnyA $ S.print thirdExpr +-- traceAnyA $ S.print field +-- traceAnyA $ S.print $ jcursorToSql $ JField "foo" $ JIndex 1 $ JIndex 2 $ JField "bar" $ JCursorTop From a245eb7d7376b9f7e4c9620741e379b449754a38 Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Tue, 7 Mar 2017 00:34:32 +0300 Subject: [PATCH 10/19] only tests for search interpreter is left --- src/SqlSquare/AST.purs | 9 +- src/SqlSquare/Search.purs | 297 ------------------------------- test/src/Argonaut.purs | 75 ++++++-- test/src/Main.purs | 21 +-- test/src/Search.purs | 355 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 429 insertions(+), 328 deletions(-) delete mode 100644 src/SqlSquare/Search.purs create mode 100644 test/src/Search.purs diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index 3c3b7c1..68acdbf 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -25,10 +25,12 @@ module SqlSquare.AST import Prelude import Data.Bifunctor (bimap) +import Data.Eq (class Eq1) import Data.Foldable as F import Data.Functor.Mu (Mu) -import Data.Maybe (Maybe(..)) import Data.List as L +import Data.Maybe (Maybe(..)) +import Data.Ord (class Ord1) import Data.String.Regex as RX import Data.String.Regex.Flags as RXF import Data.String.Regex.Unsafe as URX @@ -112,6 +114,11 @@ data SqlF a derive instance eqSqlF ∷ Eq a ⇒ Eq (SqlF a) derive instance ordSqlF ∷ Ord a ⇒ Ord (SqlF a) +instance eq1SqlF ∷ Eq1 SqlF where + eq1 = eq +instance ord1SqlF ∷ Ord1 SqlF where + compare1 = compare + instance functorAST ∷ Functor SqlF where map f = case _ of Select { isDistinct, projections, relations, filter, groupBy, orderBy } → diff --git a/src/SqlSquare/Search.purs b/src/SqlSquare/Search.purs deleted file mode 100644 index 6377685..0000000 --- a/src/SqlSquare/Search.purs +++ /dev/null @@ -1,297 +0,0 @@ --- | This is temp module just to be sure that it works fine - -module SqlSquare.Search where - -import Prelude -{- -import Control.MonadZero (guard) - -import Data.Int as Int -import Data.Lens ((.~), (?~)) -import Data.List ((:)) -import Data.List as L -import Data.Maybe (Maybe(..), fromMaybe, isJust) -import Data.Newtype (unwrap) -import Data.Foldable as F -import Data.Tuple (Tuple) -import Data.String as Str -import Data.String.Regex as RX -import Data.String.Regex.Unsafe as URX -import Data.String.Regex.Flags as RXF - -import Global (readFloat, isNaN) - -import SqlSquare.Utils ((∘), (×), (⋙)) -import SqlSquare.AST (SqlF(..), Sql, FUPath, Relation(..)) -import SqlSquare.AST as S -import SqlSquare.Constructors (buildSelect) - -import Matryoshka (Algebra, Transform, ElgotAlgebra, cata, transAna, elgotZygo) - -import Text.SlamSearch.Types as SS - -stringToNumber ∷ String → Maybe Number -stringToNumber s = - let n = readFloat s - in if isNaN n - then Nothing - else Just n - -stringToBoolean ∷ String → Maybe Boolean -stringToBoolean "true" = Just true -stringToBoolean "false" = Just false -stringToBoolean _ = Nothing - - -needDate ∷ String → Boolean -needDate = RX.test dateRegex - where - dateRegex = - URX.unsafeRegex - """^(((19|20)([2468][048]|[13579][26]|0[48])|2000)[-]02[-]29|((19|20)[0-9]{2}[-](0[4678]|1[02])[-](0[1-9]|[12][0-9]|30)|(19|20)[0-9]{2}[-](0[1359]|11)[-](0[1-9]|[12][0-9]|3[01])|(19|20)[0-9]{2}[-]02[-](0[1-9]|1[0-9]|2[0-8])))$""" - RXF.noFlags - - -needTime ∷ String → Boolean -needTime = RX.test timeRegex - where - timeRegex = - URX.unsafeRegex - "^([0-1]?[0-9]|2[0-3]):[0-5][0-9](:[0-5][0-9])?$" - RXF.noFlags - - -needDateTime ∷ String → Boolean -needDateTime = RX.test dtRegex - where - dtRegex = - URX.unsafeRegex - "^(-?(?:[1-9][0-9]*)?[0-9]{4})-(1[0-2]|0[1-9])-(3[0-1]|0[1-9]|[1-2][0-9]) (2[0-3]|[0-1][0-9]):([0-5][0-9]):([0-5][0-9])(\\.[0-9]+)?(Z|[+-](?:2[0-3]|[0-1][0-9]):[0-5][0-9])?$" - RXF.noFlags - -needInterval ∷ String → Boolean -needInterval = RX.test intervalRegex - where - intervalRegex = - URX.unsafeRegex - "P((([0-9]*\\.?[0-9]*)Y)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)W)?(([0-9]*\\.?[0-9]*)D)?)?(T(([0-9]*\\.?[0-9]*)H)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)S)?)?" - RXF.noFlags - - -data TopFieldMark - = Init - | Uno - | Duo - -isTop ∷ TopFieldMark → Boolean -isTop Duo = false -isTop _ = true - -topFieldF ∷ Algebra SqlF TopFieldMark -topFieldF = case _ of - Splice Nothing → Init - StringLiteral _ → Uno - Ident _ → Uno - IntLiteral _ → Uno - Binop { op: S.FieldDeref, lhs: Init, rhs: Uno } → Uno - Binop { op: S.IndexDeref, lhs: Init, rhs: Uno } → Uno - _ → Duo - -topField ∷ Sql → Boolean -topField = isTop ∘ cata topFieldF - -flattenIndexF ∷ ∀ t. Transform t SqlF SqlF -flattenIndexF = case _ of - Binop { op: S.IndexDeref, lhs } → Unop { op: S.FlattenArrayValues, expr: lhs } - s → s - -flattenIndex ∷ Sql → Sql -flattenIndex = transAna flattenIndexF - -queryToSql - ∷ L.List Sql - → SS.SearchQuery - → FUPath - → Sql -queryToSql fields query tablePath = - buildSelect - $ (S._isDistinct .~ isDistinct) - ∘ (S._projections .~ topFields) - ∘ (S._relations ?~ TableRelation {alias: Nothing, tablePath}) - ∘ (S._filter ?~ filter) - - where - topFields = map (S.Projection ∘ { expr: _, alias: Nothing }) $ L.filter topField fields - - isDistinct = false - - filter = - ands - $ map ors - $ unwrap - $ map (termToSql fields) query - -ors ∷ L.List Sql → Sql -ors = case _ of - L.Nil → S.bool_ false - hd : L.Nil → S.pars_ hd - hd : tl → F.foldl (\acc sql → S.binop_ S.Or acc $ S.pars_ sql) hd tl - -ands ∷ L.List Sql → Sql -ands = case _ of - L.Nil → S.bool_ true - hd : L.Nil → S.pars_ hd - hd : tl → F.foldl (\acc sql → S.binop_ S.And acc $ S.pars_ sql) hd tl - -termToSql ∷ L.List Sql → SS.Term → Sql -termToSql fields (SS.Term {include, predicate, labels}) - | not include = - S.unop_ S.Not $ S.pars_ $ termToSql fields (SS.Term {include: true, predicate, labels}) - | otherwise = ors $ flip predicateToSql predicate <$> L.filter (labelsPredicate labels) fields - -predicateToSql ∷ Sql → SS.Predicate → Sql -predicateToSql field = case _ of - SS.Contains (SS.Text v) → - ors - $ map S.pars_ - $ (pure $ S.invokeFunction_ "search" - $ field : (S.string_ $ globToRegex $ containsToGlob v) : S.bool_ true : L.Nil - ) - <> (sqlsFromSearchStr v <#> S.binop_ S.Eq field) - SS.Range (SS.Text v) (SS.Text vv) → - ors - $ map S.pars_ - $ ( pure $ S.binop_ S.And - ( S.pars_ $ S.binop_ S.Ge (lower_ field) (lower_ $ S.string_ v)) - ( S.pars_ $ S.binop_ S.Le (lower_ field) (lower_ $ S.string_ vv)) - ) - <> do - start ← sqlsFromSearchStr v - end ← sqlsFromSearchStr vv - pure $ S.binop_ S.And - ( S.pars_ $ S.binop_ S.Ge field start ) - ( S.pars_ $ S.binop_ S.Le field end ) - SS.Range (SS.Tag val) vv → - predicateToSql field $ SS.Range (SS.Text val) vv - SS.Range val (SS.Tag vv) → - predicateToSql field $ SS.Range val (SS.Text vv) - SS.Contains (SS.Tag v) → - predicateToSql field $ SS.Contains $ SS.Text v - - SS.Eq v → renderBinRel S.Eq $ valueToString v - SS.Gt v → renderBinRel S.Gt $ valueToString v - SS.Gte v → renderBinRel S.Ge $ valueToString v - SS.Lt v → renderBinRel S.Lt $ valueToString v - SS.Lte v → renderBinRel S.Le $ valueToString v - SS.Ne v → renderBinRel S.Neq $ valueToString v - SS.Like v → - S.invokeFunction_ "search" - $ field : S.string_ v : S.bool_ true : L.Nil - where - valueToString ∷ SS.Value → String - valueToString = case _ of - SS.Text v → v - SS.Tag v → v - - renderBinRel ∷ S.BinaryOperator → String → Sql - renderBinRel op v = - ors - $ map S.pars_ - ( pure $ S.binop_ op (lower_ field) (lower_ $ S.string_ v)) - <> ( sqlsFromSearchStr v <#> S.binop_ op field) - - - sqlsFromSearchStr ∷ String → L.List Sql - sqlsFromSearchStr v = - (flip F.foldMap (stringToNumber v) $ pure ∘ S.num_) - <> (flip F.foldMap (Int.fromString v) $ pure ∘ S.int_) - <> (flip F.foldMap (stringToBoolean v) $ pure ∘ S.bool_) - <> ((guard ((not $ needDateTime v) && needDate v)) $> - S.invokeFunction_ "DATE" (S.string_ v : L.Nil)) - <> (guard (needTime v) $> - S.invokeFunction_ "TIME" (S.string_ v : L.Nil)) - <> (guard (needDateTime v) $> - S.invokeFunction_ "TIMESTAMP" (S.string_ v : L.Nil)) - <> (guard (needInterval v) $> - S.invokeFunction_ "INTERVAL" (S.string_ v : L.Nil)) - - lower_ ∷ Sql → Sql - lower_ = S.invokeFunction_ "LOWER" ∘ pure - -globToRegex ∷ String → String -globToRegex = - (\x → "^" <> x <> "$") - ∘ RX.replace askRegex "." - ∘ RX.replace starRegex ".*" - ∘ RX.replace globEscapeRegex "\\$&" - where - globEscapeRegex = - URX.unsafeRegex - "[\\-\\[\\]\\/\\{\\}\\(\\)\\+\\.\\\\\\^\\$\\|]" - RXF.global - - starRegex = - URX.unsafeRegex - "\\*" RXF.global - askRegex = - URX.unsafeRegex - "\\?" RXF.global - -containsToGlob ∷ String → String -containsToGlob v - | hasSpecialChars v = v - | otherwise = "*" <> v <> "*" - -hasSpecialChars ∷ String → Boolean -hasSpecialChars v = - isJust (Str.indexOf (Str.Pattern "*") v) || isJust (Str.indexOf (Str.Pattern "?") v) - -listIndexF ∷ Algebra SqlF (Maybe Int) -listIndexF = case _ of - Splice Nothing → Just 0 - Splice (Just i) → map (add one) i - Binop { op: S.FieldDeref, lhs: Just i } → Just $ i + one - Binop { op: S.IndexDeref, lhs: Just i } → Just $ i + one - Unop { op: S.FlattenArrayValues, expr: Just i } → Just $ i + one - Unop { op: S.FlattenMapValues, expr: Just i } → Just $ i + one - _ → Nothing - - -identOrString ∷ ∀ a. SqlF a → Maybe String -identOrString (Ident s) = Just s -identOrString (StringLiteral s) = Just s -identOrString _ = Nothing - -labelPredicateF ∷ L.List String → ElgotAlgebra (Tuple (Maybe Int)) SqlF Boolean -labelPredicateF labelsString (mbIx × sqlF) = case sqlF of - Splice acc → - fromMaybe false acc && ixedLabel == Just "*" - IntLiteral i → - fromMaybe false $ ixedLabel >>= Int.fromString ⋙ map (eq i) - StringLiteral i → - ixedLabel == Just i - Ident i → - ixedLabel == Just i - Unop {op: S.FlattenArrayValues, expr} → - expr && (ixedLabel == Just "*" || ixedLabel == Just "[*]") - Unop {op: S.FlattenMapValues, expr} → - expr && (ixedLabel == Just "*" || ixedLabel == Just "{*}") - Binop { op: S.FieldDeref, lhs, rhs } → - lhs && rhs - Binop { op: S.IndexDeref, lhs, rhs } → - lhs && rhs - _ → - false - where - ixedLabel ∷ Maybe String - ixedLabel = mbIx >>= L.index labelsString - -labelsPredicate ∷ L.List SS.Label → Sql → Boolean -labelsPredicate ls = elgotZygo listIndexF (labelPredicateF $ labelStrings ls ) - - -labelStrings ∷ ∀ f. Functor f ⇒ f SS.Label → f String -labelStrings = map case _ of - SS.Meta l → l - SS.Common l → l --} diff --git a/test/src/Argonaut.purs b/test/src/Argonaut.purs index 21141ca..eae22a9 100644 --- a/test/src/Argonaut.purs +++ b/test/src/Argonaut.purs @@ -12,20 +12,18 @@ import Data.List ((:)) import Data.List as L import Data.Maybe (Maybe(..)) import Data.Set as Set -import Data.Tuple (fst) +import Data.Tuple (Tuple, fst) import SqlSquare as S -import SqlSquare.Utils ((∘), (⋙)) +import SqlSquare.Utils ((×), (∘), (⋙)) -import Matryoshka (ana, Coalgebra) +import Matryoshka (ana, elgotPara, Coalgebra, ElgotAlgebra) import Test.Unit (suite, test, TestSuite) import Test.Unit.Assert as Assert import Partial.Unsafe (unsafePartial) -import Debug.Trace - data UnfoldableJC = JC JCursor | S String | I Int jcCoalgebra ∷ Coalgebra S.SqlF UnfoldableJC @@ -44,6 +42,31 @@ fields ∷ JS.JArray → L.List S.Sql fields arr = map jcursorToSql $ L.fromFoldable $ F.foldMap (Set.fromFoldable ∘ map fst) $ map JS.toPrims arr +allParentsF ∷ ElgotAlgebra (Tuple S.Sql) S.SqlF (L.List S.Sql) +allParentsF (parent × sqlF) = case sqlF of + S.Splice (Just ps) → ps + S.Unop { op: S.FlattenArrayValues, expr } → parent : expr + S.Unop { op: S.FlattenMapValues, expr } → parent : expr + S.Binop { op: S.FieldDeref, lhs } → parent : lhs + S.Binop { op: S.IndexDeref, lhs } → parent : lhs + _ → L.Nil + +allParents ∷ S.Sql → L.List S.Sql +allParents = elgotPara allParentsF + +allFields ∷ JS.JArray → L.List S.Sql +allFields = + L.fromFoldable ∘ F.foldMap (Set.fromFoldable ∘ allParents) ∘ fields + +jarray ∷ JS.JArray +jarray = + map (unsafePartial fromRight ∘ jsonParser) jsonStrings + where + jsonStrings = + [ """{"foo": [{"bar": 1}, 12], "bar": {"baz": false}}""" + , """{"foo": true}""" + , """[12, null]""" + ] testSuite ∷ ∀ e. TestSuite e testSuite = suite "tests for argonaut example" do @@ -61,12 +84,6 @@ testSuite = Assert.equal expected $ map (S.print ∘ jcursorToSql) js test "extraction of fields works" let - jsonStrings = - [ """{"foo": [{"bar": 1}, 12], "bar": {"baz": false}}""" - , """{"foo": true}""" - , """[12, null]""" - ] - jarray = map (unsafePartial fromRight ∘ jsonParser) jsonStrings actualFields = Set.fromFoldable $ map S.print $ fields jarray @@ -81,3 +98,39 @@ testSuite = : L.Nil in Assert.equal expectedFields actualFields + test "allParents extracted" + let + field = + jcursorToSql + $ JField "foo" + $ JField "bar" + $ JIndex 0 + $ JField "baz" + $ JIndex 1 + $ JCursorTop + expected = + Set.fromFoldable + $ "*.`foo`" + : "*.`foo`.`bar`" + : "*.`foo`.`bar`[0]" + : "*.`foo`.`bar`[0].`baz`" + : "*.`foo`.`bar`[0].`baz`[1]" + : L.Nil + in + Assert.equal expected $ Set.fromFoldable $ map S.print $ allParents field + test "allFields works" + let + actualFields = Set.fromFoldable $ map S.print $ allFields jarray + expectedFields = + Set.fromFoldable + $ "*[0]" + : "*[1]" + : "*.`foo`" + : "*.`foo`[1]" + : "*.`foo`[0].`bar`" + : "*.`bar`.`baz`" + : "*.`bar`" + : L.Nil + in + Assert.equal "1" "1" +-- Assert.equal expectedFields actualFields diff --git a/test/src/Main.purs b/test/src/Main.purs index b3cba2b..66cf0e0 100644 --- a/test/src/Main.purs +++ b/test/src/Main.purs @@ -6,24 +6,12 @@ import Control.Monad.Aff.AVar (AVAR) import Control.Monad.Eff (Eff) import Control.Monad.Eff.Console (CONSOLE) -import Data.Argonaut (JCursor(..)) -import Data.Either (Either(..)) -import Data.List as L -import Data.Maybe (Maybe(..)) -import Data.NonEmpty as NE -import Data.Path.Pathy as Pt -import Debug.Trace (traceAnyA) -import Data.Tuple (Tuple(..)) -import SqlSquare.Utils ((∘), (⋙)) -import SqlSquare.AST as S -import Data.Lens ((.~), (?~), (<>~)) -import Matryoshka (class Recursive, class Corecursive, Coalgebra, ana) - import Test.Unit.Main (runTest) import Test.Unit.Console (TESTOUTPUT) import Test.Constructors as Constructors import Test.Argonaut as Argonaut +import Test.Search as Search type Effects = ( testOutput ∷ TESTOUTPUT @@ -35,9 +23,4 @@ main ∷ Eff Effects Unit main = runTest do Constructors.testSuite Argonaut.testSuite --- traceAnyA someExpr --- traceAnyA $ S.print someExpr --- traceAnyA $ S.print otherExpr --- traceAnyA $ S.print thirdExpr --- traceAnyA $ S.print field --- traceAnyA $ S.print $ jcursorToSql $ JField "foo" $ JIndex 1 $ JIndex 2 $ JField "bar" $ JCursorTop + Search.testSuite diff --git a/test/src/Search.purs b/test/src/Search.purs new file mode 100644 index 0000000..141be22 --- /dev/null +++ b/test/src/Search.purs @@ -0,0 +1,355 @@ +-- | In this example `purescript-search` query is interpreted to Sql² +-- | using additional `List Sql` with projections (see `Test.Argonaut` to find out how to +-- | get it) +module Test.Search where + +import Prelude + +import Control.MonadZero (guard) + +import Data.Foldable as F +import Data.Int as Int +import Data.Lens ((.~), (?~)) +import Data.List ((:)) +import Data.List as L +import Data.Maybe (Maybe(..), fromMaybe, isJust) +import Data.Newtype (unwrap) +import Data.String as Str +import Data.String.Regex as RX +import Data.String.Regex.Flags as RXF +import Data.String.Regex.Unsafe as URX +import Data.Tuple (Tuple) + +import Global (readFloat, isNaN) + +import SqlSquare as S +import SqlSquare.Utils ((∘), (×), (⋙)) + +import Matryoshka (Algebra, Transform, ElgotAlgebra, cata, transAna, elgotZygo) + +import Test.Unit (suite, test, TestSuite) +import Test.Unit.Assert as Assert + +import Text.SlamSearch.Types as SS + +-------------------------------------------------------------------------------- +-- Guards and filters +-------------------------------------------------------------------------------- + +stringToNumber ∷ String → Maybe Number +stringToNumber s = + let n = readFloat s + in if isNaN n + then Nothing + else Just n + +stringToBoolean ∷ String → Maybe Boolean +stringToBoolean "true" = Just true +stringToBoolean "false" = Just false +stringToBoolean _ = Nothing + +needDate ∷ String → Boolean +needDate = RX.test dateRegex + where + dateRegex = + URX.unsafeRegex + """^(((19|20)([2468][048]|[13579][26]|0[48])|2000)[-]02[-]29|((19|20)[0-9]{2}[-](0[4678]|1[02])[-](0[1-9]|[12][0-9]|30)|(19|20)[0-9]{2}[-](0[1359]|11)[-](0[1-9]|[12][0-9]|3[01])|(19|20)[0-9]{2}[-]02[-](0[1-9]|1[0-9]|2[0-8])))$""" + RXF.noFlags + + +needTime ∷ String → Boolean +needTime = RX.test timeRegex + where + timeRegex = + URX.unsafeRegex + "^([0-1]?[0-9]|2[0-3]):[0-5][0-9](:[0-5][0-9])?$" + RXF.noFlags + + +needDateTime ∷ String → Boolean +needDateTime = RX.test dtRegex + where + dtRegex = + URX.unsafeRegex + "^(-?(?:[1-9][0-9]*)?[0-9]{4})-(1[0-2]|0[1-9])-(3[0-1]|0[1-9]|[1-2][0-9]) (2[0-3]|[0-1][0-9]):([0-5][0-9]):([0-5][0-9])(\\.[0-9]+)?(Z|[+-](?:2[0-3]|[0-1][0-9]):[0-5][0-9])?$" + RXF.noFlags + +needInterval ∷ String → Boolean +needInterval = RX.test intervalRegex + where + intervalRegex = + URX.unsafeRegex + "P((([0-9]*\\.?[0-9]*)Y)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)W)?(([0-9]*\\.?[0-9]*)D)?)?(T(([0-9]*\\.?[0-9]*)H)?(([0-9]*\\.?[0-9]*)M)?(([0-9]*\\.?[0-9]*)S)?)?" + RXF.noFlags + + +-------------------------------------------------------------------------------- +-- Accessors +-------------------------------------------------------------------------------- + +labelStrings ∷ ∀ f. Functor f ⇒ f SS.Label → f String +labelStrings = map case _ of + SS.Meta l → l + SS.Common l → l + +identOrString ∷ ∀ a. S.SqlF a → Maybe String +identOrString = case _ of + S.Ident s → Just s + S.StringLiteral s → Just s + _ → Nothing + +valueToString ∷ SS.Value → String +valueToString = case _ of + SS.Text v → v + SS.Tag v → v + +-------------------------------------------------------------------------------- +-- Predicate aggregations +-------------------------------------------------------------------------------- + +ors ∷ L.List S.Sql → S.Sql +ors = case _ of + L.Nil → S.bool false + hd : L.Nil → S.pars hd + hd : tl → F.foldl (\acc sql → S.binop S.Or acc $ S.pars sql) hd tl + +ands ∷ L.List S.Sql → S.Sql +ands = case _ of + L.Nil → S.bool true + hd : L.Nil → S.pars hd + hd : tl → F.foldl (\acc sql → S.binop S.And acc $ S.pars sql) hd tl + +-------------------------------------------------------------------------------- +-- Filtering only top fields +-------------------------------------------------------------------------------- + +data TopFieldMark + = Init + | TopField + | NotTopField + +isTop ∷ TopFieldMark → Boolean +isTop = case _ of + NotTopField → false + _ → true + +topFieldF ∷ Algebra S.SqlF TopFieldMark +topFieldF = case _ of + S.Splice Nothing → Init + S.StringLiteral _ → TopField + S.Ident _ → TopField + S.IntLiteral _ → TopField + S.Binop { op: S.FieldDeref, lhs: Init, rhs: TopField } → TopField + S.Binop { op: S.IndexDeref, lhs: Init, rhs: TopField } → TopField + _ → NotTopField + +isTopField ∷ S.Sql → Boolean +isTopField = isTop ∘ cata topFieldF + +-------------------------------------------------------------------------------- +-- Flattening all array derefs ( `foo[1]` → `foo[*]` ) +-------------------------------------------------------------------------------- + +flattenIndexF ∷ ∀ t. Transform t S.SqlF S.SqlF +flattenIndexF = case _ of + S.Binop { op: S.IndexDeref, lhs } → S.Unop { op: S.FlattenArrayValues, expr: lhs } + s → s + +flattenIndex ∷ S.Sql → S.Sql +flattenIndex = transAna flattenIndexF + +-------------------------------------------------------------------------------- +-- Searching for flatten values ({*}, [*]) +-------------------------------------------------------------------------------- + +needDistinctF ∷ Algebra S.SqlF Boolean +needDistinctF = case _ of + S.Unop { op: S.FlattenArrayValues } → true + S.Unop { op: S.FlattenMapValues } → true + S.Binop { lhs, rhs } → lhs || rhs + _ → false + +needDistinct ∷ S.Sql → Boolean +needDistinct = cata needDistinctF + +-------------------------------------------------------------------------------- +-- Interpretation +-------------------------------------------------------------------------------- + +termToSql ∷ L.List S.Sql → SS.Term → S.Sql +termToSql fields (SS.Term { include, predicate, labels}) + | not include = + S.unop S.Not $ S.pars $ termToSql fields $ SS.Term { include: true, predicate, labels} + | otherwise = + ors $ flip predicateToSql predicate <$> L.filter (labelsConform labels) fields + +-- | This function checks if Sql field is conforming search label list +labelsConform ∷ L.List SS.Label → S.Sql → Boolean +labelsConform ls = elgotZygo listIndexF $ labelsConformF $ labelStrings ls + +-- | Algebra of deref depth +listIndexF ∷ Algebra S.SqlF (Maybe Int) +listIndexF = case _ of + S.Splice Nothing → Just 0 + S.Splice (Just i) → map (add one) i + S.Binop { op: S.FieldDeref, lhs: Just i } → Just $ i + one + S.Binop { op: S.IndexDeref, lhs: Just i } → Just $ i + one + S.Unop { op: S.FlattenArrayValues, expr: Just i } → Just $ i + one + S.Unop { op: S.FlattenMapValues, expr: Just i } → Just $ i + one + _ → Nothing + +-- | Algebra checking that deref rhs conforms label from label list +labelsConformF ∷ L.List String → ElgotAlgebra (Tuple (Maybe Int)) S.SqlF Boolean +labelsConformF labelsString (mbIx × sqlF) = case sqlF of + S.Splice acc → + fromMaybe false acc && ixedLabel == Just "*" + S.IntLiteral i → + fromMaybe false $ ixedLabel >>= Int.fromString ⋙ map (eq i) + S.StringLiteral i → + ixedLabel == Just i + S.Ident i → + ixedLabel == Just i + S.Unop {op: S.FlattenArrayValues, expr} → + expr && (ixedLabel == Just "*" || ixedLabel == Just "[*]") + S.Unop {op: S.FlattenMapValues, expr} → + expr && (ixedLabel == Just "*" || ixedLabel == Just "{*}") + S.Binop { op: S.FieldDeref, lhs, rhs } → + lhs && rhs + S.Binop { op: S.IndexDeref, lhs, rhs } → + lhs && rhs + _ → + false + where + ixedLabel ∷ Maybe String + ixedLabel = mbIx >>= L.index labelsString + + +-- | Getting sql field and search predicate construct sql predicate +predicateToSql ∷ S.Sql → SS.Predicate → S.Sql +predicateToSql field = case _ of + SS.Contains (SS.Text v) → + ors + $ (pure + $ S.invokeFunction "search" + $ field + : (S.string $ globToRegex $ containsToGlob v) + : S.bool true + : L.Nil + ) + <> (sqlsFromSearchStr v <#> S.binop S.Eq field) + SS.Range (SS.Text v) (SS.Text vv) → + ors + $ ( pure $ S.binop S.And + ( S.pars $ S.binop S.Ge (lower field) (lower $ S.string v)) + ( S.pars $ S.binop S.Le (lower field) (lower $ S.string vv)) + ) + <> do + start ← sqlsFromSearchStr v + end ← sqlsFromSearchStr vv + pure $ S.binop S.And + ( S.pars $ S.binop S.Ge field start ) + ( S.pars $ S.binop S.Le field end ) + SS.Range (SS.Tag val) vv → + predicateToSql field $ SS.Range (SS.Text val) vv + SS.Range val (SS.Tag vv) → + predicateToSql field $ SS.Range val (SS.Text vv) + SS.Contains (SS.Tag v) → + predicateToSql field $ SS.Contains $ SS.Text v + + SS.Eq v → renderBinRel S.Eq $ valueToString v + SS.Gt v → renderBinRel S.Gt $ valueToString v + SS.Gte v → renderBinRel S.Ge $ valueToString v + SS.Lt v → renderBinRel S.Lt $ valueToString v + SS.Lte v → renderBinRel S.Le $ valueToString v + SS.Ne v → renderBinRel S.Neq $ valueToString v + SS.Like v → + S.invokeFunction "search" + $ field : S.string v : S.bool true : L.Nil + where + renderBinRel ∷ S.BinaryOperator → String → S.Sql + renderBinRel op v = + ors + $ ( pure $ S.binop op (lower field) (lower $ S.string v)) + <> ( sqlsFromSearchStr v <#> S.binop op field) + + sqlsFromSearchStr ∷ String → L.List S.Sql + sqlsFromSearchStr v = + (flip F.foldMap (stringToNumber v) $ pure ∘ S.num) + <> (flip F.foldMap (Int.fromString v) $ pure ∘ S.int) + <> (flip F.foldMap (stringToBoolean v) $ pure ∘ S.bool) + <> ((guard ((not $ needDateTime v) && needDate v)) $> + S.invokeFunction "DATE" (S.string v : L.Nil)) + <> (guard (needTime v) $> + S.invokeFunction "TIME" (S.string v : L.Nil)) + <> (guard (needDateTime v) $> + S.invokeFunction "TIMESTAMP" (S.string v : L.Nil)) + <> (guard (needInterval v) $> + S.invokeFunction "INTERVAL" (S.string v : L.Nil)) + + lower ∷ S.Sql → S.Sql + lower = S.invokeFunction "LOWER" ∘ pure + +globToRegex ∷ String → String +globToRegex = + (\x → "^" <> x <> "$") + ∘ RX.replace askRegex "." + ∘ RX.replace starRegex ".*" + ∘ RX.replace globEscapeRegex "\\$&" + where + globEscapeRegex = + URX.unsafeRegex + "[\\-\\[\\]\\/\\{\\}\\(\\)\\+\\.\\\\\\^\\$\\|]" + RXF.global + + starRegex = + URX.unsafeRegex + "\\*" RXF.global + askRegex = + URX.unsafeRegex + "\\?" RXF.global + +containsToGlob ∷ String → String +containsToGlob v + | hasSpecialChars v = v + | otherwise = "*" <> v <> "*" + +hasSpecialChars ∷ String → Boolean +hasSpecialChars v = + isJust (Str.indexOf (Str.Pattern "*") v) || isJust (Str.indexOf (Str.Pattern "?") v) + +-------------------------------------------------------------------------------- +-- Interpreter entry point +-------------------------------------------------------------------------------- + +queryToSql + ∷ L.List S.Sql + → SS.SearchQuery + → S.FUPath + → S.Sql +queryToSql fields query tablePath = + S.buildSelect + $ (S._isDistinct .~ isDistinct) + ∘ (S._projections .~ topFields) + ∘ (S._relations ?~ S.TableRelation { alias: Nothing, tablePath }) + ∘ (S._filter ?~ filter) + where + topFields = + map (S.Projection ∘ { expr: _, alias: Nothing}) $ L.filter isTopField fields + + isDistinct = F.any needDistinct $ map flattenIndex fields + + filter = + ands + $ map ors + $ unwrap + $ map (termToSql fields) query + +-------------------------------------------------------------------------------- +-- Tests +-------------------------------------------------------------------------------- + +testSuite ∷ ∀ e. TestSuite e +testSuite = + suite "purescript-search interpreter tests" do + test "dummy" do + Assert.equal true true From 2fc907c433e03a9612f8225f47d0f19c32029333 Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Wed, 8 Mar 2017 18:34:06 +0300 Subject: [PATCH 11/19] done --- .travis.yml | 16 ++-- README.md | 22 +++++ bower.json | 48 ++++++----- src/SqlSquare/AST.purs | 4 +- test/src/Search.purs | 178 ++++++++++++++++++++++++++++------------- 5 files changed, 185 insertions(+), 83 deletions(-) create mode 100644 README.md diff --git a/.travis.yml b/.travis.yml index a5c107e..0dc0abd 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,10 +1,16 @@ language: node_js dist: trusty sudo: required -node_js: - - 6 +node_js: stable install: - - npm install pulp bower -g - - npm install && bower install + - npm install -g bower + - npm install + - bower install script: - - npm run test + - npm run -s build + - npm run -s test +after_success: +- >- + test $TRAVIS_TAG && + echo $GITHUB_TOKEN | pulp login && + echo y | pulp publish --no-push diff --git a/README.md b/README.md new file mode 100644 index 0000000..d987f21 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +# purescript-sqlsquare + +[![Latest release](http://img.shields.io/github/release/slamdata/purescript-sqlsquare.svg)](https://github.com/slamdata/purescript-sqlsquare/releases) +[![Build status](https://travis-ci.org/slamdata/purescript-sqlsquare.svg?branch=master)](https://travis-ci.org/slamdata/purescript-sqlsquare) + +AST and printer for SQL² -- query language used by [quasar](https://github.com/quasar-analytics/quasar). + +## Instalation + +``` +bower install purescript-sqlsquare +``` + +## Documentation + +There are two examples (extracted from [slamdata](https://github.com/slamdata/slamdata)) ++ Extraction sql fields from array of jsons: [here](test/src/Test/Argonaut.purs) ++ Interpretation query language of [purescript-search](https://github.com/slamdata/purescript-search): +[here](test/src/Test/Search.purs) + + +Module documentation is published on Pursuit: [http://pursuit.purescript.org/packages/purescript-sqlsquare](http://pursuit.purescript.org/packages/purescript-sqlsquare) diff --git a/bower.json b/bower.json index 5e15355..c6195c2 100644 --- a/bower.json +++ b/bower.json @@ -1,22 +1,30 @@ { - "name": "purescript-sqlsquare", - "ignore": [ - "**/.*", - "node_modules", - "bower_components", - "output" - ], - "dependencies": { - "purescript-prelude": "^2.4.0", - "purescript-matryoshka": "^0.1.1", - "purescript-pathy": "^3.0.2", - "purescript-profunctor": "^2.0.0", - "purescript-profunctor-lenses": "^2.6.0" - }, - "devDependencies": { - "purescript-argonaut": "^2.0.0", - "purescript-search": "^2.0.0", - "purescript-debug": "^2.0.0", - "purescript-test-unit": "^10.1.0" - } + "name": "purescript-sqlsquare", + "homepage": "https://github.com/slamdata/purescript-sqlsquare", + "license": "Apache-2.0", + "repository": { + "type": "git", + "url": "git://github.com/slamdata/purescript-sqlsquare.git" + }, + "ignore": [ + "**/.*", + "node_modules", + "bower_components", + "output", + "bower.json", + "package.json" + ], + "dependencies": { + "purescript-prelude": "^2.4.0", + "purescript-matryoshka": "^0.2.0", + "purescript-pathy": "^3.0.2", + "purescript-profunctor": "^2.0.0", + "purescript-profunctor-lenses": "^2.6.0" + }, + "devDependencies": { + "purescript-argonaut": "^2.0.0", + "purescript-search": "^2.0.0", + "purescript-debug": "^2.0.0", + "purescript-test-unit": "^10.1.0" + } } diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index 68acdbf..4c86997 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -46,7 +46,9 @@ import SqlSquare.OrderBy (OrderBy(..), printOrderBy) import SqlSquare.Projection (Projection(..), printProjection) import SqlSquare.Relation (Relation(..), printRelation, FUPath, JoinRelR, ExprRelR, TableRelR, VariRelR, IdentRelR) -import Matryoshka (class Recursive, Algebra, cata) +import Matryoshka (class Recursive, Algebra, cata, transParaT, project) + +import Debug.Trace as DT type BinopR a = { lhs ∷ a diff --git a/test/src/Search.purs b/test/src/Search.purs index 141be22..b8b507b 100644 --- a/test/src/Search.purs +++ b/test/src/Search.purs @@ -5,31 +5,39 @@ module Test.Search where import Prelude +import Control.Alt ((<|>)) import Control.MonadZero (guard) +import Data.Argonaut as JS +import Data.Either (Either(..), fromRight) import Data.Foldable as F import Data.Int as Int import Data.Lens ((.~), (?~)) import Data.List ((:)) import Data.List as L -import Data.Maybe (Maybe(..), fromMaybe, isJust) +import Data.Maybe (Maybe(..), isJust, fromJust, fromMaybe) import Data.Newtype (unwrap) +import Data.Path.Pathy as Pt import Data.String as Str import Data.String.Regex as RX import Data.String.Regex.Flags as RXF import Data.String.Regex.Unsafe as URX -import Data.Tuple (Tuple) import Global (readFloat, isNaN) import SqlSquare as S -import SqlSquare.Utils ((∘), (×), (⋙)) +import SqlSquare.Utils ((∘), (×)) -import Matryoshka (Algebra, Transform, ElgotAlgebra, cata, transAna, elgotZygo) +import Matryoshka (Algebra, Coalgebra, Transform, ana, cata, transAna) + +import Partial.Unsafe (unsafePartial) import Test.Unit (suite, test, TestSuite) import Test.Unit.Assert as Assert +import Test.Argonaut as Ar + +import Text.SlamSearch (mkQuery) import Text.SlamSearch.Types as SS -------------------------------------------------------------------------------- @@ -87,8 +95,8 @@ needInterval = RX.test intervalRegex -- Accessors -------------------------------------------------------------------------------- -labelStrings ∷ ∀ f. Functor f ⇒ f SS.Label → f String -labelStrings = map case _ of +labelString ∷ SS.Label → String +labelString = case _ of SS.Meta l → l SS.Common l → l @@ -164,10 +172,32 @@ flattenIndex = transAna flattenIndexF needDistinctF ∷ Algebra S.SqlF Boolean needDistinctF = case _ of + S.SetLiteral ns → F.or ns + S.ArrayLiteral ns → F.or ns + S.MapLiteral tpls → F.any (\(a × b) → a || b) tpls + S.Splice Nothing → false + S.Splice (Just a) → a + S.Binop { lhs, rhs } → lhs || rhs S.Unop { op: S.FlattenArrayValues } → true S.Unop { op: S.FlattenMapValues } → true - S.Binop { lhs, rhs } → lhs || rhs - _ → false + S.Unop { expr } → expr + S.Ident _ → false + S.InvokeFunction { args } → F.or args + S.Match { expr, cases, else_ } → + expr || F.any (\(S.Case { cond, expr: e }) → e || cond) cases || fromMaybe false else_ + S.Switch { cases, else_ } → + F.any (\(S.Case { cond, expr }) → cond || expr) cases || fromMaybe false else_ + S.Let { bindTo, in_ } → + bindTo || in_ + S.IntLiteral _ → false + S.StringLiteral _ → false + S.FloatLiteral _ → false + S.NullLiteral → false + S.BoolLiteral _ → false + S.Vari _ → false + S.Parens a → a + S.Select { projections, filter } → + F.any (\(S.Projection { expr }) → expr) projections || fromMaybe false filter needDistinct ∷ S.Sql → Boolean needDistinct = cata needDistinctF @@ -176,53 +206,43 @@ needDistinct = cata needDistinctF -- Interpretation -------------------------------------------------------------------------------- +extractFields ∷ SS.Term → Maybe S.Sql +extractFields (SS.Term { labels }) + | L.null labels = Nothing + | otherwise = Just $ ana labelToFieldF $ map labelString $ L.reverse labels + termToSql ∷ L.List S.Sql → SS.Term → S.Sql -termToSql fields (SS.Term { include, predicate, labels}) +termToSql fs (SS.Term { include, predicate, labels}) | not include = - S.unop S.Not $ S.pars $ termToSql fields $ SS.Term { include: true, predicate, labels} + S.unop S.Not $ termToSql fields $ SS.Term { include: true, predicate, labels} | otherwise = - ors $ flip predicateToSql predicate <$> L.filter (labelsConform labels) fields - --- | This function checks if Sql field is conforming search label list -labelsConform ∷ L.List SS.Label → S.Sql → Boolean -labelsConform ls = elgotZygo listIndexF $ labelsConformF $ labelStrings ls - --- | Algebra of deref depth -listIndexF ∷ Algebra S.SqlF (Maybe Int) -listIndexF = case _ of - S.Splice Nothing → Just 0 - S.Splice (Just i) → map (add one) i - S.Binop { op: S.FieldDeref, lhs: Just i } → Just $ i + one - S.Binop { op: S.IndexDeref, lhs: Just i } → Just $ i + one - S.Unop { op: S.FlattenArrayValues, expr: Just i } → Just $ i + one - S.Unop { op: S.FlattenMapValues, expr: Just i } → Just $ i + one - _ → Nothing - --- | Algebra checking that deref rhs conforms label from label list -labelsConformF ∷ L.List String → ElgotAlgebra (Tuple (Maybe Int)) S.SqlF Boolean -labelsConformF labelsString (mbIx × sqlF) = case sqlF of - S.Splice acc → - fromMaybe false acc && ixedLabel == Just "*" - S.IntLiteral i → - fromMaybe false $ ixedLabel >>= Int.fromString ⋙ map (eq i) - S.StringLiteral i → - ixedLabel == Just i - S.Ident i → - ixedLabel == Just i - S.Unop {op: S.FlattenArrayValues, expr} → - expr && (ixedLabel == Just "*" || ixedLabel == Just "[*]") - S.Unop {op: S.FlattenMapValues, expr} → - expr && (ixedLabel == Just "*" || ixedLabel == Just "{*}") - S.Binop { op: S.FieldDeref, lhs, rhs } → - lhs && rhs - S.Binop { op: S.IndexDeref, lhs, rhs } → - lhs && rhs - _ → - false + ors + $ flip predicateToSql predicate + <$> (if L.null labels then fs else pure $ labelsToField labels) + + +labelToFieldF ∷ Coalgebra S.SqlF (L.List String) +labelToFieldF = case _ of + L.Nil → S.Splice Nothing + hd : L.Nil → case toInt hd of + Just i → S.IntLiteral i + Nothing → S.Ident hd + hd : tl → case toInt hd of + Just i → S.Binop { op: S.IndexDeref, lhs: tl, rhs: pure hd } + Nothing → case hd of + "[*]" → S.Unop { op: S.FlattenArrayValues, expr: tl } + "{*}" → S.Unop { op: S.FlattenMapValues, expr: tl } + "*" → S.Unop { op: S.FlattenMapValues, expr: tl } + a → S.Binop { op: S.FieldDeref, lhs: tl, rhs: pure hd } where - ixedLabel ∷ Maybe String - ixedLabel = mbIx >>= L.index labelsString + toInt ∷ String → Maybe Int + toInt s = + (Int.fromString s) + <|> (Str.stripSuffix (Str.Pattern "]") s >>= Str.stripPrefix (Str.Pattern "[") >>= Int.fromString) + +labelsToField ∷ L.List SS.Label → S.Sql +labelsToField = ana labelToFieldF ∘ map labelString ∘ L.reverse -- | Getting sql field and search predicate construct sql predicate predicateToSql ∷ S.Sql → SS.Predicate → S.Sql @@ -326,30 +346,74 @@ queryToSql → SS.SearchQuery → S.FUPath → S.Sql -queryToSql fields query tablePath = +queryToSql fs query path = S.buildSelect $ (S._isDistinct .~ isDistinct) ∘ (S._projections .~ topFields) - ∘ (S._relations ?~ S.TableRelation { alias: Nothing, tablePath }) + ∘ (S._relations ?~ S.TableRelation { alias: Nothing, tablePath: path }) ∘ (S._filter ?~ filter) where topFields = - map (S.Projection ∘ { expr: _, alias: Nothing}) $ L.filter isTopField fields + map (S.Projection ∘ { expr: _, alias: Nothing}) $ L.filter isTopField fs - isDistinct = F.any needDistinct $ map flattenIndex fields + isDistinct = needDistinct filter filter = ands $ map ors $ unwrap - $ map (termToSql fields) query + $ map (termToSql $ map flattenIndex fs) query -------------------------------------------------------------------------------- -- Tests -------------------------------------------------------------------------------- +fields ∷ L.List S.Sql +fields = Ar.allFields jarray + where + jarray ∷ JS.JArray + jarray = map (unsafePartial fromRight ∘ JS.jsonParser) jsonStrings + + jsonStrings ∷ Array String + jsonStrings = + [ """{"foo": 1, "bar": 2}""" + , """{"foo": [1, 2], "bar": null}""" + , """{"foo": 3, "bar": { "valid": false, "value": "baz" } }""" + ] + +searchQueries ∷ L.List SS.SearchQuery +searchQueries = + F.foldMap (F.foldMap pure) $ map mkQuery searchStrings + where + searchStrings ∷ L.List String + searchStrings = + """ba""" + : """foo:"[*]":2""" + : """bar:>1""" + : """false""" + : """bar:valid:=false""" + : """"non-existing":foo""" + : L.Nil + +expectedOutput ∷ L.List String +expectedOutput = + """select distinct *.`bar`, *.`foo` from `/mongo/testDb/patients` where (((search(*.`bar`,"^.*ba.*$",true)) or ((search(*.`foo`,"^.*ba.*$",true))) or ((search(*.`bar`.`valid`,"^.*ba.*$",true))) or ((search(*.`bar`.`value`,"^.*ba.*$",true))) or ((search(*.`foo`[*],"^.*ba.*$",true))) or ((search(*.`foo`[*],"^.*ba.*$",true)))))""" + : """select distinct *.`bar`, *.`foo` from `/mongo/testDb/patients` where (((search(`foo`[*],"^.*2.*$",true) or (`foo`[*] = 2.0) or (`foo`[*] = 2))))""" + : """select *.`bar`, *.`foo` from `/mongo/testDb/patients` where (((LOWER(`bar`) > LOWER("1") or (`bar` > 1.0) or (`bar` > 1))))""" + : """select distinct *.`bar`, *.`foo` from `/mongo/testDb/patients` where ((search(*.`bar`,"^.*false.*$",true) or (*.`bar` = false) or (search(*.`foo`,"^.*false.*$",true) or (*.`foo` = false)) or (search(*.`bar`.`valid`,"^.*false.*$",true) or (*.`bar`.`valid` = false)) or (search(*.`bar`.`value`,"^.*false.*$",true) or (*.`bar`.`value` = false)) or (search(*.`foo`[*],"^.*false.*$",true) or (*.`foo`[*] = false)) or (search(*.`foo`[*],"^.*false.*$",true) or (*.`foo`[*] = false))))""" + : """select *.`bar`, *.`foo` from `/mongo/testDb/patients` where (((LOWER(`bar`.`valid`) = LOWER("false") or (`bar`.`valid` = false))))""" + : """select *.`bar`, *.`foo` from `/mongo/testDb/patients` where ((((search(`non-existing`,"^.*foo.*$",true)))))""" + : L.Nil + +tablePath ∷ S.FUPath +tablePath = Right $ unsafePartial fromJust $ Pt.parseAbsFile "/mongo/testDb/patients" + testSuite ∷ ∀ e. TestSuite e testSuite = suite "purescript-search interpreter tests" do - test "dummy" do - Assert.equal true true + test "search query is interpreted correctly" + let + querySqls = map (\sq → queryToSql fields sq tablePath) searchQueries + querySqlsStrings = map S.print querySqls + in + void $ L.zipWithA Assert.equal expectedOutput querySqlsStrings From d14cbf92a802371ef5da9fa35587519912747c4a Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Wed, 8 Mar 2017 18:35:14 +0300 Subject: [PATCH 12/19] readme --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index d987f21..7707e1c 100644 --- a/README.md +++ b/README.md @@ -14,9 +14,9 @@ bower install purescript-sqlsquare ## Documentation There are two examples (extracted from [slamdata](https://github.com/slamdata/slamdata)) -+ Extraction sql fields from array of jsons: [here](test/src/Test/Argonaut.purs) ++ Extraction sql fields from array of jsons: [here](test/src/Argonaut.purs) + Interpretation query language of [purescript-search](https://github.com/slamdata/purescript-search): -[here](test/src/Test/Search.purs) +[here](test/src/Search.purs) Module documentation is published on Pursuit: [http://pursuit.purescript.org/packages/purescript-sqlsquare](http://pursuit.purescript.org/packages/purescript-sqlsquare) From acde2850fb4173d2fa2a69650e0f157f116e0028 Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Thu, 9 Mar 2017 22:29:50 +0300 Subject: [PATCH 13/19] Literal, need manually implement Ord1 and Eq1 --- src/SqlSquare/AST.purs | 204 ++++++++++++++++++++++---------- src/SqlSquare/Case.purs | 10 ++ src/SqlSquare/Constructors.purs | 57 +++++---- src/SqlSquare/GroupBy.purs | 11 ++ src/SqlSquare/Lenses.purs | 137 +++++++++++++++------ src/SqlSquare/OrderBy.purs | 8 ++ src/SqlSquare/Projection.purs | 11 ++ src/SqlSquare/Relation.purs | 35 ++++++ 8 files changed, 347 insertions(+), 126 deletions(-) diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index 4c86997..a70ea2e 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -27,14 +27,18 @@ import Prelude import Data.Bifunctor (bimap) import Data.Eq (class Eq1) import Data.Foldable as F +import Data.Traversable as T import Data.Functor.Mu (Mu) import Data.List as L import Data.Maybe (Maybe(..)) +import Data.Monoid (mempty) import Data.Ord (class Ord1) import Data.String.Regex as RX import Data.String.Regex.Flags as RXF import Data.String.Regex.Unsafe as URX +import Data.Json.Extended.Signature (EJsonF, renderEJsonF) + import SqlSquare.Utils (type (×), (×), (∘), (⋙)) import SqlSquare.OrderType as OT import SqlSquare.JoinType as JT @@ -92,10 +96,9 @@ type SelectR a = , orderBy ∷ Maybe (OrderBy a) } -data SqlF a +data SqlF literal a = SetLiteral (L.List a) - | ArrayLiteral (L.List a) - | MapLiteral (L.List (a × a)) + | Literal (literal a) | Splice (Maybe a) | Binop (BinopR a) | Unop (UnopR a) @@ -104,24 +107,19 @@ data SqlF a | Match (MatchR a) | Switch (SwitchR a) | Let (LetR a) - | IntLiteral Int - | FloatLiteral Number - | StringLiteral String - | NullLiteral - | BoolLiteral Boolean | Vari String | Select (SelectR a) | Parens a -derive instance eqSqlF ∷ Eq a ⇒ Eq (SqlF a) -derive instance ordSqlF ∷ Ord a ⇒ Ord (SqlF a) +derive instance eqSqlF ∷ (Eq a, Eq (l a)) ⇒ Eq (SqlF l a) +derive instance ordSqlF ∷ (Ord a, Ord (l a)) ⇒ Ord (SqlF l a) + +--instance eq1SqlF ∷ Eq1 l ⇒ Eq1 (SqlF l) where -instance eq1SqlF ∷ Eq1 SqlF where - eq1 = eq -instance ord1SqlF ∷ Ord1 SqlF where - compare1 = compare +--instance ord1SqlF ∷ Ord (l a) ⇒ Ord1 (SqlF l) where +-- compare1 = compare -instance functorAST ∷ Functor SqlF where +instance functorAST ∷ Functor l ⇒ Functor (SqlF l) where map f = case _ of Select { isDistinct, projections, relations, filter, groupBy, orderBy } → Select { isDistinct @@ -133,23 +131,11 @@ instance functorAST ∷ Functor SqlF where } Vari s → Vari s - BoolLiteral b → - BoolLiteral b - NullLiteral → - NullLiteral - StringLiteral s → - StringLiteral s - FloatLiteral n → - FloatLiteral n - IntLiteral i → - IntLiteral i Let { ident, bindTo, in_ } → Let { ident , bindTo: f bindTo , in_: f in_ } - MapLiteral lst → - MapLiteral $ map (bimap f f) lst Splice a → Splice $ map f a Binop { lhs, rhs, op } → @@ -178,20 +164,136 @@ instance functorAST ∷ Functor SqlF where } SetLiteral lst → SetLiteral $ map f lst - ArrayLiteral lst → - ArrayLiteral $ map f lst + Literal l → + Literal $ map f l Parens t → Parens $ f t -printF ∷ Algebra SqlF String -printF = case _ of + +instance foldableSqlF ∷ F.Foldable l ⇒ F.Foldable (SqlF l) where + foldMap f = case _ of + Ident _ → mempty + SetLiteral lst → F.foldMap f lst + Splice mbA → F.foldMap f mbA + Binop { lhs, rhs } → f lhs <> f rhs + Unop { expr } → f expr + InvokeFunction { args } → F.foldMap f args + Match { expr, cases, else_ } → f expr <> F.foldMap (F.foldMap f) cases <> F.foldMap f else_ + Switch { cases, else_} → F.foldMap (F.foldMap f) cases <> F.foldMap f else_ + Let { bindTo, in_ } → f bindTo <> f in_ + Vari _ → mempty + Select { projections, relations, filter, groupBy, orderBy } → + F.foldMap (F.foldMap f) projections + <> F.foldMap (F.foldMap f) relations + <> F.foldMap f filter + <> F.foldMap (F.foldMap f) groupBy + <> F.foldMap (F.foldMap f) orderBy + Parens a → f a + Literal l → F.foldMap f l + foldl f a = case _ of + Ident _ → a + SetLiteral lst → F.foldl f a lst + Splice mbA → F.foldl f a mbA + Binop { lhs, rhs } → f (f a lhs) rhs + Unop { expr } → f a expr + InvokeFunction { args } → F.foldl f a args + Match { expr, cases, else_ } → + F.foldl f (F.foldl (F.foldl f) (f a expr) cases) else_ + Switch { cases, else_ } → + F.foldl f (F.foldl (F.foldl f) a cases) else_ + Let { bindTo, in_} → + f (f a bindTo) in_ + Vari _ → a + Select { projections, relations, filter, groupBy, orderBy } → + F.foldl (F.foldl f) + (F.foldl (F.foldl f) + (F.foldl f + (F.foldl (F.foldl f) + (F.foldl (F.foldl f) a + projections) + relations) + filter) + groupBy) + orderBy + Parens p → f a p + Literal l → F.foldl f a l + foldr f a = case _ of + Ident _ → a + SetLiteral lst → F.foldr f a lst + Splice mbA → F.foldr f a mbA + Binop { lhs, rhs } → f rhs $ f lhs a + Unop { expr } → f expr a + InvokeFunction { args } → F.foldr f a args + Match { expr, cases, else_ } → + F.foldr f (F.foldr (flip $ F.foldr f) (f expr a) cases) else_ + Switch { cases, else_ } → + F.foldr f (F.foldr (flip $ F.foldr f) a cases) else_ + Let { bindTo, in_ } → + f bindTo $ f in_ a + Vari _ → a + Select { projections, relations, filter, groupBy, orderBy } → + F.foldr (flip $ F.foldr f) + (F.foldr (flip $ F.foldr f) + (F.foldr f + (F.foldr (flip $ F.foldr f) + (F.foldr (flip $ F.foldr f) a + projections) + relations) + filter) + groupBy) + orderBy + Parens p → f p a + Literal l → F.foldr f a l + + + +instance traversableSqlF ∷ T.Traversable l ⇒ T.Traversable (SqlF l) where + traverse f = case _ of + SetLiteral lst → map SetLiteral $ T.traverse f lst + Literal l → map Literal $ T.traverse f l + Splice mbA → map Splice $ T.traverse f mbA + Binop { lhs, rhs, op } → + map Binop $ { lhs: _, rhs: _, op } <$> f lhs <*> f rhs + Unop { op, expr } → + map Unop $ { expr: _, op } <$> f expr + Ident s → pure $ Ident s + InvokeFunction { name, args } → + map InvokeFunction $ { name, args:_ } <$> T.traverse f args + Match { expr, cases, else_ } → + map Match + $ { expr: _, cases: _, else_: _ } + <$> f expr + <*> T.traverse (T.traverse f) cases + <*> T.traverse f else_ + Switch { cases, else_ } → + map Switch + $ { cases: _, else_: _ } + <$> T.traverse (T.traverse f) cases + <*> T.traverse f else_ + Let { bindTo, in_, ident } → + map Let + $ { bindTo: _, in_: _, ident } + <$> f bindTo + <*> f in_ + Vari s → pure $ Vari s + Parens p → map Parens $ f p + Select { isDistinct, projections, relations, filter, groupBy, orderBy } → + map Select + $ { isDistinct, projections: _, relations: _, filter: _, groupBy: _, orderBy: _} + <$> T.traverse (T.traverse f) projections + <*> T.traverse (T.traverse f) relations + <*> T.traverse f filter + <*> T.traverse (T.traverse f) groupBy + <*> T.traverse (T.traverse f) orderBy + sequence = T.sequenceDefault + +printF ∷ ∀ l. Algebra l String → Algebra (SqlF l) String +printF printLiteralF = case _ of + Splice Nothing → "*" + Splice (Just s) → s <> ".*" SetLiteral lst → "(" <> F.intercalate ", " lst <> ")" - ArrayLiteral lst → "[" <> F.intercalate ", " lst <> "]" - MapLiteral tplLst → "{" <> F.intercalate ", " (map (\(k × v) → k <> ": " <> v) tplLst) <> "}" - Splice mb → case mb of - Nothing → "*" - Just a → a <> ".*" + Literal l → printLiteralF l Binop {lhs, rhs, op} → case op of IfUndefined → lhs <> " ?? " <> rhs Range → lhs <> " .. " <> rhs @@ -252,16 +354,6 @@ printF = case _ of <> F.foldMap (" else " <> _) else_ Let { ident, bindTo, in_ } → ident <> " := " <> bindTo <> "; " <> in_ - IntLiteral int → - show int - FloatLiteral n → - show n - StringLiteral s → - renderString s - NullLiteral → - "null" - BoolLiteral b → - show b Vari s → ":" <> s Select { isDistinct, projections, relations, filter, groupBy, orderBy } → @@ -275,22 +367,8 @@ printF = case _ of <> (orderBy # F.foldMap \ob → " order by " <> printOrderBy ob) Parens t → "(" <> t <> ")" - where - replaceAll - ∷ String - → String - → String - → String - replaceAll i = - RX.replace $ URX.unsafeRegex i RXF.global - - renderString - ∷ String - → String - renderString str = - "\"" <> replaceAll "\"" "\\\"" str <> "\"" -type Sql = Mu SqlF +type Sql = Mu (SqlF EJsonF) -print ∷ ∀ t. Recursive t SqlF ⇒ t → String -print = cata printF +print ∷ Sql → String +print = cata (printF renderEJsonF) diff --git a/src/SqlSquare/Case.purs b/src/SqlSquare/Case.purs index e04fc30..5d89286 100644 --- a/src/SqlSquare/Case.purs +++ b/src/SqlSquare/Case.purs @@ -3,6 +3,8 @@ module SqlSquare.Case where import Prelude import Data.Newtype (class Newtype) +import Data.Foldable as F +import Data.Traversable as T import Matryoshka (Algebra) @@ -13,5 +15,13 @@ derive instance newtypeCase ∷ Newtype (Case a) _ derive instance eqCase ∷ Eq a ⇒ Eq (Case a) derive instance ordCase ∷ Ord a ⇒ Ord (Case a) +instance foldableCase ∷ F.Foldable Case where + foldMap f (Case { cond, expr }) = f expr + foldl f a (Case { cond, expr }) = f (f a cond) expr + foldr f a (Case { cond, expr }) = f cond $ f expr a +instance traversableCase ∷ T.Traversable Case where + traverse f (Case { cond, expr }) = map Case $ { cond: _, expr: _ } <$> f cond <*> f expr + sequence = T.sequenceDefault + printCase ∷ Algebra Case String printCase (Case { cond, expr }) = " when " <> cond <> " then " <> expr diff --git a/src/SqlSquare/Constructors.purs b/src/SqlSquare/Constructors.purs index 16467a3..11063b4 100644 --- a/src/SqlSquare/Constructors.purs +++ b/src/SqlSquare/Constructors.purs @@ -2,60 +2,67 @@ module SqlSquare.Constructors where import Prelude +import Data.Array as Arr +import Data.Json.Extended.Signature (EJsonF(..)) import Data.Foldable as F +import Data.HugeNum as HN import Data.List as L +import Data.Map as Map import Data.Maybe (Maybe(..)) import Matryoshka (class Corecursive, embed) import SqlSquare.AST (SqlF(..), Relation, GroupBy(..), OrderBy, BinaryOperator, UnaryOperator, (∘), SelectR, Case(..), Projection(..)) -vari ∷ ∀ t. Corecursive t SqlF ⇒ String → t +vari ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ String → t vari s = embed $ Vari s -bool ∷ ∀ t. Corecursive t SqlF ⇒ Boolean → t -bool b = embed $ BoolLiteral b +bool ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ Boolean → t +bool b = embed $ Literal $ Boolean b -null ∷ ∀ t. Corecursive t SqlF ⇒ t -null = embed NullLiteral +null ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ t +null = embed $ Literal Null -int ∷ ∀ t. Corecursive t SqlF ⇒ Int → t -int i = embed $ IntLiteral i +int ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ Int → t +int i = embed $ Literal $ Integer i -num ∷ ∀ t. Corecursive t SqlF ⇒ Number → t -num i = embed $ FloatLiteral i +num ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ Number → t +num i = embed $ Literal $ Decimal $ HN.fromNumber i -string ∷ ∀ t. Corecursive t SqlF ⇒ String → t -string s = embed $ StringLiteral s +string ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ String → t +string s = embed $ Literal $ String s -unop ∷ ∀ t. Corecursive t SqlF ⇒ UnaryOperator → t → t +unop ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ UnaryOperator → t → t unop op expr = embed $ Unop { op, expr } -binop ∷ ∀ t. Corecursive t SqlF ⇒ BinaryOperator → t → t → t +binop ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ BinaryOperator → t → t → t binop op lhs rhs = embed $ Binop { op, lhs, rhs } -set ∷ ∀ t f. (Corecursive t SqlF, F.Foldable f) ⇒ f t → t +set ∷ ∀ t f. (Corecursive t (SqlF EJsonF), F.Foldable f) ⇒ f t → t set l = embed $ SetLiteral $ L.fromFoldable l -array ∷ ∀ t f. (Corecursive t SqlF, F.Foldable f) ⇒ f t → t -array l = embed $ ArrayLiteral $ L.fromFoldable l +array ∷ ∀ t f. (Corecursive t (SqlF EJsonF), F.Foldable f) ⇒ f t → t +array l = embed $ Literal $ Array $ Arr.fromFoldable l -splice ∷ ∀ t. Corecursive t SqlF ⇒ Maybe t → t +map_ ∷ ∀ t. (Corecursive t (SqlF EJsonF), Ord t) ⇒ Map.Map t t → t +map_ m = embed $ Literal $ Map $ Arr.fromFoldable $ Map.toList m + +splice ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ Maybe t → t splice m = embed $ Splice m -ident ∷ ∀ t. Corecursive t SqlF ⇒ String → t +ident ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ String → t ident i = embed $ Ident i -match ∷ ∀ t. Corecursive t SqlF ⇒ t → L.List (Case t) → Maybe t → t +match ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ t → L.List (Case t) → Maybe t → t match expr cases else_ = embed $ Match { expr, cases, else_ } -switch ∷ ∀ t. Corecursive t SqlF ⇒ L.List (Case t) → Maybe t → t +switch ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ L.List (Case t) → Maybe t → t switch cases else_ = embed $ Switch { cases, else_ } -let_ ∷ ∀ t. Corecursive t SqlF ⇒ String → t → t → t +let_ ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ String → t → t → t let_ id bindTo in_ = embed $ Let { ident: id, bindTo, in_ } -invokeFunction ∷ ∀ t. Corecursive t SqlF ⇒ String → L.List t → t +invokeFunction ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ String → L.List t → t invokeFunction name args = embed $ InvokeFunction {name, args} -- when (bool true) # then (num 1.0) :P @@ -67,7 +74,7 @@ then_ f t = f t select ∷ ∀ t f - . (Corecursive t SqlF, F.Foldable f) + . (Corecursive t (SqlF EJsonF), F.Foldable f) ⇒ Boolean → f (Projection t) → Maybe (Relation t) @@ -99,7 +106,7 @@ groupBy f = GroupBy { keys: L.fromFoldable f, having: Nothing } having ∷ ∀ t. t → GroupBy t → GroupBy t having t (GroupBy r) = GroupBy r{ having = Just t } -buildSelect ∷ ∀ t. Corecursive t SqlF ⇒ (SelectR t → SelectR t) → t +buildSelect ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ (SelectR t → SelectR t) → t buildSelect f = embed $ Select $ f { isDistinct: false , projections: L.Nil @@ -109,5 +116,5 @@ buildSelect f = , orderBy: Nothing } -pars ∷ ∀ t. Corecursive t SqlF ⇒ t → t +pars ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ t → t pars = embed ∘ Parens diff --git a/src/SqlSquare/GroupBy.purs b/src/SqlSquare/GroupBy.purs index e12ad9f..56d56eb 100644 --- a/src/SqlSquare/GroupBy.purs +++ b/src/SqlSquare/GroupBy.purs @@ -3,6 +3,7 @@ module SqlSquare.GroupBy where import Prelude import Data.Foldable as F +import Data.Traversable as T import Data.List as L import Data.Maybe (Maybe) import Data.Newtype (class Newtype) @@ -15,6 +16,16 @@ derive instance functorGroupBy ∷ Functor GroupBy derive instance eqGroupBy ∷ Eq a ⇒ Eq (GroupBy a) derive instance ordGroupBy ∷ Ord a ⇒ Ord (GroupBy a) +instance foldableGroupBy ∷ F.Foldable GroupBy where + foldMap f (GroupBy { keys, having }) = F.foldMap f keys <> F.foldMap f having + foldl f a (GroupBy { keys, having }) = F.foldl f (F.foldl f a keys) having + foldr f a (GroupBy { keys, having }) = F.foldr f (F.foldr f a having) keys + +instance traversableGroupBy ∷ T.Traversable GroupBy where + traverse f (GroupBy { keys, having }) = + map GroupBy $ {keys: _, having: _} <$> T.traverse f keys <*> T.traverse f having + sequence = T.sequenceDefault + printGroupBy ∷ Algebra GroupBy String printGroupBy (GroupBy { keys, having }) = F.intercalate ", " keys <> F.foldMap (" having " <> _) having diff --git a/src/SqlSquare/Lenses.purs b/src/SqlSquare/Lenses.purs index 064a972..b86a184 100644 --- a/src/SqlSquare/Lenses.purs +++ b/src/SqlSquare/Lenses.purs @@ -2,10 +2,12 @@ module SqlSquare.Lenses where import Prelude -import Data.Lens (Prism', prism', Lens', lens, Iso', iso) +import Data.HugeNum as HN +import Data.Json.Extended as EJ +import Data.Lens (Prism', prism', Lens', lens, Iso') +import Data.Lens.Iso.Newtype (_Newtype) import Data.List as L import Data.Maybe as M -import Data.Newtype (class Newtype, wrap, unwrap) import Data.NonEmpty as NE import Matryoshka (class Recursive, class Corecursive, embed, project) @@ -13,9 +15,6 @@ import Matryoshka (class Recursive, class Corecursive, embed, project) import SqlSquare.AST as S import SqlSquare.Utils (type (×), (∘), (⋙)) -_Newtype ∷ ∀ n t. Newtype n t ⇒ Iso' n t -_Newtype = iso unwrap wrap - _GroupBy ∷ ∀ a. Iso' (S.GroupBy a) {keys ∷ L.List a, having ∷ M.Maybe a} _GroupBy = _Newtype @@ -136,97 +135,159 @@ _tablePath ∷ ∀ a r. Lens' { tablePath ∷ a|r } a _tablePath = lens _.tablePath _{ tablePath = _ } -_SetLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (L.List t) +_SetLiteral + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t (L.List t) _SetLiteral = prism' (embed ∘ S.SetLiteral) $ project ⋙ case _ of S.SetLiteral lst → M.Just lst _ → M.Nothing -_ArrayLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (L.List t) -_ArrayLiteral = prism' (embed ∘ S.ArrayLiteral) $ project ⋙ case _ of - S.ArrayLiteral lst → M.Just lst +_Literal + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t (EJ.EJsonF t) +_Literal = prism' (embed ∘ S.Literal) $ project ⋙ case _ of + S.Literal js → M.Just js + _ → M.Nothing + +_ArrayLiteral + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t (Array t) +_ArrayLiteral = prism' (embed ∘ S.Literal ∘ EJ.Array) $ project ⋙ case _ of + S.Literal (EJ.Array a) → M.Just a _ → M.Nothing -_MapLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (L.List (t × t)) -_MapLiteral = prism' (embed ∘ S.MapLiteral) $ project ⋙ case _ of - S.MapLiteral tpls → M.Just tpls +_MapLiteral + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t (Array (t × t)) +_MapLiteral = prism' (embed ∘ S.Literal ∘ EJ.Map) $ project ⋙ case _ of + S.Literal (EJ.Map tpls) → M.Just tpls _ → M.Nothing -_Splice ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (M.Maybe t) +_Splice + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t (M.Maybe t) _Splice = prism' (embed ∘ S.Splice) $ project ⋙ case _ of S.Splice m → M.Just m _ → M.Nothing -_Binop ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.BinopR t) +_Binop + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t (S.BinopR t) _Binop = prism' (embed ∘ S.Binop) $ project ⋙ case _ of S.Binop b → M.Just b _ → M.Nothing -_Unop ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.UnopR t) +_Unop + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t (S.UnopR t) _Unop = prism' (embed ∘ S.Unop) $ project ⋙ case _ of S.Unop r → M.Just r _ → M.Nothing -_Ident ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t String +_Ident + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t String _Ident = prism' (embed ∘ S.Ident) $ project ⋙ case _ of S.Ident s → M.Just s _ → M.Nothing -_InvokeFunction ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.InvokeFunctionR t) +_InvokeFunction + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t (S.InvokeFunctionR t) _InvokeFunction = prism' (embed ∘ S.InvokeFunction) $ project ⋙ case _ of S.InvokeFunction r → M.Just r _ → M.Nothing -_Match ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.MatchR t) +_Match + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t (S.MatchR t) _Match = prism' (embed ∘ S.Match) $ project ⋙ case _ of S.Match r → M.Just r _ → M.Nothing -_Switch ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.SwitchR t) +_Switch + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t (S.SwitchR t) _Switch = prism' (embed ∘ S.Switch) $ project ⋙ case _ of S.Switch r → M.Just r _ → M.Nothing -_Let ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.LetR t) +_Let + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t (S.LetR t) _Let = prism' (embed ∘ S.Let) $ project ⋙ case _ of S.Let r → M.Just r _ → M.Nothing -_IntLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t Int -_IntLiteral = prism' (embed ∘ S.IntLiteral) $ project ⋙ case _ of - S.IntLiteral r → M.Just r +_IntLiteral + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t Int +_IntLiteral = prism' (embed ∘ S.Literal ∘ EJ.Integer) $ project ⋙ case _ of + S.Literal (EJ.Integer r) → M.Just r _ → M.Nothing -_FloatLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t Number -_FloatLiteral = prism' (embed ∘ S.FloatLiteral) $ project ⋙ case _ of - S.FloatLiteral r → M.Just r +_DecimalLiteral + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t HN.HugeNum +_DecimalLiteral = prism' (embed ∘ S.Literal ∘ EJ.Decimal) $ project ⋙ case _ of + S.Literal (EJ.Decimal r) → M.Just r _ → M.Nothing -_StringLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t String -_StringLiteral = prism' (embed ∘ S.StringLiteral) $ project ⋙ case _ of - S.StringLiteral r → M.Just r +_StringLiteral + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t String +_StringLiteral = prism' (embed ∘ S.Literal ∘ EJ.String) $ project ⋙ case _ of + S.Literal (EJ.String r) → M.Just r _ → M.Nothing -_NullLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t Unit -_NullLiteral = prism' (const $ embed $ S.NullLiteral) $ project ⋙ case _ of - S.NullLiteral → M.Just unit +_NullLiteral + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t Unit +_NullLiteral = prism' (const $ embed $ S.Literal EJ.Null) $ project ⋙ case _ of + S.Literal EJ.Null → M.Just unit _ → M.Nothing -_BoolLiteral ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t Boolean -_BoolLiteral = prism' (embed ∘ S.BoolLiteral) $ project ⋙ case _ of - S.BoolLiteral b → M.Just b +_BoolLiteral + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t Boolean +_BoolLiteral = prism' (embed ∘ S.Literal ∘ EJ.Boolean) $ project ⋙ case _ of + S.Literal (EJ.Boolean b) → M.Just b _ → M.Nothing -_Vari ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t String +_Vari + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t String _Vari = prism' (embed ∘ S.Vari) $ project ⋙ case _ of S.Vari r → M.Just r _ → M.Nothing -_Select ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t (S.SelectR t) +_Select + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t (S.SelectR t) _Select = prism' (embed ∘ S.Select) $ project ⋙ case _ of S.Select r → M.Just r _ → M.Nothing -_Parens ∷ ∀ t. (Recursive t S.SqlF, Corecursive t S.SqlF) ⇒ Prism' t t +_Parens ∷ ∀ t. (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) ⇒ Prism' t t _Parens = prism' (embed ∘ S.Parens) $ project ⋙ case _ of S.Parens t → M.Just t _ → M.Nothing diff --git a/src/SqlSquare/OrderBy.purs b/src/SqlSquare/OrderBy.purs index 90a5b38..77c6c2e 100644 --- a/src/SqlSquare/OrderBy.purs +++ b/src/SqlSquare/OrderBy.purs @@ -3,6 +3,7 @@ module SqlSquare.OrderBy where import Prelude import Data.Foldable as F +import Data.Traversable as T import Data.List as L import Data.Newtype (class Newtype) import Data.NonEmpty as NE @@ -18,6 +19,13 @@ derive instance functorOrderBy ∷ Functor OrderBy derive instance newtypeOrderBy ∷ Newtype (OrderBy a) _ derive instance eqOrderBy ∷ Eq a ⇒ Eq (OrderBy a) derive instance ordOrderBy ∷ Ord a ⇒ Ord (OrderBy a) +instance foldableOrderBy ∷ F.Foldable OrderBy where + foldMap f (OrderBy xs) = F.foldMap (F.foldMap f) xs + foldl f a (OrderBy xs) = F.foldl (F.foldl f) a xs + foldr f a (OrderBy xs) = F.foldr (flip (F.foldr f)) a xs +instance traversableOrderBy ∷ T.Traversable OrderBy where + traverse f (OrderBy xs) = map OrderBy $ T.traverse (T.traverse f) xs + sequence = T.sequenceDefault printOrderBy ∷ Algebra OrderBy String printOrderBy (OrderBy lst) = diff --git a/src/SqlSquare/Projection.purs b/src/SqlSquare/Projection.purs index 304c788..61aba58 100644 --- a/src/SqlSquare/Projection.purs +++ b/src/SqlSquare/Projection.purs @@ -3,17 +3,28 @@ module SqlSquare.Projection where import Prelude import Data.Foldable as F +import Data.Traversable as T import Data.Maybe (Maybe) import Data.Newtype (class Newtype) import Matryoshka (Algebra) +import SqlSquare.Utils ((∘)) + newtype Projection a = Projection { expr ∷ a, alias ∷ Maybe String } derive instance functorProjection ∷ Functor Projection derive instance newtypeProjection ∷ Newtype (Projection a) _ derive instance eqProjection ∷ Eq a ⇒ Eq (Projection a) derive instance ordProjection ∷ Ord a ⇒ Ord (Projection a) +instance foldableProjection ∷ F.Foldable Projection where + foldMap f (Projection { expr }) = f expr + foldl f a (Projection { expr }) = f a expr + foldr f a (Projection { expr }) = f expr a +instance traversableProjection ∷ T.Traversable Projection where + traverse f (Projection { expr, alias }) = + map (Projection ∘ { expr: _, alias}) $ f expr + sequence = T.sequenceDefault printProjection ∷ Algebra Projection String printProjection (Projection { expr, alias }) = expr <> F.foldMap (" as " <> _) alias diff --git a/src/SqlSquare/Relation.purs b/src/SqlSquare/Relation.purs index e5c3011..d9b708a 100644 --- a/src/SqlSquare/Relation.purs +++ b/src/SqlSquare/Relation.purs @@ -4,12 +4,15 @@ import Prelude import Data.Either (Either, either) import Data.Foldable as F +import Data.Monoid (mempty) +import Data.Traversable as T import Data.Maybe (Maybe) import Data.Path.Pathy (AbsFile, RelFile, Unsandboxed, unsafePrintPath) import Matryoshka (Algebra) import SqlSquare.JoinType as JT +import SqlSquare.Utils ((∘)) type FUPath = Either (RelFile Unsandboxed) (AbsFile Unsandboxed) @@ -50,6 +53,38 @@ data Relation a derive instance functorRelation ∷ Functor Relation derive instance eqRelation ∷ Eq a ⇒ Eq (Relation a) derive instance ordRelation ∷ Ord a ⇒ Ord (Relation a) +instance foldableRelation ∷ F.Foldable Relation where + foldMap f = case _ of + JoinRelation { left, right, clause } → F.foldMap f left <> F.foldMap f right <> f clause + ExprRelation { expr } → f expr + _ → mempty + foldl f a = case _ of + JoinRelation { left, right, clause } → + f (F.foldl f (F.foldl f a left) right) clause + ExprRelation { expr } → + f a expr + _ → a + foldr f a = case _ of + JoinRelation { left, right, clause } → + F.foldr f (F.foldr f (f clause a) right) left + ExprRelation { expr } → + f expr a + _ → a +instance traversableRelation ∷ T.Traversable Relation where + traverse f = case _ of + JoinRelation { left, right, clause, joinType } → + map JoinRelation + $ { joinType, left: _, right: _, clause: _} + <$> T.traverse f left + <*> T.traverse f right + <*> f clause + ExprRelation { expr, aliasName} → + (ExprRelation ∘ { expr: _, aliasName}) + <$> f expr + TableRelation t → pure $ TableRelation t + VariRelation v → pure $ VariRelation v + IdentRelation i → pure $ IdentRelation i + sequence = T.sequenceDefault printRelation ∷ Algebra Relation String printRelation = case _ of From 55f822979d9f42ff7c488487adb397b8feb37275 Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Thu, 9 Mar 2017 23:34:48 +0300 Subject: [PATCH 14/19] using EJsonF --- src/SqlSquare/AST.purs | 112 ++++++++++++++++++++++++++++++++++++----- test/src/Argonaut.purs | 9 ++-- test/src/Search.purs | 29 +++++------ 3 files changed, 118 insertions(+), 32 deletions(-) diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index a70ea2e..2850980 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -24,18 +24,14 @@ module SqlSquare.AST import Prelude -import Data.Bifunctor (bimap) -import Data.Eq (class Eq1) +import Data.Eq (class Eq1, eq1) import Data.Foldable as F import Data.Traversable as T import Data.Functor.Mu (Mu) import Data.List as L import Data.Maybe (Maybe(..)) import Data.Monoid (mempty) -import Data.Ord (class Ord1) -import Data.String.Regex as RX -import Data.String.Regex.Flags as RXF -import Data.String.Regex.Unsafe as URX +import Data.Ord (class Ord1, compare1) import Data.Json.Extended.Signature (EJsonF, renderEJsonF) @@ -50,9 +46,7 @@ import SqlSquare.OrderBy (OrderBy(..), printOrderBy) import SqlSquare.Projection (Projection(..), printProjection) import SqlSquare.Relation (Relation(..), printRelation, FUPath, JoinRelR, ExprRelR, TableRelR, VariRelR, IdentRelR) -import Matryoshka (class Recursive, Algebra, cata, transParaT, project) - -import Debug.Trace as DT +import Matryoshka (Algebra, cata) type BinopR a = { lhs ∷ a @@ -114,10 +108,104 @@ data SqlF literal a derive instance eqSqlF ∷ (Eq a, Eq (l a)) ⇒ Eq (SqlF l a) derive instance ordSqlF ∷ (Ord a, Ord (l a)) ⇒ Ord (SqlF l a) ---instance eq1SqlF ∷ Eq1 l ⇒ Eq1 (SqlF l) where +instance eq1SqlF ∷ Eq1 l ⇒ Eq1 (SqlF l) where + eq1 (Literal l) (Literal ll) = eq1 l ll + eq1 (Splice a) (Splice aa) = eq a aa + eq1 (Binop r) (Binop rr) = + r.lhs == rr.lhs + && r.rhs == rr.rhs + && r.op == rr.op + eq1 (Unop r) (Unop rr) = + r.expr == rr.expr + && r.op == rr.op + eq1 (Ident s) (Ident ss) = + s == ss + eq1 (InvokeFunction r) (InvokeFunction rr) = + r.name == rr.name + && r.args == rr.args + eq1 (Match r) (Match rr) = + r.else_ == rr.else_ + && r.cases == rr.cases + && r.expr == rr.expr + eq1 (Switch r) (Switch rr) = + r.cases == rr.cases + && r.else_ == rr.else_ + eq1 (Let r) (Let rr) = + r.in_ == r.in_ + && r.bindTo == rr.bindTo + && r.ident == rr.ident + eq1 (Vari v) (Vari vv) = + v == vv + eq1 (Parens a) (Parens aa) = + a == aa + eq1 (Select r) (Select rr) = + r.isDistinct == rr.isDistinct + && r.projections == rr.projections + && r.relations == rr.relations + && r.filter == rr.filter + && r.groupBy == rr.groupBy + && r.orderBy == rr.orderBy + eq1 _ _ = false ---instance ord1SqlF ∷ Ord (l a) ⇒ Ord1 (SqlF l) where --- compare1 = compare +instance ord1SqlF ∷ Ord1 l ⇒ Ord1 (SqlF l) where + compare1 (Literal l) (Literal ll) = compare1 l ll + compare1 (Literal _) _ = LT + compare1 _ (Literal _) = GT + compare1 (SetLiteral s) (SetLiteral ss) = compare s ss + compare1 (SetLiteral _) _ = LT + compare1 _ (SetLiteral _) = GT + compare1 (Splice a) (Splice aa) = compare a aa + compare1 (Splice _) _ = LT + compare1 _ (Splice _) = GT + compare1 (Binop r) (Binop rr) = + compare r.lhs rr.lhs + <> compare r.rhs rr.rhs + <> compare r.op rr.op + compare1 (Binop _) _ = LT + compare1 _ (Binop _) = GT + compare1 (Unop r) (Unop rr) = + compare r.op rr.op + <> compare r.expr rr.expr + compare1 (Unop _) _ = LT + compare1 _ (Unop _) = GT + compare1 (Ident s) (Ident ss) = compare s ss + compare1 (Ident s) _ = LT + compare1 _ (Ident s) = GT + compare1 (InvokeFunction r) (InvokeFunction rr) = + compare r.name rr.name + <> compare r.args rr.args + compare1 (InvokeFunction _) _ = LT + compare1 _ (InvokeFunction _) = GT + compare1 (Match r) (Match rr) = + compare r.else_ rr.else_ + <> compare r.expr rr.expr + <> compare r.cases rr.cases + compare1 (Match _) _ = LT + compare1 _ (Match _) = GT + compare1 (Switch r) (Switch rr) = + compare r.else_ rr.else_ + <> compare r.cases rr.cases + compare1 (Switch _) _ = LT + compare1 _ (Switch _) = GT + compare1 (Let r) (Let rr) = + compare r.in_ rr.in_ + <> compare r.bindTo rr.bindTo + <> compare r.ident rr.ident + compare1 (Let _) _ = LT + compare1 _ (Let _) = GT + compare1 (Vari v) (Vari vv) = compare v vv + compare1 (Vari _) _ = LT + compare1 _ (Vari _) = GT + compare1 (Parens a) (Parens aa) = compare a aa + compare1 (Parens a) _ = LT + compare1 _ (Parens _) = GT + compare1 (Select r) (Select rr) = + compare r.isDistinct rr.isDistinct + <> compare r.projections rr.projections + <> compare r.filter rr.filter + <> compare r.relations rr.relations + <> compare r.orderBy rr.orderBy + <> compare r.groupBy rr.groupBy instance functorAST ∷ Functor l ⇒ Functor (SqlF l) where map f = case _ of diff --git a/test/src/Argonaut.purs b/test/src/Argonaut.purs index eae22a9..bd6c62f 100644 --- a/test/src/Argonaut.purs +++ b/test/src/Argonaut.purs @@ -1,4 +1,4 @@ --- | An example of using `purescript-sqlsquare` library. +-- | An example of using `purescript-sqlsquare` library -- | Having an array of `Json`s construct a list of Sql² projections module Test.Argonaut where @@ -13,6 +13,7 @@ import Data.List as L import Data.Maybe (Maybe(..)) import Data.Set as Set import Data.Tuple (Tuple, fst) +import Data.Json.Extended.Signature (EJsonF(..)) import SqlSquare as S import SqlSquare.Utils ((×), (∘), (⋙)) @@ -26,10 +27,10 @@ import Partial.Unsafe (unsafePartial) data UnfoldableJC = JC JCursor | S String | I Int -jcCoalgebra ∷ Coalgebra S.SqlF UnfoldableJC +jcCoalgebra ∷ Coalgebra (S.SqlF EJsonF) UnfoldableJC jcCoalgebra = case _ of S s → S.Ident s - I i → S.IntLiteral i + I i → S.Literal (Integer i) JC cursor → case cursor of JCursorTop → S.Splice Nothing JIndex i c → S.Binop { op: S.IndexDeref, lhs: JC c, rhs: I i } @@ -42,7 +43,7 @@ fields ∷ JS.JArray → L.List S.Sql fields arr = map jcursorToSql $ L.fromFoldable $ F.foldMap (Set.fromFoldable ∘ map fst) $ map JS.toPrims arr -allParentsF ∷ ElgotAlgebra (Tuple S.Sql) S.SqlF (L.List S.Sql) +allParentsF ∷ ElgotAlgebra (Tuple S.Sql) (S.SqlF EJsonF) (L.List S.Sql) allParentsF (parent × sqlF) = case sqlF of S.Splice (Just ps) → ps S.Unop { op: S.FlattenArrayValues, expr } → parent : expr diff --git a/test/src/Search.purs b/test/src/Search.purs index b8b507b..522c309 100644 --- a/test/src/Search.purs +++ b/test/src/Search.purs @@ -22,6 +22,7 @@ import Data.String as Str import Data.String.Regex as RX import Data.String.Regex.Flags as RXF import Data.String.Regex.Unsafe as URX +import Data.Json.Extended.Signature as EJ import Global (readFloat, isNaN) @@ -100,10 +101,10 @@ labelString = case _ of SS.Meta l → l SS.Common l → l -identOrString ∷ ∀ a. S.SqlF a → Maybe String +identOrString ∷ ∀ a. (S.SqlF EJ.EJsonF) a → Maybe String identOrString = case _ of S.Ident s → Just s - S.StringLiteral s → Just s + S.Literal (EJ.String s) → Just s _ → Nothing valueToString ∷ SS.Value → String @@ -141,12 +142,12 @@ isTop = case _ of NotTopField → false _ → true -topFieldF ∷ Algebra S.SqlF TopFieldMark +topFieldF ∷ Algebra (S.SqlF EJ.EJsonF) TopFieldMark topFieldF = case _ of S.Splice Nothing → Init - S.StringLiteral _ → TopField S.Ident _ → TopField - S.IntLiteral _ → TopField + S.Literal (EJ.Integer _) → TopField + S.Literal (EJ.String _) → TopField S.Binop { op: S.FieldDeref, lhs: Init, rhs: TopField } → TopField S.Binop { op: S.IndexDeref, lhs: Init, rhs: TopField } → TopField _ → NotTopField @@ -158,7 +159,7 @@ isTopField = isTop ∘ cata topFieldF -- Flattening all array derefs ( `foo[1]` → `foo[*]` ) -------------------------------------------------------------------------------- -flattenIndexF ∷ ∀ t. Transform t S.SqlF S.SqlF +flattenIndexF ∷ ∀ t. Transform t (S.SqlF EJ.EJsonF) (S.SqlF EJ.EJsonF) flattenIndexF = case _ of S.Binop { op: S.IndexDeref, lhs } → S.Unop { op: S.FlattenArrayValues, expr: lhs } s → s @@ -170,11 +171,11 @@ flattenIndex = transAna flattenIndexF -- Searching for flatten values ({*}, [*]) -------------------------------------------------------------------------------- -needDistinctF ∷ Algebra S.SqlF Boolean +needDistinctF ∷ Algebra (S.SqlF EJ.EJsonF) Boolean needDistinctF = case _ of S.SetLiteral ns → F.or ns - S.ArrayLiteral ns → F.or ns - S.MapLiteral tpls → F.any (\(a × b) → a || b) tpls + S.Literal (EJ.Array ns) → F.or ns + S.Literal (EJ.Map tpls) → F.any (\(a × b) → a || b) tpls S.Splice Nothing → false S.Splice (Just a) → a S.Binop { lhs, rhs } → lhs || rhs @@ -189,11 +190,7 @@ needDistinctF = case _ of F.any (\(S.Case { cond, expr }) → cond || expr) cases || fromMaybe false else_ S.Let { bindTo, in_ } → bindTo || in_ - S.IntLiteral _ → false - S.StringLiteral _ → false - S.FloatLiteral _ → false - S.NullLiteral → false - S.BoolLiteral _ → false + S.Literal _ → false S.Vari _ → false S.Parens a → a S.Select { projections, filter } → @@ -221,11 +218,11 @@ termToSql fs (SS.Term { include, predicate, labels}) <$> (if L.null labels then fs else pure $ labelsToField labels) -labelToFieldF ∷ Coalgebra S.SqlF (L.List String) +labelToFieldF ∷ Coalgebra (S.SqlF EJ.EJsonF) (L.List String) labelToFieldF = case _ of L.Nil → S.Splice Nothing hd : L.Nil → case toInt hd of - Just i → S.IntLiteral i + Just i → S.Literal (EJ.Integer i) Nothing → S.Ident hd hd : tl → case toInt hd of Just i → S.Binop { op: S.IndexDeref, lhs: tl, rhs: pure hd } From d563682d79357ac8a8cc76fcf78d414bf3cf012b Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Thu, 9 Mar 2017 23:38:48 +0300 Subject: [PATCH 15/19] updated ejson dep --- bower.json | 57 +++++++++++++++++++++++++++--------------------------- 1 file changed, 29 insertions(+), 28 deletions(-) diff --git a/bower.json b/bower.json index c6195c2..680915c 100644 --- a/bower.json +++ b/bower.json @@ -1,30 +1,31 @@ { - "name": "purescript-sqlsquare", - "homepage": "https://github.com/slamdata/purescript-sqlsquare", - "license": "Apache-2.0", - "repository": { - "type": "git", - "url": "git://github.com/slamdata/purescript-sqlsquare.git" - }, - "ignore": [ - "**/.*", - "node_modules", - "bower_components", - "output", - "bower.json", - "package.json" - ], - "dependencies": { - "purescript-prelude": "^2.4.0", - "purescript-matryoshka": "^0.2.0", - "purescript-pathy": "^3.0.2", - "purescript-profunctor": "^2.0.0", - "purescript-profunctor-lenses": "^2.6.0" - }, - "devDependencies": { - "purescript-argonaut": "^2.0.0", - "purescript-search": "^2.0.0", - "purescript-debug": "^2.0.0", - "purescript-test-unit": "^10.1.0" - } + "name": "purescript-sqlsquare", + "homepage": "https://github.com/slamdata/purescript-sqlsquare", + "license": "Apache-2.0", + "repository": { + "type": "git", + "url": "git://github.com/slamdata/purescript-sqlsquare.git" + }, + "ignore": [ + "**/.*", + "node_modules", + "bower_components", + "output", + "bower.json", + "package.json" + ], + "dependencies": { + "purescript-prelude": "^2.4.0", + "purescript-matryoshka": "^0.2.0", + "purescript-pathy": "^3.0.2", + "purescript-profunctor": "^2.0.0", + "purescript-profunctor-lenses": "^2.6.0", + "purescript-ejson": "^5.0.0" + }, + "devDependencies": { + "purescript-argonaut": "^2.0.0", + "purescript-search": "^2.0.0", + "purescript-debug": "^2.0.0", + "purescript-test-unit": "^10.1.0" + } } From dfb067b8a04199367365b48f3c51ff40438bdcbd Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Thu, 9 Mar 2017 23:43:52 +0300 Subject: [PATCH 16/19] capitalized --- src/SqlSquare/AST.purs | 48 +++++++++++++++++------------------ src/SqlSquare/Case.purs | 2 +- src/SqlSquare/GroupBy.purs | 2 +- src/SqlSquare/JoinType.purs | 8 +++--- src/SqlSquare/OrderType.purs | 4 +-- src/SqlSquare/Projection.purs | 2 +- src/SqlSquare/Relation.purs | 8 +++--- 7 files changed, 37 insertions(+), 37 deletions(-) diff --git a/src/SqlSquare/AST.purs b/src/SqlSquare/AST.purs index 2850980..5db3549 100644 --- a/src/SqlSquare/AST.purs +++ b/src/SqlSquare/AST.purs @@ -385,8 +385,8 @@ printF printLiteralF = case _ of Binop {lhs, rhs, op} → case op of IfUndefined → lhs <> " ?? " <> rhs Range → lhs <> " .. " <> rhs - Or → lhs <> " or " <> rhs - And → lhs <> " and " <> rhs + Or → lhs <> " OR " <> rhs + And → lhs <> " AND " <> rhs Eq → lhs <> " = " <> rhs Neq → lhs <> " <> " <> rhs Ge → lhs <> " >= " <> rhs @@ -400,24 +400,24 @@ printF printLiteralF = case _ of Div → lhs <> " / " <> rhs Mod → lhs <> " % " <> rhs Pow → lhs <> " ^ " <> rhs - In → lhs <> " in " <> rhs + In → lhs <> " IN " <> rhs FieldDeref → lhs <> "." <> rhs IndexDeref → lhs <> "[" <> rhs <> "]" - Limit → lhs <> " limit " <> rhs - Offset → lhs <> " offset " <> rhs - Sample → lhs <> " sample " <> rhs - Union → lhs <> " union " <> rhs - UnionAll → lhs <> " union all " <> rhs - Intersect → lhs <> " intersect " <> rhs - IntersectAll → lhs <> " intersect all " <> rhs - Except → lhs <> " except " <> rhs + Limit → lhs <> " LIMIT " <> rhs + Offset → lhs <> " OFFSET " <> rhs + Sample → lhs <> " SAMPLE " <> rhs + Union → lhs <> " UNION " <> rhs + UnionAll → lhs <> " UNION ALL " <> rhs + Intersect → lhs <> " INTERSECT " <> rhs + IntersectAll → lhs <> " INTERSECT ALL " <> rhs + Except → lhs <> " EXCEPT " <> rhs UnshiftMap → "{" <> lhs <> ": " <> rhs <> "...}" Unop {expr, op} → case op of - Not → "not " <> expr - Exists → "exists " <> expr + Not → "NOT " <> expr + Exists → "EXISTS " <> expr Positive → "+" <> expr Negative → "-" <> expr - Distinct → "distinct " <> expr + Distinct → "DISTINCT " <> expr FlattenMapKeys → expr <> "{*: }" FlattenMapValues → expr <> "{*}" ShiftMapKeys → expr <> "{_: }" @@ -432,27 +432,27 @@ printF printLiteralF = case _ of InvokeFunction {name, args} → name <> "(" <> F.intercalate "," args <> ")" Match { expr, cases, else_ } → - "case " + "CASE " <> expr <> F.intercalate " " (map printCase cases) - <> F.foldMap (" else " <> _) else_ + <> F.foldMap (" ELSE " <> _) else_ Switch { cases, else_ } → - "case " + "CASE " <> F.intercalate " " (map printCase cases) - <> F.foldMap (" else " <> _) else_ + <> F.foldMap (" ELSE " <> _) else_ Let { ident, bindTo, in_ } → ident <> " := " <> bindTo <> "; " <> in_ Vari s → ":" <> s Select { isDistinct, projections, relations, filter, groupBy, orderBy } → - "select " - <> (if isDistinct then "distinct " else "") + "SELECT " + <> (if isDistinct then "DISTINCT " else "") <> (F.intercalate ", " $ map printProjection projections) <> (relations # F.foldMap \rs → - " from " <> printRelation rs) - <> (filter # F.foldMap \f → " where " <> f) - <> (groupBy # F.foldMap \gb → " group by " <> printGroupBy gb) - <> (orderBy # F.foldMap \ob → " order by " <> printOrderBy ob) + " FROM " <> printRelation rs) + <> (filter # F.foldMap \f → " WHERE " <> f) + <> (groupBy # F.foldMap \gb → " GROUP BY " <> printGroupBy gb) + <> (orderBy # F.foldMap \ob → " ORDER BY " <> printOrderBy ob) Parens t → "(" <> t <> ")" diff --git a/src/SqlSquare/Case.purs b/src/SqlSquare/Case.purs index 5d89286..5dc8681 100644 --- a/src/SqlSquare/Case.purs +++ b/src/SqlSquare/Case.purs @@ -24,4 +24,4 @@ instance traversableCase ∷ T.Traversable Case where sequence = T.sequenceDefault printCase ∷ Algebra Case String -printCase (Case { cond, expr }) = " when " <> cond <> " then " <> expr +printCase (Case { cond, expr }) = " WHEN " <> cond <> " THEN " <> expr diff --git a/src/SqlSquare/GroupBy.purs b/src/SqlSquare/GroupBy.purs index 56d56eb..bf6fae8 100644 --- a/src/SqlSquare/GroupBy.purs +++ b/src/SqlSquare/GroupBy.purs @@ -28,4 +28,4 @@ instance traversableGroupBy ∷ T.Traversable GroupBy where printGroupBy ∷ Algebra GroupBy String printGroupBy (GroupBy { keys, having }) = - F.intercalate ", " keys <> F.foldMap (" having " <> _) having + F.intercalate ", " keys <> F.foldMap (" HAVING " <> _) having diff --git a/src/SqlSquare/JoinType.purs b/src/SqlSquare/JoinType.purs index 29075db..6b8b8a6 100644 --- a/src/SqlSquare/JoinType.purs +++ b/src/SqlSquare/JoinType.purs @@ -10,10 +10,10 @@ data JoinType printJoinType ∷ JoinType → String printJoinType = case _ of - LeftJoin → "left join" - RightJoin → "right join" - FullJoin → "full join" - InnerJoin → "inner join" + LeftJoin → "LEFT JOIN" + RightJoin → "RIGHT JOIN" + FullJoin → "FULL JOIN" + InnerJoin → "INNER JOIN" derive instance eqJoinType ∷ Eq JoinType derive instance ordJoinType ∷ Ord JoinType diff --git a/src/SqlSquare/OrderType.purs b/src/SqlSquare/OrderType.purs index 0356e0c..a660af7 100644 --- a/src/SqlSquare/OrderType.purs +++ b/src/SqlSquare/OrderType.purs @@ -6,8 +6,8 @@ data OrderType = ASC | DESC printOrderType ∷ OrderType → String printOrderType = case _ of - ASC → "asc" - DESC → "desc" + ASC → "ASC" + DESC → "DESC" derive instance eqOrderType ∷ Eq OrderType derive instance ordOrderType ∷ Ord OrderType diff --git a/src/SqlSquare/Projection.purs b/src/SqlSquare/Projection.purs index 61aba58..1b54f44 100644 --- a/src/SqlSquare/Projection.purs +++ b/src/SqlSquare/Projection.purs @@ -27,4 +27,4 @@ instance traversableProjection ∷ T.Traversable Projection where sequence = T.sequenceDefault printProjection ∷ Algebra Projection String -printProjection (Projection { expr, alias }) = expr <> F.foldMap (" as " <> _) alias +printProjection (Projection { expr, alias }) = expr <> F.foldMap (" AS " <> _) alias diff --git a/src/SqlSquare/Relation.purs b/src/SqlSquare/Relation.purs index d9b708a..0a5a34a 100644 --- a/src/SqlSquare/Relation.purs +++ b/src/SqlSquare/Relation.purs @@ -89,16 +89,16 @@ instance traversableRelation ∷ T.Traversable Relation where printRelation ∷ Algebra Relation String printRelation = case _ of ExprRelation {expr, aliasName} → - "(" <> expr <> ") as " <> aliasName + "(" <> expr <> ") AS " <> aliasName VariRelation { vari, alias} → - vari <> F.foldMap (" as " <> _) alias + vari <> F.foldMap (" AS " <> _) alias TableRelation { tablePath, alias } → "`" <> either unsafePrintPath unsafePrintPath tablePath <> "`" - <> F.foldMap (" as " <> _) alias + <> F.foldMap (" AS " <> _) alias IdentRelation { ident, alias } → - ident <> F.foldMap (\x → " as `" <> x <> "`") alias + ident <> F.foldMap (\x → " AS `" <> x <> "`") alias JoinRelation { left, right, joinType, clause } → printRelation left <> " " From a52159de1077a1bd65842c52cd7d4f6f87e3bd54 Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Fri, 10 Mar 2017 00:00:09 +0300 Subject: [PATCH 17/19] capitalize tests, polymorphic l --- src/SqlSquare/Constructors.purs | 24 ++++++++++++------------ src/SqlSquare/OrderBy.purs | 2 +- test/src/Constructors.purs | 3 +-- test/src/Search.purs | 12 ++++++------ 4 files changed, 20 insertions(+), 21 deletions(-) diff --git a/src/SqlSquare/Constructors.purs b/src/SqlSquare/Constructors.purs index 11063b4..9c222bf 100644 --- a/src/SqlSquare/Constructors.purs +++ b/src/SqlSquare/Constructors.purs @@ -14,7 +14,7 @@ import Matryoshka (class Corecursive, embed) import SqlSquare.AST (SqlF(..), Relation, GroupBy(..), OrderBy, BinaryOperator, UnaryOperator, (∘), SelectR, Case(..), Projection(..)) -vari ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ String → t +vari ∷ ∀ t f. Corecursive t (SqlF f) ⇒ String → t vari s = embed $ Vari s bool ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ Boolean → t @@ -32,13 +32,13 @@ num i = embed $ Literal $ Decimal $ HN.fromNumber i string ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ String → t string s = embed $ Literal $ String s -unop ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ UnaryOperator → t → t +unop ∷ ∀ t f. Corecursive t (SqlF f) ⇒ UnaryOperator → t → t unop op expr = embed $ Unop { op, expr } -binop ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ BinaryOperator → t → t → t +binop ∷ ∀ t f. Corecursive t (SqlF f) ⇒ BinaryOperator → t → t → t binop op lhs rhs = embed $ Binop { op, lhs, rhs } -set ∷ ∀ t f. (Corecursive t (SqlF EJsonF), F.Foldable f) ⇒ f t → t +set ∷ ∀ t f g. (Corecursive t (SqlF g), F.Foldable f) ⇒ f t → t set l = embed $ SetLiteral $ L.fromFoldable l array ∷ ∀ t f. (Corecursive t (SqlF EJsonF), F.Foldable f) ⇒ f t → t @@ -47,22 +47,22 @@ array l = embed $ Literal $ Array $ Arr.fromFoldable l map_ ∷ ∀ t. (Corecursive t (SqlF EJsonF), Ord t) ⇒ Map.Map t t → t map_ m = embed $ Literal $ Map $ Arr.fromFoldable $ Map.toList m -splice ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ Maybe t → t +splice ∷ ∀ t f. Corecursive t (SqlF f) ⇒ Maybe t → t splice m = embed $ Splice m -ident ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ String → t +ident ∷ ∀ t f. Corecursive t (SqlF f) ⇒ String → t ident i = embed $ Ident i -match ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ t → L.List (Case t) → Maybe t → t +match ∷ ∀ t f. Corecursive t (SqlF f) ⇒ t → L.List (Case t) → Maybe t → t match expr cases else_ = embed $ Match { expr, cases, else_ } -switch ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ L.List (Case t) → Maybe t → t +switch ∷ ∀ t f. Corecursive t (SqlF f) ⇒ L.List (Case t) → Maybe t → t switch cases else_ = embed $ Switch { cases, else_ } -let_ ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ String → t → t → t +let_ ∷ ∀ t f. Corecursive t (SqlF f) ⇒ String → t → t → t let_ id bindTo in_ = embed $ Let { ident: id, bindTo, in_ } -invokeFunction ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ String → L.List t → t +invokeFunction ∷ ∀ t f. Corecursive t (SqlF f) ⇒ String → L.List t → t invokeFunction name args = embed $ InvokeFunction {name, args} -- when (bool true) # then (num 1.0) :P @@ -106,7 +106,7 @@ groupBy f = GroupBy { keys: L.fromFoldable f, having: Nothing } having ∷ ∀ t. t → GroupBy t → GroupBy t having t (GroupBy r) = GroupBy r{ having = Just t } -buildSelect ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ (SelectR t → SelectR t) → t +buildSelect ∷ ∀ t f. Corecursive t (SqlF f) ⇒ (SelectR t → SelectR t) → t buildSelect f = embed $ Select $ f { isDistinct: false , projections: L.Nil @@ -116,5 +116,5 @@ buildSelect f = , orderBy: Nothing } -pars ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ t → t +pars ∷ ∀ t f. Corecursive t (SqlF f) ⇒ t → t pars = embed ∘ Parens diff --git a/src/SqlSquare/OrderBy.purs b/src/SqlSquare/OrderBy.purs index 77c6c2e..ca2328a 100644 --- a/src/SqlSquare/OrderBy.purs +++ b/src/SqlSquare/OrderBy.purs @@ -29,4 +29,4 @@ instance traversableOrderBy ∷ T.Traversable OrderBy where printOrderBy ∷ Algebra OrderBy String printOrderBy (OrderBy lst) = - F.intercalate ", " $ lst <#> \(ot × a) → OT.printOrderType ot <> " " <> a + F.intercalate ", " $ lst <#> \(ot × a) → a <> " " <> OT.printOrderType ot diff --git a/test/src/Constructors.purs b/test/src/Constructors.purs index d11c38c..1848d5f 100644 --- a/test/src/Constructors.purs +++ b/test/src/Constructors.purs @@ -53,8 +53,7 @@ buildSelectQuery = expectedSqlString ∷ String expectedSqlString = - "select distinct `foo` as field, `bar`.`baz`.* from `/mongo/testDb/patients` where `quux` = 12.0 group by `zzz` having `ooo` > 2 order by asc `zzz`" - + "SELECT DISTINCT `foo` AS field, `bar`.`baz`.* FROM `/mongo/testDb/patients` WHERE `quux` = 12.0 GROUP BY `zzz` HAVING `ooo` > 2 ORDER BY `zzz` ASC" testSuite ∷ ∀ e. TestSuite e testSuite = diff --git a/test/src/Search.purs b/test/src/Search.purs index 522c309..e3e3062 100644 --- a/test/src/Search.purs +++ b/test/src/Search.purs @@ -394,12 +394,12 @@ searchQueries = expectedOutput ∷ L.List String expectedOutput = - """select distinct *.`bar`, *.`foo` from `/mongo/testDb/patients` where (((search(*.`bar`,"^.*ba.*$",true)) or ((search(*.`foo`,"^.*ba.*$",true))) or ((search(*.`bar`.`valid`,"^.*ba.*$",true))) or ((search(*.`bar`.`value`,"^.*ba.*$",true))) or ((search(*.`foo`[*],"^.*ba.*$",true))) or ((search(*.`foo`[*],"^.*ba.*$",true)))))""" - : """select distinct *.`bar`, *.`foo` from `/mongo/testDb/patients` where (((search(`foo`[*],"^.*2.*$",true) or (`foo`[*] = 2.0) or (`foo`[*] = 2))))""" - : """select *.`bar`, *.`foo` from `/mongo/testDb/patients` where (((LOWER(`bar`) > LOWER("1") or (`bar` > 1.0) or (`bar` > 1))))""" - : """select distinct *.`bar`, *.`foo` from `/mongo/testDb/patients` where ((search(*.`bar`,"^.*false.*$",true) or (*.`bar` = false) or (search(*.`foo`,"^.*false.*$",true) or (*.`foo` = false)) or (search(*.`bar`.`valid`,"^.*false.*$",true) or (*.`bar`.`valid` = false)) or (search(*.`bar`.`value`,"^.*false.*$",true) or (*.`bar`.`value` = false)) or (search(*.`foo`[*],"^.*false.*$",true) or (*.`foo`[*] = false)) or (search(*.`foo`[*],"^.*false.*$",true) or (*.`foo`[*] = false))))""" - : """select *.`bar`, *.`foo` from `/mongo/testDb/patients` where (((LOWER(`bar`.`valid`) = LOWER("false") or (`bar`.`valid` = false))))""" - : """select *.`bar`, *.`foo` from `/mongo/testDb/patients` where ((((search(`non-existing`,"^.*foo.*$",true)))))""" + """SELECT DISTINCT *.`bar`, *.`foo` FROM `/mongo/testDb/patients` WHERE (((search(*.`bar`,"^.*ba.*$",true)) OR ((search(*.`foo`,"^.*ba.*$",true))) OR ((search(*.`bar`.`valid`,"^.*ba.*$",true))) OR ((search(*.`bar`.`value`,"^.*ba.*$",true))) OR ((search(*.`foo`[*],"^.*ba.*$",true))) OR ((search(*.`foo`[*],"^.*ba.*$",true)))))""" + : """SELECT DISTINCT *.`bar`, *.`foo` FROM `/mongo/testDb/patients` WHERE (((search(`foo`[*],"^.*2.*$",true) OR (`foo`[*] = 2.0) OR (`foo`[*] = 2))))""" + : """SELECT *.`bar`, *.`foo` FROM `/mongo/testDb/patients` WHERE (((LOWER(`bar`) > LOWER("1") OR (`bar` > 1.0) OR (`bar` > 1))))""" + : """SELECT DISTINCT *.`bar`, *.`foo` FROM `/mongo/testDb/patients` WHERE ((search(*.`bar`,"^.*false.*$",true) OR (*.`bar` = false) OR (search(*.`foo`,"^.*false.*$",true) OR (*.`foo` = false)) OR (search(*.`bar`.`valid`,"^.*false.*$",true) OR (*.`bar`.`valid` = false)) OR (search(*.`bar`.`value`,"^.*false.*$",true) OR (*.`bar`.`value` = false)) OR (search(*.`foo`[*],"^.*false.*$",true) OR (*.`foo`[*] = false)) OR (search(*.`foo`[*],"^.*false.*$",true) OR (*.`foo`[*] = false))))""" + : """SELECT *.`bar`, *.`foo` FROM `/mongo/testDb/patients` WHERE (((LOWER(`bar`.`valid`) = LOWER("false") OR (`bar`.`valid` = false))))""" + : """SELECT *.`bar`, *.`foo` FROM `/mongo/testDb/patients` WHERE ((((search(`non-existing`,"^.*foo.*$",true)))))""" : L.Nil tablePath ∷ S.FUPath From 3383c11a01a52c7842527ca33c1d3d5c990389f6 Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Fri, 10 Mar 2017 20:27:46 +0300 Subject: [PATCH 18/19] updated to the latest purescript-ejson, added date|time constructors|lenses --- bower.json | 2 +- src/SqlSquare/Constructors.purs | 12 +++++++++++- src/SqlSquare/Lenses.purs | 25 +++++++++++++++++++++++++ 3 files changed, 37 insertions(+), 2 deletions(-) diff --git a/bower.json b/bower.json index 680915c..252070e 100644 --- a/bower.json +++ b/bower.json @@ -20,7 +20,7 @@ "purescript-pathy": "^3.0.2", "purescript-profunctor": "^2.0.0", "purescript-profunctor-lenses": "^2.6.0", - "purescript-ejson": "^5.0.0" + "purescript-ejson": "^6.0.0" }, "devDependencies": { "purescript-argonaut": "^2.0.0", diff --git a/src/SqlSquare/Constructors.purs b/src/SqlSquare/Constructors.purs index 9c222bf..07f33ff 100644 --- a/src/SqlSquare/Constructors.purs +++ b/src/SqlSquare/Constructors.purs @@ -3,6 +3,7 @@ module SqlSquare.Constructors where import Prelude import Data.Array as Arr +import Data.DateTime as DT import Data.Json.Extended.Signature (EJsonF(..)) import Data.Foldable as F import Data.HugeNum as HN @@ -32,6 +33,15 @@ num i = embed $ Literal $ Decimal $ HN.fromNumber i string ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ String → t string s = embed $ Literal $ String s +date ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ DT.Date → t +date d = embed $ Literal $ Date d + +time ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ DT.Time → t +time t = embed $ Literal $ Time t + +timestamp ∷ ∀ t. Corecursive t (SqlF EJsonF) ⇒ DT.DateTime → t +timestamp dt = embed $ Literal $ Timestamp dt + unop ∷ ∀ t f. Corecursive t (SqlF f) ⇒ UnaryOperator → t → t unop op expr = embed $ Unop { op, expr } @@ -65,7 +75,7 @@ let_ id bindTo in_ = embed $ Let { ident: id, bindTo, in_ } invokeFunction ∷ ∀ t f. Corecursive t (SqlF f) ⇒ String → L.List t → t invokeFunction name args = embed $ InvokeFunction {name, args} --- when (bool true) # then (num 1.0) :P +-- when (bool true) # then_ (num 1.0) :P when ∷ ∀ t. t → (t → Case t) when cond = Case ∘ { cond, expr: _ } diff --git a/src/SqlSquare/Lenses.purs b/src/SqlSquare/Lenses.purs index b86a184..98ef501 100644 --- a/src/SqlSquare/Lenses.purs +++ b/src/SqlSquare/Lenses.purs @@ -2,6 +2,7 @@ module SqlSquare.Lenses where import Prelude +import Data.DateTime as DT import Data.HugeNum as HN import Data.Json.Extended as EJ import Data.Lens (Prism', prism', Lens', lens, Iso') @@ -291,3 +292,27 @@ _Parens ∷ ∀ t. (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJs _Parens = prism' (embed ∘ S.Parens) $ project ⋙ case _ of S.Parens t → M.Just t _ → M.Nothing + +_TimeLiteral + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t DT.Time +_TimeLiteral = prism' (embed ∘ S.Literal ∘ EJ.Time) $ project ⋙ case _ of + S.Literal (EJ.Time t) → M.Just t + _ → M.Nothing + +_DateLiteral + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t DT.Date +_DateLiteral = prism' (embed ∘ S.Literal ∘ EJ.Date) $ project ⋙ case _ of + S.Literal (EJ.Date d) → M.Just d + _ → M.Nothing + +_TimestampLiteral + ∷ ∀ t + . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ⇒ Prism' t DT.DateTime +_TimestampLiteral = prism' (embed ∘ S.Literal ∘ EJ.Timestamp) $ project ⋙ case _ of + S.Literal (EJ.Timestamp dt) → M.Just dt + _ → M.Nothing From 308f18b2276b5bd957febf3212e60918f0ffca66 Mon Sep 17 00:00:00 2001 From: Maxim Zimaliev Date: Fri, 10 Mar 2017 21:31:05 +0300 Subject: [PATCH 19/19] lenses --- src/SqlSquare/Lenses.purs | 55 +++++++++++++++++++++------------------ 1 file changed, 29 insertions(+), 26 deletions(-) diff --git a/src/SqlSquare/Lenses.purs b/src/SqlSquare/Lenses.purs index 98ef501..e8786b0 100644 --- a/src/SqlSquare/Lenses.purs +++ b/src/SqlSquare/Lenses.purs @@ -137,17 +137,17 @@ _tablePath = lens _.tablePath _{ tablePath = _ } _SetLiteral - ∷ ∀ t - . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) ⇒ Prism' t (L.List t) _SetLiteral = prism' (embed ∘ S.SetLiteral) $ project ⋙ case _ of S.SetLiteral lst → M.Just lst _ → M.Nothing _Literal - ∷ ∀ t - . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) - ⇒ Prism' t (EJ.EJsonF t) + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) + ⇒ Prism' t (f t) _Literal = prism' (embed ∘ S.Literal) $ project ⋙ case _ of S.Literal js → M.Just js _ → M.Nothing @@ -169,64 +169,64 @@ _MapLiteral = prism' (embed ∘ S.Literal ∘ EJ.Map) $ project ⋙ case _ of _ → M.Nothing _Splice - ∷ ∀ t - . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) ⇒ Prism' t (M.Maybe t) _Splice = prism' (embed ∘ S.Splice) $ project ⋙ case _ of S.Splice m → M.Just m _ → M.Nothing _Binop - ∷ ∀ t - . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) ⇒ Prism' t (S.BinopR t) _Binop = prism' (embed ∘ S.Binop) $ project ⋙ case _ of S.Binop b → M.Just b _ → M.Nothing _Unop - ∷ ∀ t - . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) ⇒ Prism' t (S.UnopR t) _Unop = prism' (embed ∘ S.Unop) $ project ⋙ case _ of S.Unop r → M.Just r _ → M.Nothing _Ident - ∷ ∀ t - . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) ⇒ Prism' t String _Ident = prism' (embed ∘ S.Ident) $ project ⋙ case _ of S.Ident s → M.Just s _ → M.Nothing _InvokeFunction - ∷ ∀ t - . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) ⇒ Prism' t (S.InvokeFunctionR t) _InvokeFunction = prism' (embed ∘ S.InvokeFunction) $ project ⋙ case _ of S.InvokeFunction r → M.Just r _ → M.Nothing _Match - ∷ ∀ t - . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) ⇒ Prism' t (S.MatchR t) _Match = prism' (embed ∘ S.Match) $ project ⋙ case _ of S.Match r → M.Just r _ → M.Nothing _Switch - ∷ ∀ t - . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) ⇒ Prism' t (S.SwitchR t) _Switch = prism' (embed ∘ S.Switch) $ project ⋙ case _ of S.Switch r → M.Just r _ → M.Nothing _Let - ∷ ∀ t - . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) ⇒ Prism' t (S.LetR t) _Let = prism' (embed ∘ S.Let) $ project ⋙ case _ of S.Let r → M.Just r @@ -273,22 +273,25 @@ _BoolLiteral = prism' (embed ∘ S.Literal ∘ EJ.Boolean) $ project ⋙ case _ _ → M.Nothing _Vari - ∷ ∀ t - . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) ⇒ Prism' t String _Vari = prism' (embed ∘ S.Vari) $ project ⋙ case _ of S.Vari r → M.Just r _ → M.Nothing _Select - ∷ ∀ t - . (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) ⇒ Prism' t (S.SelectR t) _Select = prism' (embed ∘ S.Select) $ project ⋙ case _ of S.Select r → M.Just r _ → M.Nothing -_Parens ∷ ∀ t. (Recursive t (S.SqlF EJ.EJsonF), Corecursive t (S.SqlF EJ.EJsonF)) ⇒ Prism' t t +_Parens + ∷ ∀ t f + . (Recursive t (S.SqlF f), Corecursive t (S.SqlF f)) + ⇒ Prism' t t _Parens = prism' (embed ∘ S.Parens) $ project ⋙ case _ of S.Parens t → M.Just t _ → M.Nothing