├── .travis.yml
├── Setup.hs
├── .gitignore
├── CONTRIBUTING.md
├── examples
├── Timeout.cql
├── Congruence.cql
├── Mapping.cql
├── Petri.cql
├── KB.cql
├── Employee.cql
├── Delta.cql
├── Sigma.cql
└── Import.cql
├── test
├── Spec.hs
├── Language
│ └── CQL
│ │ └── Parser
│ │ └── Generator.hs
├── Parser
│ └── ParserSpec.hs
└── CQLSpec.hs
├── http
├── Main.hs
├── src
│ └── Api
│ │ ├── Config
│ │ ├── Config.hs
│ │ └── Environment.hs
│ │ ├── Api.hs
│ │ ├── Lib.hs
│ │ └── App.hs
└── package.yaml
├── .editorconfig
├── src
└── Language
│ └── CQL
│ ├── Parser
│ ├── LexerRules.hs
│ ├── ReservedWords.hs
│ ├── Program.hs
│ ├── Schema.hs
│ ├── Typeside.hs
│ ├── Mapping.hs
│ ├── Transform.hs
│ ├── Parser.hs
│ └── Instance.hs
│ ├── Graph.hs
│ ├── Instance
│ ├── Presentation.hs
│ └── Algebra.hs
│ ├── Program.hs
│ ├── Query.hs
│ ├── Congruence.hs
│ ├── Options.hs
│ ├── Common.hs
│ ├── Internal.hs
│ ├── Morphism.hs
│ ├── Typeside.hs
│ ├── Collage.hs
│ ├── Prover.hs
│ ├── Schema.hs
│ └── Mapping.hs
├── cli
└── Main.hs
├── cql.nix
├── default.nix
├── package.yaml
├── stack.yaml
└── README.md
/.travis.yml:
--------------------------------------------------------------------------------
1 | language: nix
2 |
--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | .stack-work/
2 | cql.cabal
3 | http/cql-http.cabal
4 | *~
5 | .DS_Store
6 | *.yaml#
7 | *.cql#
8 |
9 |
--------------------------------------------------------------------------------
/CONTRIBUTING.md:
--------------------------------------------------------------------------------
1 | To get started, sign the Contributor License Agreement.
2 |
--------------------------------------------------------------------------------
/examples/Timeout.cql:
--------------------------------------------------------------------------------
1 |
2 | schema S = literal : empty {
3 | entities E
4 | foreign_keys f : E -> E
5 | }
6 |
7 | instance I = literal : S {
8 | generators e : E
9 | options timeout = "1"
10 | }
11 |
--------------------------------------------------------------------------------
/test/Spec.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-}
22 |
--------------------------------------------------------------------------------
/http/Main.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | module Main where
22 |
23 | import Api.App (app)
24 |
25 | main :: IO ()
26 | main = app
27 |
--------------------------------------------------------------------------------
/examples/Congruence.cql:
--------------------------------------------------------------------------------
1 | options
2 | prover = congruence
3 |
4 | typeside T = literal {
5 | types
6 | string
7 | nat
8 | constants
9 | Al Akin Bob Bo Carl Cork Dan Dunn Math CS : string
10 | zero : nat
11 | functions
12 | succ : nat -> nat
13 | plus : nat, nat -> nat
14 | }
15 |
16 | schema S = literal : T {
17 | entities
18 | Employee
19 | Department
20 | foreign_keys
21 | manager : Employee -> Employee
22 | worksIn : Employee -> Department
23 | secretary : Department -> Employee
24 | attributes
25 | first last : Employee -> string
26 | age : Employee -> nat
27 | name : Department -> string
28 | }
29 |
30 | instance I = literal : S {
31 | generators
32 | a b : Employee
33 | equations
34 | a.manager=a a.worksIn.secretary=a
35 | b.manager=a b.worksIn = a.worksIn
36 | first(a) = Al
37 | first(b) = Bob last(b) = Bo
38 | }
39 |
--------------------------------------------------------------------------------
/http/src/Api/Config/Config.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | module Api.Config.Config where
22 |
23 | import Api.Config.Environment (Environment)
24 |
25 | data Config = Config
26 | { environment :: Environment
27 | , apiPort :: Int
28 | }
29 |
--------------------------------------------------------------------------------
/examples/Mapping.cql:
--------------------------------------------------------------------------------
1 | typeside T = literal {
2 | types string
3 | constants o : string
4 | functions reverse : string -> string
5 | equations
6 | forall x:string. x.reverse.reverse = x
7 | }
8 |
9 | schema S = literal : T {
10 | entities E
11 | foreign_keys f : E -> E
12 | path_equations
13 | f.f = E
14 | attributes a1 a2 : E -> string
15 | observation_equations
16 | forall e:E. e.a1 = e.a2
17 | options
18 | allow_empty_sorts_unsafe = true
19 | program_allow_nontermination_unsafe = true
20 | }
21 |
22 | mapping M = literal : S -> S {
23 | entity E -> E
24 | foreign_keys
25 | f -> f.f
26 | attributes
27 | a1 -> lambda x. x.a1.reverse.reverse
28 | a2 -> lambda x. x.a2
29 | }
30 |
31 | instance I = literal : S {
32 | generators
33 | e : E
34 | equations
35 | e.a1 = e.a2
36 | options
37 | program_allow_nontermination_unsafe = true
38 | }
39 |
40 | transform h = literal : I -> I {
41 | generators
42 | e -> e.f
43 | }
44 |
45 | mapping m2 = [ M ; M ]
46 |
47 | transform h2 = [ h ; h ]
48 |
--------------------------------------------------------------------------------
/.editorconfig:
--------------------------------------------------------------------------------
1 | # SPDX-License-Identifier: AGPL-3.0-only
2 | #
3 | # This file is part of `statebox/cql`, the categorical query language.
4 | #
5 | # Copyright (C) 2019 Stichting Statebox
6 | #
7 | # This program is free software: you can redistribute it and/or modify
8 | # it under the terms of the GNU Affero General Public License as published by
9 | # the Free Software Foundation, either version 3 of the License, or
10 | # (at your option) any later version.
11 | #
12 | # This program is distributed in the hope that it will be useful,
13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 | # GNU Affero General Public License for more details.
16 | #
17 | # You should have received a copy of the GNU Affero General Public License
18 | # along with this program. If not, see .
19 |
20 | # see https://EditorConfig.org
21 |
22 | # top-most EditorConfig file
23 | root = true
24 |
25 | # Unix-style newlines with a newline ending every file
26 | [*]
27 | charset = utf-8
28 | end_of_line = lf
29 | trim_trailing_whitespace = true
30 | insert_final_newline = true
31 | indent_style = space
32 | indent_size = 2
33 |
--------------------------------------------------------------------------------
/examples/Petri.cql:
--------------------------------------------------------------------------------
1 | schema Net = literal : empty {
2 | entities
3 | Input Place Trans Output
4 | foreign_keys
5 | place : Input -> Place
6 | trans : Input -> Trans
7 | place : Output -> Place
8 | trans : Output -> Trans
9 | }
10 |
11 | // p1 ->t1-> p2 ->t2-> p3
12 | instance N = literal : Net {
13 | generators
14 | p1 p2 p3 : Place
15 | t1 t2 : Trans
16 | i1 i2 : Input
17 | o1 o2 : Output
18 | equations
19 | i1.place = p1
20 | i1.trans = t1
21 | o1.trans = t1
22 | o1.place = p2
23 |
24 | i2.place = p2
25 | i2.trans = t2
26 | o2.trans = t2
27 | o2.place = p3
28 |
29 | options
30 | interpret_as_algebra = true
31 | }
32 |
33 | // entities
34 | // i1 i2 o1 o2 p1 p2 p3 t1 t2
35 | // foreign_keys
36 | // trans : o2 -> t2
37 | // place : o2 -> p3
38 | // place : o1 -> p2
39 | // trans : o1 -> t1
40 | // trans : i2 -> t2
41 | // place : i2 -> p2
42 | // place : i1 -> p1
43 | // trans : i1 -> t1
44 |
45 | //schema intN = pivot N
46 |
47 | //mapping proj = pivot N // intN -> Net
48 |
49 | //instance J = pivot N
50 |
51 | //instance k = sigma proj J // = I
52 |
--------------------------------------------------------------------------------
/http/src/Api/Config/Environment.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | module Api.Config.Environment where
22 |
23 | -- wai
24 | import Network.Wai (Middleware)
25 |
26 | -- wai-extra
27 | import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)
28 |
29 | data Environment
30 | = Development
31 | | Production
32 | deriving (Show, Read)
33 |
34 | logger :: Environment -> Middleware
35 | logger Development = logStdoutDev
36 | logger Production = logStdout
37 |
--------------------------------------------------------------------------------
/http/src/Api/Api.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE DataKinds #-}
22 | {-# LANGUAGE TypeOperators #-}
23 |
24 | module Api.Api where
25 |
26 | import Language.CQL (runProg)
27 |
28 | -- servant-server
29 | import Servant ((:>), Handler, PlainText, Post, ReqBody, Server)
30 |
31 | type API = "cql" :> ReqBody '[PlainText] String :> Post '[PlainText] String
32 |
33 | cqlApi :: Server API
34 | cqlApi = cqlEndpoint
35 |
36 | cqlEndpoint :: String -> Handler String
37 | cqlEndpoint cqlDefinition = do
38 | let cqlEnvironment = runProg cqlDefinition
39 | pure $ either id (\(_, _, env) -> show env) cqlEnvironment
40 |
--------------------------------------------------------------------------------
/http/src/Api/Lib.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | module Api.Lib where
22 |
23 | import Api.Api (API, cqlApi)
24 | import Api.Config.Config (Config (..))
25 | import Api.Config.Environment (logger)
26 |
27 | -- servant-server
28 | import Servant (Application, Proxy (Proxy), serve)
29 |
30 | -- warp
31 | import Network.Wai.Handler.Warp (defaultSettings, runSettings,
32 | setPort)
33 |
34 | startApp :: Config -> IO ()
35 | startApp config = runSettings
36 | (setPort (apiPort config) defaultSettings)
37 | (app config)
38 |
39 | app :: Config -> Application
40 | app config = logger (environment config) $ serve api cqlApi
41 |
42 | api :: Proxy API
43 | api = Proxy
44 |
--------------------------------------------------------------------------------
/http/src/Api/App.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | module Api.App where
22 |
23 | import Api.Config.Config (Config (Config))
24 | import Api.Config.Environment (Environment (Development))
25 | import Api.Lib (startApp)
26 |
27 | -- base
28 | import Data.Maybe (fromMaybe)
29 | import System.Environment (lookupEnv)
30 | import Text.Read (readMaybe)
31 |
32 | app :: IO ()
33 | app = do
34 | environment <- lookupEnvVar "CQL_ENV" Development
35 | apiPort <- lookupEnvVar "PORT" 8080
36 | startApp $ Config environment apiPort
37 |
38 | lookupEnvVar :: (Read a, Show a) => String -> a -> IO a
39 | lookupEnvVar variable default' = do
40 | maybeValue <- lookupEnv variable
41 | return $ fromMaybe default' $ readMaybe =<< maybeValue
42 |
--------------------------------------------------------------------------------
/examples/KB.cql:
--------------------------------------------------------------------------------
1 | //one = two should not be provable
2 | /*
3 | typeside EmptySortsCheck = literal {
4 | types
5 | void
6 | nat
7 | constants
8 | one two : nat
9 | equations
10 | forall x:void. one = two
11 | options
12 | prover = completion
13 | allow_empty_sorts_unsafe = true
14 | }
15 | */
16 | options
17 | prover = completion
18 | allow_empty_sorts_unsafe = true
19 | require_consistency = false
20 |
21 | typeside Group = literal {
22 | types
23 | S
24 | constants
25 | e : S
26 | functions
27 | I : S -> S
28 | o : S,S -> S
29 | equations
30 | forall x. (e o x) = x
31 | forall x. (I(x) o x) = e
32 | forall x, y, z. ((x o y) o z) = (x o (y o z))
33 |
34 | }
35 |
36 | schema G = literal : Group {
37 | entities
38 | E
39 | attributes
40 | g : E -> S
41 | }
42 |
43 | instance AGroup = literal : G {
44 | generators
45 | e : E
46 | equations
47 | e.g.I = e.g
48 | (e.g o e.g) = e.g
49 | }
50 |
51 | /*
52 | typeside CompletedGroup = literal {
53 | types
54 | S
55 | constants
56 | e : S
57 | functions
58 | I : S -> S
59 | o : S,S -> S
60 | equations
61 | forall x. (e o x) = x
62 | forall x. (I(x) o x) = e
63 | forall x, y, z. ((x o y) o z) = (x o (y o z))
64 |
65 | forall x, y. (I(x) o (x o y)) = y
66 | forall . I(e) = e
67 | forall x. (x o e) = x
68 | forall x. I(I(x)) = x
69 | forall x. (x o I(x)) = e
70 | forall x y. (x o (I(x) o y)) = y
71 | forall x y. I((x o y)) = (I(y) o I(x))
72 |
73 | options
74 | prover = completion
75 | }
76 | */
77 |
--------------------------------------------------------------------------------
/examples/Employee.cql:
--------------------------------------------------------------------------------
1 | options
2 | //prover = completion
3 | program_allow_nontermination_unsafe = true
4 | allow_empty_sorts_unsafe = true
5 | //timeout = "1"
6 |
7 | typeside T = literal {
8 | types
9 | string
10 | nat
11 | constants
12 | Al Akin Bob Bo Carl Cork Dan Dunn Math CS : string
13 | zero : nat
14 | functions
15 | succ : nat -> nat
16 | plus : nat, nat -> nat
17 | // equations
18 | // zero = zero
19 | // forall x . plus(zero, x) = x
20 | // forall x , y . plus(succ(x),y) = succ(plus(x,y))
21 | }
22 |
23 | schema S = literal : T {
24 | entities
25 | Employee
26 | Department
27 | foreign_keys
28 | manager : Employee -> Employee
29 | worksIn : Employee -> Department
30 | secretary : Department -> Employee
31 | attributes
32 | first last : Employee -> string
33 | age : Employee -> nat
34 | name : Department -> string
35 | // observation_equations
36 | // forall e. e.first = Al
37 | }
38 |
39 | instance I = literal : S {
40 | generators
41 | a b : Employee
42 | equations
43 | a.manager=a a.worksIn.secretary=a
44 | b.manager=a b.worksIn = a.worksIn
45 | last(b) = Bo
46 |
47 | multi_equations
48 | first -> {a Al, b Bob}
49 | }
50 |
51 | instance J = literal : S {
52 | generators
53 | a b : Employee
54 | c d : Department
55 | y : nat
56 | equations
57 | a.manager = a a.worksIn = d c.secretary = b
58 | b.manager = a b.worksIn = c d.secretary = b
59 | first(a) = Al
60 | a.last = Al
61 | d.name = Bob
62 | c.name = Al
63 | age(a) = zero
64 | age(b) = y
65 | options interpret_as_algebra = true
66 | }
67 |
--------------------------------------------------------------------------------
/src/Language/CQL/Parser/LexerRules.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | module Language.CQL.Parser.LexerRules where
22 |
23 | -- megaparsec
24 | import Text.Megaparsec
25 | import Text.Megaparsec.Char
26 | import qualified Text.Megaparsec.Char.Lexer as L
27 |
28 | -- void
29 | import Data.Void
30 |
31 | type Parser = Parsec Void String
32 |
33 | spaceConsumer :: Parser ()
34 | spaceConsumer = L.space space1 lineComment blockComment
35 | where
36 | lineComment = L.skipLineComment "//"
37 | blockComment = L.skipBlockComment "(*" "*)" <|> L.skipBlockComment "/*" "*/"
38 |
39 | lexeme :: Parser a -> Parser a
40 | lexeme = L.lexeme spaceConsumer
41 |
42 | idChar :: Parser Char
43 | idChar = letterChar <|> char '_' <|> char '$'
44 |
45 | upperId :: Parser String
46 | upperId = (:) <$> upperChar <*> many (idChar <|> digitChar)
47 |
48 | lowerId :: Parser String
49 | lowerId = (:) <$> lowerChar <*> many (idChar <|> digitChar)
50 |
51 | specialId :: Parser String
52 | specialId = (:) <$> idChar <*> many (idChar <|> digitChar)
53 |
--------------------------------------------------------------------------------
/cli/Main.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | module Main where
22 |
23 | import Language.CQL
24 | import System.Environment
25 |
26 | main :: IO ()
27 | main = do
28 | args <- getArgs
29 | src <- mapM readFile args
30 | _ <- mapM (putStrLn . showResult . runProg) src
31 | return ()
32 | where
33 | showResult r = case r of
34 | Right (_, types, env) ->
35 | "////////////////////////////////////////////////////////////////////////////////\n" ++
36 | "// types //\n" ++
37 | "////////////////////////////////////////////////////////////////////////////////\n" ++
38 | "\n" ++
39 | "\n" ++
40 | show types ++
41 | "////////////////////////////////////////////////////////////////////////////////\n" ++
42 | "// environment //\n" ++
43 | "////////////////////////////////////////////////////////////////////////////////\n" ++
44 | "\n" ++
45 | show env
46 | Left err -> err
47 |
48 |
--------------------------------------------------------------------------------
/cql.nix:
--------------------------------------------------------------------------------
1 | /*
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | */
21 |
22 | { mkDerivation, stdenv, hpack, hspec
23 | , base, containers, megaparsec, servant-server, term-rewriting, tabular, wai
24 | , wai-extra, warp, twee-lib, union-find, fgl, mtl, PropLogic }:
25 |
26 | mkDerivation {
27 | pname = "cql";
28 | version = "0.1.0.0";
29 | src = ./.;
30 |
31 | isLibrary = true;
32 | isExecutable = true;
33 | doCheck = true;
34 |
35 | libraryHaskellDepends = [
36 | base containers megaparsec servant-server term-rewriting tabular wai wai-extra
37 | warp twee-lib union-find fgl mtl PropLogic
38 | ];
39 | executableHaskellDepends = [
40 | base megaparsec term-rewriting twee-lib containers union-find fgl mtl PropLogic
41 | ];
42 | testHaskellDepends = [
43 | base megaparsec term-rewriting hspec twee-lib containers union-find fgl mtl PropLogic
44 | ];
45 | buildDepends = [ hpack ];
46 |
47 | preConfigure = ''
48 | hpack
49 | '';
50 |
51 | homepage = "https://github.com/statebox/cql";
52 | description = "CQL - Categorical Query Language implementation in Haskell";
53 | license = stdenv.lib.licenses.agpl3;
54 | }
55 |
--------------------------------------------------------------------------------
/http/package.yaml:
--------------------------------------------------------------------------------
1 | # SPDX-License-Identifier: AGPL-3.0-only
2 | #
3 | # This file is part of `statebox/cql`, the categorical query language.
4 | #
5 | # Copyright (C) 2019 Stichting Statebox
6 | #
7 | # This program is free software: you can redistribute it and/or modify
8 | # it under the terms of the GNU Affero General Public License as published by
9 | # the Free Software Foundation, either version 3 of the License, or
10 | # (at your option) any later version.
11 | #
12 | # This program is distributed in the hope that it will be useful,
13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 | # GNU Affero General Public License for more details.
16 | #
17 | # You should have received a copy of the GNU Affero General Public License
18 | # along with this program. If not, see .
19 | name: cql-http
20 | version: 0.1.0.0
21 | github: "statebox/cql"
22 | license: AGPL
23 | author: "Statebox"
24 | copyright: "2019 Statebox"
25 |
26 |
27 | # Metadata used when publishing your package
28 | # synopsis: Short description of your package
29 | # category: Web
30 |
31 | # To avoid duplicated efforts in documentation and dealing with the
32 | # complications of embedding Haddock markup inside cabal files, it is
33 | # common to point users to the README.md file.
34 | description: Please see the README on GitHub at
35 |
36 | dependencies:
37 | - cql
38 | - base >= 4.7 && < 5
39 | - servant-server
40 | - wai
41 | - wai-extra
42 | - warp
43 |
44 | library:
45 | source-dirs: src
46 |
47 | ghc-options:
48 | - -Wall
49 | - -Werror
50 |
51 | executables:
52 | cql-http:
53 | main: Main.hs
54 | source-dirs: .
55 | ghc-options:
56 | - -threaded
57 | - -rtsopts
58 | - -with-rtsopts=-N
59 | dependencies:
60 | - cql-http
61 |
--------------------------------------------------------------------------------
/src/Language/CQL/Graph.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 |
22 | module Language.CQL.Graph where
23 |
24 | import Prelude
25 |
26 | data Graph a = Graph { vertices :: [a], edges :: [(a, a)] } deriving Show
27 |
28 | removeEdge :: (Eq a) => (a, a) -> Graph a -> Graph a
29 | removeEdge x (Graph v e) = Graph v (filter (/=x) e)
30 |
31 | connections :: (Eq a) => ((a, a) -> a) -> a -> Graph a -> [(a, a)]
32 | connections f0 x (Graph _ e) = filter ((==x) . f0) e
33 |
34 | outbound :: Eq b => b -> Graph b -> [(b, b)]
35 | outbound = connections fst
36 |
37 | inbound :: Eq a => a -> Graph a -> [(a, a)]
38 | inbound = connections snd
39 |
40 | -- | Topological sort.
41 | tsort :: (Eq a) => Graph a -> Either String [a]
42 | tsort graph = tsort' [] (noInbound graph) graph
43 | where
44 | noInbound (Graph v e) = filter (flip notElem $ fmap snd e) v
45 | tsort' l [] (Graph _ []) = pure $ reverse l
46 | tsort' _ [] _ = Left "There is at least one cycle in the graph."
47 | tsort' l (n:s) g = tsort' (n:l) s' g'
48 | where
49 | outEdges = outbound n g
50 | outNodes = snd <$> outEdges
51 | g' = foldr removeEdge g outEdges
52 | s' = s ++ filter (null . flip inbound g') outNodes
53 |
--------------------------------------------------------------------------------
/test/Language/CQL/Parser/Generator.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | module Language.CQL.Parser.Generator where
22 |
23 | import Language.CQL.Parser.ReservedWords
24 | import Test.QuickCheck.Gen
25 |
26 | lowerCharGen :: Gen Char
27 | lowerCharGen = elements ['a' .. 'z']
28 |
29 | upperCharGen :: Gen Char
30 | upperCharGen = elements ['A' .. 'Z']
31 |
32 | idCharGen :: Gen Char
33 | idCharGen = oneof [lowerCharGen, upperCharGen, elements ['_', '$']]
34 |
35 | digitCharGen :: Gen Char
36 | digitCharGen = elements ['0' .. '9']
37 |
38 | upperIdGen :: Gen String
39 | upperIdGen =
40 | ((:) <$> upperCharGen <*>
41 | listOf (oneof [idCharGen, digitCharGen])) `suchThat`
42 | (`notElem` reservedWords)
43 |
44 | lowerIdGen :: Gen String
45 | lowerIdGen =
46 | ((:) <$> lowerCharGen <*>
47 | listOf (oneof [idCharGen, digitCharGen])) `suchThat`
48 | (`notElem` reservedWords)
49 |
50 | specialIdGen :: Gen String
51 | specialIdGen =
52 | ((:) <$> idCharGen <*>
53 | listOf (oneof [idCharGen, digitCharGen])) `suchThat`
54 | (`notElem` reservedWords)
55 |
56 | identifierGen :: Gen String
57 | identifierGen = oneof [lowerIdGen, upperIdGen, specialIdGen]
58 |
59 | boolGen :: Gen Bool
60 | boolGen = oneof [pure True, pure False]
61 |
--------------------------------------------------------------------------------
/default.nix:
--------------------------------------------------------------------------------
1 | /*
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | */
21 |
22 | # Nix package for development
23 | #
24 | ## INSTALL
25 | #
26 | # To build and install the packages in the user environment, use:
27 | #
28 | # $ nix-env -f . -i
29 | #
30 | ## BUILD ONLY
31 | #
32 | # To build the packages and add it to the nix store, use:
33 | #
34 | # $ nix-build
35 | #
36 | ## SHELL
37 | #
38 | # To launch a shell with all dependencies installed in the environment:
39 | #
40 | # $ nix-shell -A cql
41 | #
42 | # After entering nix-shell, build it:
43 | #
44 | # $ make
45 | #
46 | ## NIXPKGS
47 | #
48 | # For all of the above commands, nixpkgs to use can be set the following way:
49 | #
50 | # a) by default it uses nixpkgs pinned to a known working version
51 | #
52 | # b) use the default nixpkgs from the system:
53 | # --arg pkgs 0
54 | #
55 | # c) use nixpkgs from an URL
56 | # --arg pkgs 0 -I nixpkgs=https://github.com/NixOS/nixpkgs/archive/18.03.tar.gz
57 | #
58 | # c) use nixpkgs at a given path
59 | # --arg pkgs /path/to/nixpkgs
60 |
61 | {
62 | pkgs ? null,
63 | }:
64 |
65 | let
66 | syspkgs = import { };
67 | pinpkgs = syspkgs.fetchFromGitHub {
68 | owner = "NixOS";
69 | repo = "nixpkgs";
70 |
71 | # binary cache exists for revisions listed in https://nixos.org/channels//git-revision
72 | rev = "0ab8fa2181a5d6561de673a91d51a2a082622328";
73 | sha256 = "1ldhn86pk7ajmkicm33h0lbipgvx439mll3llabkmr330lyrkgpz";
74 | };
75 | usepkgs = if null == pkgs then
76 | import pinpkgs {}
77 | else
78 | if 0 == pkgs then
79 | import { }
80 | else
81 | import pkgs {};
82 | stdenv = usepkgs.stdenvAdapters.keepDebugInfo usepkgs.stdenv;
83 |
84 | in {
85 | cql = usepkgs.haskellPackages.callPackage ./cql.nix { };
86 | }
87 |
--------------------------------------------------------------------------------
/examples/Delta.cql:
--------------------------------------------------------------------------------
1 | typeside Ty = literal {
2 | types
3 | int
4 | string
5 | // constants
6 | // "100" "150" "200" "250" "300" : int
7 | // "115-234" "112-988" "198-887" Smith Jones "250" "300" "100" : string
8 | options
9 | allow_empty_sorts_unsafe = true
10 | }
11 |
12 | schema C = literal : Ty {
13 | entities
14 | T1 T2
15 | attributes
16 | ssn first1 last1 : T1 -> string
17 | first2 last2 : T2 -> string
18 | salary : T2 -> int
19 | options
20 | allow_empty_sorts_unsafe = true
21 | }
22 |
23 | schema D = literal : Ty {
24 | entities
25 | T
26 | attributes
27 | ssn0 first0 last0 : T -> string
28 | salary0 : T -> int
29 | options
30 | allow_empty_sorts_unsafe = true
31 | }
32 |
33 | mapping F = literal : C -> D {
34 | entity
35 | T1 -> T
36 | attributes
37 | ssn -> lambda x. ssn0(x)
38 | first1 -> lambda x. first0(x)
39 | last1 -> lambda x. x.last0
40 |
41 | entity
42 | T2 -> T
43 | attributes
44 | last2 -> lambda x. x.last0
45 | salary -> salary0 // dot notation
46 | first2 -> lambda x. x.first0
47 | }
48 |
49 | instance J = literal : D {
50 | generators
51 | XF667 XF891 XF221 : T
52 | equations
53 | // XF667.ssn0 = "115-234" XF891.ssn0 = "112-988" XF221.ssn0 = "198-887"
54 | // XF667.first0 = Bob XF891.first0 = Sue XF221.first0 = Alice
55 | // XF667.last0 = Smith XF891.last0 = Smith XF221.last0 = Jones
56 | // XF667.salary0 = 250 XF891.salary0 = 300 XF221.salary0 = 100
57 | options
58 | allow_empty_sorts_unsafe = true
59 | }
60 |
61 | instance deltaFJ = delta F J
62 |
63 | instance J0 = literal : D {
64 | generators
65 | XF22 aXF66 XF89 xxx : T
66 | // equations
67 | // aXF66.ssn0 = "115-234" XF89.ssn0 = "112-988" XF22.ssn0 = "198-887"
68 | // aXF66.first0 = Bob XF89.first0 = Sue XF22.first0 = Alice
69 | // aXF66.last0 = Smith XF89.last0 = Smith XF22.last0 = Jones
70 | // aXF66.salary0 = 250 XF89.salary0 = 300 XF22.salary0 = 100
71 | options
72 | allow_empty_sorts_unsafe = true
73 | }
74 |
75 | transform h = literal : J -> J0 {
76 | generators
77 | XF667 -> aXF66
78 | XF891 -> XF89
79 | XF221 -> XF22
80 | }
81 |
82 | transform h0 = delta F h
83 |
84 | instance sigmadeltaFJ = sigma F deltaFJ {
85 | options
86 | program_allow_nontermination_unsafe = true
87 | allow_empty_sorts_unsafe = true
88 | }
89 |
90 | transform u = counit F J {
91 | options
92 | program_allow_nontermination_unsafe = true
93 | allow_empty_sorts_unsafe = true
94 | }
95 |
--------------------------------------------------------------------------------
/package.yaml:
--------------------------------------------------------------------------------
1 | # SPDX-License-Identifier: AGPL-3.0-only
2 | #
3 | # This file is part of `statebox/cql`, the categorical query language.
4 | #
5 | # Copyright (C) 2019 Stichting Statebox
6 | #
7 | # This program is free software: you can redistribute it and/or modify
8 | # it under the terms of the GNU Affero General Public License as published by
9 | # the Free Software Foundation, either version 3 of the License, or
10 | # (at your option) any later version.
11 | #
12 | # This program is distributed in the hope that it will be useful,
13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 | # GNU Affero General Public License for more details.
16 | #
17 | # You should have received a copy of the GNU Affero General Public License
18 | # along with this program. If not, see .
19 |
20 | name: cql
21 | version: 0.1.0.0
22 | github: "statebox/cql"
23 | license: AGPL
24 | author: "Statebox"
25 | copyright: "2019 Statebox"
26 |
27 | extra-source-files:
28 | - README.md
29 |
30 | # Metadata used when publishing your package
31 | # synopsis: Short description of your package
32 | # category: Web
33 |
34 | # To avoid duplicated efforts in documentation and dealing with the
35 | # complications of embedding Haddock markup inside cabal files, it is
36 | # common to point users to the README.md file.
37 | description: Please see the README on GitHub at
38 |
39 | dependencies:
40 | - base >= 4.7 && < 5
41 | - containers
42 | - megaparsec
43 | - QuickCheck
44 | - scientific
45 | - semigroups
46 | - term-rewriting
47 | - tabular
48 | - deepseq
49 | - twee-lib
50 | - pretty
51 | - containers
52 | - union-find >=0.2 && <0.3
53 | - fgl >=5.5
54 | - mtl >= 2.0
55 | - PropLogic >= 0.9.0.4
56 |
57 | library:
58 | source-dirs: src
59 |
60 | ghc-options:
61 | - -Weverything
62 | - -Werror
63 | - -Wno-implicit-prelude
64 | - -Wno-missing-export-lists
65 | - -Wno-missing-import-lists
66 | - -Wno-safe
67 | - -Wno-missing-local-signatures
68 | - -Wno-unsafe
69 | - -Wno-monomorphism-restriction
70 | - -Wno-unused-type-patterns
71 | - -Wno-name-shadowing
72 |
73 | executables:
74 | cql:
75 | main: Main.hs
76 | source-dirs: cli
77 | ghc-options:
78 | - -threaded
79 | - -rtsopts
80 | - -with-rtsopts=-N
81 | dependencies:
82 | - cql
83 |
84 | tests:
85 | cql-test:
86 | main: Spec.hs
87 | source-dirs: test
88 | ghc-options:
89 | - -threaded
90 | - -rtsopts
91 | - -with-rtsopts=-N
92 | dependencies:
93 | - cql
94 | - hspec
95 | - QuickCheck
96 |
--------------------------------------------------------------------------------
/test/Parser/ParserSpec.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE ScopedTypeVariables #-}
22 |
23 | module Parser.ParserSpec where
24 |
25 | import Language.CQL.Parser.Generator
26 | import Language.CQL.Parser.Parser
27 | import Language.CQL.Parser.ReservedWords
28 | import Data.Either (isLeft)
29 | import Test.Hspec
30 | import Text.Megaparsec
31 | import Test.QuickCheck
32 |
33 | spec :: Spec
34 | spec = do
35 | describe "constant" $
36 | specify "parses correctly a constant" $
37 | property $ \(anyConstant :: String) ->
38 | parse (constant anyConstant) "" anyConstant == Right anyConstant
39 |
40 | describe "identifier" $ do
41 | specify "parses correctly a string starting with a lowercase character" $
42 | forAll lowerIdGen $ \s -> parse identifier "" s == Right s
43 | specify "parses correctly a string starting with an uppercase character" $
44 | forAll upperIdGen $ \s -> parse identifier "" s == Right s
45 | specify "parses correctly a string starting with a special character" $
46 | forAll specialIdGen $ \s -> parse identifier "" s == Right s
47 | specify "does not parse a string starting with a digit" $
48 | forAll ((:) <$> digitCharGen <*> listOf (oneof [idCharGen, digitCharGen])) $ \s ->
49 | isLeft $ parse identifier "" s
50 | specify
51 | "does not parse a string starting with an illegal special character" $
52 | forAll
53 | ((:) <$> (elements ['!', '"', '£', '%', '&', '/', '(', ')', '=', '?']) <*>
54 | listOf (oneof [idCharGen, digitCharGen])) $ \s ->
55 | isLeft $ parse identifier "" s
56 | specify "does not parse a reserved word" $
57 | forAll (elements reservedWords) $ \s -> isLeft $ parse identifier "" s
58 |
59 | describe "boolParser" $ do
60 | it "parses correctly a false" $ parse boolParser "" "false" == Right False
61 | it "parses correctly a true" $ parse boolParser "" "true" == Right True
62 |
--------------------------------------------------------------------------------
/src/Language/CQL/Parser/ReservedWords.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | module Language.CQL.Parser.ReservedWords where
22 |
23 | reservedWords :: [String]
24 | reservedWords =
25 | [ "sigma_chase"
26 | , "entity"
27 | , "md"
28 | , "quotient_jdbc"
29 | , "random"
30 | , "sql"
31 | , "chase"
32 | , "check"
33 | , "import_csv"
34 | , "quotient_csv"
35 | , "coproduct"
36 | , "simple"
37 | , "assert_consistent"
38 | , "coproduct_sigma"
39 | , "coequalize"
40 | , "html"
41 | , "quotient"
42 | , "entity_equations"
43 | , "schema_colimit"
44 | , "exists"
45 | , "constraints"
46 | , "getMapping"
47 | , "getSchema"
48 | , "typeside"
49 | , "schema"
50 | , "mapping"
51 | , "instance"
52 | , "transform"
53 | , "query"
54 | , "command"
55 | , "graph"
56 | , "exec_jdbc"
57 | , "exec_js"
58 | , "exec_cmdline"
59 | , "literal"
60 | , "add_to_classpath"
61 | , "identity"
62 | , "match"
63 | , "attributes"
64 | , "empty"
65 | , "imports"
66 | , "types"
67 | , "constants"
68 | , "functions"
69 | , "equations"
70 | , "forall"
71 | , "java_types"
72 | , "multi_equations"
73 | , "pi"
74 | , "bindings"
75 | , "toQuery"
76 | , "toCoQuery"
77 | , "anonymize"
78 | , "frozen"
79 | , "params"
80 | , "java_constants"
81 | , "java_functions"
82 | , "options"
83 | , "entities"
84 | , "src"
85 | , "unique"
86 | , "dst"
87 | , "path_equations"
88 | , "observation_equations"
89 | , "generators"
90 | , "rename"
91 | , "remove"
92 | , "modify"
93 | , "foreign_keys"
94 | , "lambda"
95 | , "sigma"
96 | , "delta"
97 | , "pi"
98 | , "unit"
99 | , "counit"
100 | , "eval"
101 | , "coeval"
102 | , "ed"
103 | , "chase"
104 | , "from"
105 | , "where"
106 | , "return"
107 | , "pivot"
108 | , "copivot"
109 | , "colimit"
110 | , "nodes"
111 | , "edges"
112 | , "typesideOf"
113 | , "schemaOf"
114 | , "distinct"
115 | , "import_csv"
116 | , "export_csv_instance"
117 | , "export_csv_transform"
118 | , "import_jdbc"
119 | , "import_jdbc_all"
120 | , "export_jdbc_transform"
121 | , "export_jdbc_instance"
122 | , "export_jdbc_query"
123 | , "unit_query"
124 | , "counit_query"
125 | , "union"
126 | , "wrap"
127 | ]
128 |
--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
1 | # SPDX-License-Identifier: AGPL-3.0-only
2 | #
3 | # This file is part of `statebox/cql`, the categorical query language.
4 | #
5 | # Copyright (C) 2019 Stichting Statebox
6 | #
7 | # This program is free software: you can redistribute it and/or modify
8 | # it under the terms of the GNU Affero General Public License as published by
9 | # the Free Software Foundation, either version 3 of the License, or
10 | # (at your option) any later version.
11 | #
12 | # This program is distributed in the hope that it will be useful,
13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 | # GNU Affero General Public License for more details.
16 | #
17 | # You should have received a copy of the GNU Affero General Public License
18 | # along with this program. If not, see .
19 |
20 | # This file was automatically generated by 'stack init'
21 | #
22 | # Some commonly used options have been documented as comments in this file.
23 | # For advanced use and comprehensive documentation of the format, please see:
24 | # https://docs.haskellstack.org/en/stable/yaml_configuration/
25 |
26 | # Resolver to choose a 'specific' stackage snapshot or a compiler version.
27 | # A snapshot resolver dictates the compiler version and the set of packages
28 | # to be used for project dependencies. For example:
29 | #
30 | # resolver: lts-3.5
31 | # resolver: nightly-2015-09-21
32 | # resolver: ghc-7.10.2
33 | # resolver: ghcjs-0.1.0_ghc-7.10.2
34 | #
35 | # The location of a snapshot can be provided as a file or url. Stack assumes
36 | # a snapshot provided as a file might change, whereas a url resource does not.
37 | #
38 | # resolver: ./custom-snapshot.yaml
39 | # resolver: https://example.com/snapshots/2018-01-01.yaml
40 | resolver: lts-12.0
41 |
42 | # User packages to be built.
43 | # Various formats can be used as shown in the example below.
44 | #
45 | # packages:
46 | # - some-directory
47 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz
48 | # - location:
49 | # git: https://github.com/commercialhaskell/stack.git
50 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
51 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
52 | # subdirs:
53 | # - auto-update
54 | # - wai
55 | packages:
56 | - .
57 | - http
58 | # Dependency packages to be pulled from upstream that are not in the resolver
59 | # using the same syntax as the packages field.
60 | # (e.g., acme-missiles-0.3)
61 | extra-deps: [multiset-0.3.4, union-find-array-0.1.0.2, term-rewriting-0.2.1.1, jukebox-0.3.7, twee-lib-2.1.5, minisat-0.1.2, PropLogic-0.9.0.4, fgl-5.6.0.0]
62 |
63 | # Override default flag values for local packages and extra-deps
64 | # flags: {}
65 |
66 | # Extra package databases containing global packages
67 | # extra-package-dbs: []
68 |
69 | # Control whether we use the GHC we find on the path
70 | # system-ghc: true
71 | #
72 | # Require a specific version of stack, using version ranges
73 | # require-stack-version: -any # Default
74 | # require-stack-version: ">=1.7"
75 | #
76 | # Override the architecture used by stack, especially useful on Windows
77 | # arch: i386
78 | # arch: x86_64
79 | #
80 | # Extra directories used by stack for building
81 | # extra-include-dirs: [/path/to/dir]
82 | # extra-lib-dirs: [/path/to/dir]
83 | #
84 | # Allow a newer minor version of GHC than the snapshot specifies
85 | # compiler-check: newer-minor
86 |
--------------------------------------------------------------------------------
/src/Language/CQL/Parser/Program.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 |
22 | module Language.CQL.Parser.Program where
23 |
24 | import Data.List
25 | import Data.Map as Map hiding ((\\))
26 | import Data.Maybe
27 | import Language.CQL.Common as C
28 | import Language.CQL.Parser.Instance as I
29 | import Language.CQL.Parser.LexerRules
30 | import Language.CQL.Parser.Mapping as M
31 | import Language.CQL.Parser.Parser
32 | import Language.CQL.Parser.Schema as S'
33 | import Language.CQL.Parser.Transform as TT
34 | import Language.CQL.Parser.Typeside as T'
35 | import Language.CQL.Program as P
36 | import Text.Megaparsec
37 |
38 | parseProgram :: String -> Err Prog
39 | parseProgram s = case runParser parseProgram' "" s of
40 | Left err -> Left $ "Parse error: " ++ parseErrorPretty err
41 | Right (opts, prog) -> if length (fst $ unzip prog) == length (nub $ fst $ unzip prog)
42 | then Right $ toProg opts prog
43 | else Left $ "Duplicate definition: " ++ show (nub (fmap fst prog \\ nub (fmap fst prog)))
44 |
45 | -- | Returns a list of config option key-value paired with programs.
46 | parseProgram' :: Parser ([(String, String)], [(String, Exp)])
47 | parseProgram' =
48 | between spaceConsumer eof configsAndProgs
49 | where
50 | configsAndProgs = do
51 | opts <- optional (constant "options" *> many optionParser)
52 | progs <- many parseExp
53 | return (fromMaybe [] opts, progs)
54 |
55 | toProg :: [(String, String)] -> [(String, Exp)] -> Prog
56 | toProg _ [] = newProg
57 | toProg opts ((v,e):p) = case e of
58 | ExpTy ty' -> KindCtx (Map.insert v ty' t) s i m q tr opts
59 | ExpS s' -> KindCtx t (Map.insert v s' s) i m q tr opts
60 | ExpI i' -> KindCtx t s (Map.insert v i' i) m q tr opts
61 | ExpM m' -> KindCtx t s i (Map.insert v m' m) q tr opts
62 | ExpQ q' -> KindCtx t s i m (Map.insert v q' q) tr opts
63 | ExpT t' -> KindCtx t s i m q (Map.insert v t' tr) opts
64 | where
65 | KindCtx t s i m q tr _ = toProg opts p
66 |
67 | parseExp :: Parser (String, Exp)
68 | parseExp =
69 | go "typeside" typesideExpParser ExpTy <|>
70 | go "schema" schemaExpParser ExpS <|>
71 | go "instance" instExpParser ExpI <|>
72 | go "mapping" mapExpParser ExpM <|>
73 | go "transform" transExpParser ExpT
74 | where
75 | go expKindName bodyParser ctor = do
76 | _ <- constant expKindName
77 | expName <- identifier
78 | _ <- constant "="
79 | body <- bodyParser
80 | return (expName, ctor body)
81 |
--------------------------------------------------------------------------------
/examples/Sigma.cql:
--------------------------------------------------------------------------------
1 | typeside Type = literal {
2 | types
3 | String
4 | constants
5 | gecko frog human cow horse dolphin fish : String
6 | }
7 |
8 | schema C = literal : Type {
9 | entities
10 | Amphibian
11 | LandAnimal
12 | WaterAnimal
13 | foreign_keys
14 | IsAL : Amphibian -> LandAnimal
15 | IsAW : Amphibian -> WaterAnimal
16 | attributes
17 | attA : Amphibian -> String
18 | attL : LandAnimal -> String
19 | attW : WaterAnimal -> String
20 | options
21 | allow_empty_sorts_unsafe = true
22 | }
23 |
24 | instance I = literal : C {
25 | generators
26 | a1 a2 : Amphibian
27 | l1 l2 l3 l4 l5 : LandAnimal
28 | w1 w2 w3 w4 : WaterAnimal
29 | equations
30 | attA(a1) = gecko attA(a2) = frog
31 | attL(l1) = gecko attL(l2) = frog
32 | attL(l3) = human attL(l4) = cow
33 | attL(l5) = horse attW(w1) = fish
34 | attW(w2) = gecko attW(w3) = frog
35 | attW(w4) = dolphin IsAL(a1) = l1
36 | IsAL(a2) = l2 IsAW(a1) = w2 IsAW(a2) = w3
37 | }
38 |
39 | schema D = literal : Type {
40 | entities
41 | yAmphibian
42 | yLandAnimal
43 | yWaterAnimal
44 | yAnimal
45 | foreign_keys
46 | yIsAL : yAmphibian -> yLandAnimal
47 | yIsAW : yAmphibian -> yWaterAnimal
48 | yIsALL : yLandAnimal -> yAnimal
49 | yIsAWW : yWaterAnimal -> yAnimal
50 | path_equations
51 | yIsAL.yIsALL = yIsAW.yIsAWW
52 | attributes
53 | yattA : yAmphibian -> String
54 | yattL : yLandAnimal -> String
55 | yattW : yWaterAnimal -> String
56 | options
57 | allow_empty_sorts_unsafe = true
58 | program_allow_nontermination_unsafe = true
59 | }
60 |
61 | mapping F = literal : C -> D {
62 | entity
63 | Amphibian -> yAmphibian
64 | foreign_keys
65 | IsAL -> yIsAL
66 | IsAW -> yIsAW
67 | attributes
68 | attA -> lambda x. x.yattA
69 |
70 | entity
71 | LandAnimal -> yLandAnimal
72 | attributes
73 | attL -> lambda x. x.yattL
74 |
75 | entity
76 | WaterAnimal -> yWaterAnimal
77 | attributes
78 | attW -> lambda x. x.yattW
79 | }
80 |
81 | instance J = sigma F I {
82 | options
83 | prover = program
84 | program_allow_nontermination_unsafe = true
85 | allow_empty_sorts_unsafe = true
86 | }
87 |
88 | instance I1 = literal : C {
89 | generators
90 | xa1 : Amphibian
91 | xl1 xl2 xl3 xl4 : LandAnimal
92 | xw1 xw2 xw3 : WaterAnimal
93 | equations
94 | attL(xl1) = gecko attL(xl2) = frog
95 | attL(xl3) = human attL(xl4) = cow
96 | attW(xw1) = fish attW(xw2) = gecko
97 | attW(xw3) = frog IsAL(xa1) = xl1
98 | IsAW(xa1) = xw2 attA(xa1) = gecko
99 | }
100 |
101 | transform t = literal : I1 -> I {
102 | generators
103 | xa1 -> a1
104 | xl1 -> l1
105 | xl2 -> l2
106 | xl3 -> l3
107 | xl4 -> l4
108 | xw1 -> w1
109 | xw2 -> w2
110 | xw3 -> w3
111 | }
112 |
113 | transform u = sigma F t {
114 | options
115 | program_allow_nontermination_unsafe = true
116 | allow_empty_sorts_unsafe = true
117 | }
118 |
119 |
120 | instance K = delta F J
121 |
122 | transform v = unit F I {
123 | options
124 | program_allow_nontermination_unsafe = true
125 | allow_empty_sorts_unsafe = true
126 | }
127 |
--------------------------------------------------------------------------------
/examples/Import.cql:
--------------------------------------------------------------------------------
1 | typeside Ty = literal {
2 | types
3 | string
4 | nat
5 | int
6 | constants
7 | Al Akin Bob Bo Carl Cork Dan Dunn Math CS : string
8 | zero : nat
9 | one : int
10 | functions
11 | succ : nat -> nat
12 | plus : nat, nat -> nat
13 | equations
14 | forall x:nat. plus(zero, x) = x
15 | forall x y:nat. plus(succ(x),y) = succ(plus(x,y))
16 | options
17 | program_allow_nontermination_unsafe=true
18 | }
19 |
20 | typeside Ty2 = literal {
21 | types
22 | string2
23 | nat
24 | constants
25 | sdds sdfiodf wefew fffd : string2
26 | zero : nat
27 | functions
28 | succ : nat -> nat
29 | plus : nat, nat -> nat
30 | equations
31 | forall x : nat. plus(zero, x) = x
32 | forall x y : nat. plus(succ(x),y) = succ(plus(x,y))
33 | options
34 | program_allow_nontermination_unsafe=true
35 | }
36 |
37 | typeside Ty3 = literal {
38 | imports Ty Ty2
39 | options
40 | program_allow_nontermination_unsafe=true
41 | }
42 |
43 | schema C = literal : Ty {
44 | entities
45 | T1 T2
46 | foreign_keys
47 | f : T1 -> T2
48 | g : T2 -> T2
49 | path_equations
50 | g.g = g
51 | attributes
52 | ssn first1 last1 : T1 -> string
53 | first2 last2 : T2 -> string
54 | salary : T2 -> int
55 | observation_equations
56 | //forall x. x.ssn = x.first1
57 | options
58 | program_allow_nontermination_unsafe=true
59 | allow_empty_sorts_unsafe = true
60 | }
61 |
62 | schema D = literal : Ty {
63 | entities
64 | T
65 | attributes
66 | ssn0 first0 last0 : T -> string
67 | salary0 : T -> int
68 | options
69 | program_allow_nontermination_unsafe=true
70 | allow_empty_sorts_unsafe = true
71 | }
72 |
73 | schema E = literal : Ty {
74 | imports C D
75 | options
76 | program_allow_nontermination_unsafe=true
77 | allow_empty_sorts_unsafe = true
78 | }
79 |
80 | instance I = literal : D {
81 | generators
82 | i : int
83 | s t : T
84 | equations
85 | t.ssn0 = t.last0
86 | options
87 | program_allow_nontermination_unsafe=true
88 | allow_empty_sorts_unsafe = true
89 | }
90 |
91 |
92 | instance J = literal : D {
93 | generators
94 | t0 : T
95 | equations
96 | t0.ssn0 = t0.last0
97 | options
98 | program_allow_nontermination_unsafe=true
99 | allow_empty_sorts_unsafe = true
100 | }
101 |
102 | instance K = literal : D {
103 | imports I J
104 | options
105 | program_allow_nontermination_unsafe=true
106 | allow_empty_sorts_unsafe = true
107 | }
108 |
109 | transform h1 = identity I
110 | transform h2 = identity J
111 | transform h = literal : K -> K {
112 | imports h1 h2
113 | }
114 |
115 | mapping F = literal : C -> D {
116 | entity
117 | T1 -> T
118 | foreign_keys
119 | f -> T
120 | attributes
121 | ssn -> lambda x. ssn0(x)
122 | first1 -> lambda x. first0(x)
123 | last1 -> lambda x. x.last0
124 |
125 | entity
126 | T2 -> T
127 | foreign_keys
128 | g -> T
129 | attributes
130 | last2 -> lambda x. x.last0
131 | salary -> lambda x. x.salary0
132 | first2 -> lambda x. x.first0
133 | }
134 |
135 | mapping F2 = identity D
136 |
137 | mapping G = literal : E -> E {
138 | imports F F2
139 | }
140 |
--------------------------------------------------------------------------------
/src/Language/CQL/Parser/Schema.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 |
22 | {-# LANGUAGE TupleSections #-}
23 |
24 | module Language.CQL.Parser.Schema where
25 |
26 | import Language.CQL.Parser.LexerRules
27 | import Language.CQL.Parser.Parser
28 | import Language.CQL.Parser.Typeside
29 | import Language.CQL.Schema as X
30 | import Language.CQL.Term
31 | import Language.CQL.Typeside
32 |
33 | -- base
34 | import Data.Maybe
35 |
36 | -- megaparsec
37 | import Text.Megaparsec
38 |
39 | obsEqParser :: Parser (String, Maybe String, RawTerm, RawTerm)
40 | obsEqParser = do
41 | _ <- constant "forall"
42 | i <- identifier
43 | j <- optional $ do { _ <- constant ":"; identifier }
44 | _ <- constant "."
45 | l <- rawTermParser
46 | _ <- constant "="
47 | r <- rawTermParser
48 | return (i, j, l, r)
49 |
50 | attParser :: Parser [(Att, (En, Ty))]
51 | attParser = fkParser
52 |
53 | fkParser :: Parser [(Fk, (En, En))]
54 | fkParser = do
55 | x <- some identifier
56 | _ <- constant ":"
57 | y <- identifier
58 | _ <- constant "->"
59 | z <- identifier
60 | return $ map (, (y, z)) x
61 |
62 | pathEqParser :: Parser ([Fk],[Fk])
63 | pathEqParser = do
64 | x <- sepBy1 identifier $ constant "."
65 | _ <- constant "="
66 | y <- sepBy1 identifier $ constant "."
67 | return (x, y)
68 |
69 | schemaRawParser :: Parser SchemaExpRaw'
70 | schemaRawParser = do
71 | _ <- constant "literal"
72 | _ <- constant ":"
73 | t <- typesideExpParser
74 | braces $ p t
75 | where
76 | p t = do
77 | i <- optional $ do
78 | _ <- constant "imports"
79 | many schemaExpParser
80 | e <- optional $ do
81 | _ <- constant "entities"
82 | many identifier
83 | f <- optional $ do
84 | _ <- constant "foreign_keys"
85 | many fkParser
86 | p' <- optional $ do
87 | _ <- constant "path_equations"
88 | many pathEqParser
89 | a <- optional $ do
90 | _ <- constant "attributes"
91 | many attParser
92 | o <- optional $ do
93 | _ <- constant "observation_equations"
94 | many obsEqParser
95 | o' <- optional $ do
96 | _ <- constant "options"
97 | many optionParser
98 | pure $ SchemaExpRaw' t
99 | (fromMaybe [] e)
100 | (concat $ fromMaybe [] f)
101 | (concat $ fromMaybe [] a)
102 | (fromMaybe [] p')
103 | (fromMaybe [] o )
104 | (fromMaybe [] o')
105 | (fromMaybe [] i )
106 |
107 | schemaExpParser :: Parser X.SchemaExp
108 | schemaExpParser
109 | = SchemaRaw <$> schemaRawParser
110 | <|> SchemaVar <$> identifier
111 | <|> do
112 | _ <- constant "empty"
113 | _ <- constant ":"
114 | SchemaInitial <$> typesideExpParser
115 | <|> parens schemaExpParser
116 |
--------------------------------------------------------------------------------
/src/Language/CQL/Parser/Typeside.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 |
22 | {-# LANGUAGE TupleSections #-}
23 |
24 | module Language.CQL.Parser.Typeside where
25 |
26 | import Language.CQL.Parser.LexerRules
27 | import Language.CQL.Parser.Parser
28 | import Language.CQL.Term
29 | import Language.CQL.Typeside as X
30 |
31 | -- base
32 | import Data.Maybe
33 |
34 | -- megaparsec
35 | import Text.Megaparsec
36 |
37 | typesideExpParser :: Parser TypesideExp
38 | typesideExpParser
39 | = parseSql
40 | <|> parseRaw
41 | <|> parseEmpty
42 | <|> parseVar
43 | <|> parens typesideExpParser
44 |
45 | parseEmpty :: Parser TypesideExp
46 | parseEmpty = do
47 | _ <- constant "empty"
48 | return TypesideInitial
49 |
50 | parseSql :: Parser TypesideExp
51 | parseSql = do
52 | _ <- constant "sql"
53 | return TypesideSql
54 |
55 | parseVar :: Parser TypesideExp
56 | parseVar = TypesideVar <$> identifier
57 |
58 | parseRaw :: Parser TypesideExp
59 | parseRaw = do
60 | _ <- constant "literal"
61 | TypesideRaw <$> braces typesideLiteralSectionParser
62 |
63 | eqParser :: Parser ([(String, Maybe String)], RawTerm, RawTerm)
64 | eqParser = do
65 | o <- p
66 | l <- rawTermParser
67 | _ <- constant "="
68 | r <- rawTermParser
69 | return (o, l, r)
70 | where
71 | p = do
72 | _ <- constant "forall"
73 | g <- sepBy varParser $ constant ","
74 | _ <- constant "."
75 | return $ concat g
76 | <|> return []
77 |
78 | varParser :: Parser [(String, Maybe String)]
79 | varParser = do
80 | x <- some identifier
81 | y <- optional $ do { _ <- constant ":" ; identifier }
82 | return $ map (, y) x
83 |
84 | constantParser :: Parser [(String, ([String], String))]
85 | constantParser = do
86 | x <- some identifier
87 | _ <- constant ":"
88 | y <- identifier
89 | return $ map (, ([] ,y)) x
90 |
91 | functionParser :: Parser [(String, ([String], String))]
92 | functionParser = do
93 | x <- some identifier
94 | _ <- constant ":"
95 | y <- sepBy identifier $ constant ","
96 | _ <- constant "->"
97 | z <- identifier
98 | return $ map (, (y, z)) x
99 |
100 | typesideLiteralSectionParser :: Parser X.TypesideRaw'
101 | typesideLiteralSectionParser = do
102 | i <- optional $ do
103 | _ <- constant "imports"
104 | many typesideExpParser
105 | t <- optional $ do
106 | _ <- constant "types"
107 | many identifier
108 | c <- optional $ do
109 | _ <- constant "constants"
110 | many constantParser
111 | f <- optional $ do
112 | _ <- constant "functions"
113 | many functionParser
114 | e <- optional $ do
115 | _ <- constant "equations"
116 | many eqParser
117 | o <- optional $ do
118 | _ <- constant "options"
119 | many optionParser
120 | pure $ TypesideRaw'
121 | (fromMaybe [] t)
122 | (concat (fromMaybe [] c) ++ concat (fromMaybe [] f))
123 | (fromMaybe [] e)
124 | (fromMaybe [] o)
125 | (fromMaybe [] i)
126 |
--------------------------------------------------------------------------------
/src/Language/CQL/Parser/Mapping.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | module Language.CQL.Parser.Mapping where
22 |
23 | import Language.CQL.Mapping
24 | import Language.CQL.Parser.LexerRules
25 | import Language.CQL.Parser.Parser
26 | import Language.CQL.Parser.Schema hiding (attParser, fkParser)
27 | import Language.CQL.Term
28 |
29 | -- megaparsec
30 | import Text.Megaparsec
31 |
32 | -- prelude
33 | import Data.Maybe
34 |
35 | --------------------------------------------------------------------------------
36 |
37 | fkParser :: Parser (String, [String])
38 | fkParser = do
39 | x <- identifier
40 | _ <- constant "->"
41 | y <- sepBy1 identifier $ constant "."
42 | return (x, y)
43 |
44 | attParser :: Parser (String, Either (String, Maybe String, RawTerm) [String])
45 | attParser = do
46 | x <- identifier
47 | _ <- constant "->"
48 | c1 x <|> c2 x
49 | where
50 | c1 x = do
51 | _ <- constant "lambda"
52 | y <- identifier
53 | z <- optional $ do
54 | _ <- constant ":"
55 | identifier
56 | _ <- constant "."
57 | e <- rawTermParser
58 | return (x, Left (y, z, e))
59 | c2 x = do
60 | y <- sepBy1 identifier $ constant "."
61 | return (x, Right y)
62 |
63 | mapCompParser :: Parser MappingExp
64 | mapCompParser = do
65 | _ <- constant "["
66 | f <- mapExpParser
67 | _ <- constant ";"
68 | g <- mapExpParser
69 | _ <- constant "]"
70 | return $ MappingComp f g
71 |
72 | mappingRawParser :: Parser MappingExpRaw'
73 | mappingRawParser = do
74 | _ <- constant "literal"
75 | _ <- constant ":"
76 | s <- schemaExpParser
77 | _ <- constant "->"
78 | t <- schemaExpParser
79 | braces $ q' s t
80 | where
81 | p = do
82 | x <- do
83 | _ <- constant "entity"
84 | v <- identifier
85 | _ <- constant "->"
86 | u <- identifier
87 | return (v, u)
88 | f <- optional $ do
89 | _ <- constant "foreign_keys"
90 | many fkParser
91 | a <- optional $ do
92 | _ <- constant "attributes"
93 | many attParser
94 | pure (x, fromMaybe [] f, fromMaybe [] a)
95 | q' s t = do
96 | i <- optional $ do
97 | _ <- constant "imports"
98 | many mapExpParser
99 | m <- many p
100 | o <- optional $ do
101 | _ <- constant "options"
102 | many optionParser
103 | pure $ q s t (fromMaybe [] o) (fromMaybe [] i) m
104 | q s t o i = Prelude.foldr
105 | (\(x,fm,am) (MappingExpRaw' s' t' ens' fks' atts' o' i') -> MappingExpRaw' s' t' (x:ens') (fm++fks') (am++atts') o' i')
106 | (MappingExpRaw' s t [] [] [] o i)
107 |
108 |
109 | mapExpParser :: Parser MappingExp
110 | mapExpParser
111 | = mapCompParser
112 | <|> MappingRaw <$> mappingRawParser
113 | <|> MappingVar <$> identifier
114 | <|> parens mapExpParser
115 | <|> do
116 | _ <- constant "identity"
117 | MappingId <$> schemaExpParser
118 |
119 |
--------------------------------------------------------------------------------
/src/Language/CQL/Instance/Presentation.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE AllowAmbiguousTypes #-}
22 | {-# LANGUAGE DataKinds #-}
23 | {-# LANGUAGE DuplicateRecordFields #-}
24 | {-# LANGUAGE ExplicitForAll #-}
25 | {-# LANGUAGE FlexibleContexts #-}
26 | {-# LANGUAGE FlexibleInstances #-}
27 | {-# LANGUAGE GADTs #-}
28 | {-# LANGUAGE KindSignatures #-}
29 | {-# LANGUAGE LiberalTypeSynonyms #-}
30 | {-# LANGUAGE MultiParamTypeClasses #-}
31 | {-# LANGUAGE RankNTypes #-}
32 | {-# LANGUAGE ScopedTypeVariables #-}
33 | {-# LANGUAGE StandaloneDeriving #-}
34 | {-# LANGUAGE TupleSections #-}
35 | {-# LANGUAGE TypeOperators #-}
36 | {-# LANGUAGE TypeSynonymInstances #-}
37 | {-# LANGUAGE UndecidableInstances #-}
38 |
39 | module Language.CQL.Instance.Presentation where
40 |
41 | import Control.DeepSeq (deepseq, NFData(..))
42 | import Data.Map.Strict (Map)
43 | import qualified Data.Map.Strict as Map
44 | import Data.Maybe ()
45 | import Data.Set (Set)
46 | import qualified Data.Set as Set
47 | import Data.Void
48 | import Language.CQL.Collage (Collage(..), typeOfCol)
49 | import Language.CQL.Common (Err, MultiTyMap, TyMap, type (+), section, sepTup, intercalate)
50 | import Language.CQL.Schema (Schema)
51 | import qualified Language.CQL.Schema as Schema (toCollage)
52 | import Language.CQL.Term as Term
53 | import Prelude hiding (EQ)
54 |
55 | -- | A presentation of an @Instance@.
56 | data Presentation var ty sym en fk att gen sk
57 | = Presentation
58 | { gens :: Map gen en
59 | , sks :: Map sk ty
60 | , eqs :: Set (EQ Void ty sym en fk att gen sk)
61 | }
62 |
63 | instance TyMap Show '[var, ty, sym, en, fk, att, gen, sk]
64 | => Show (Presentation var ty sym en fk att gen sk) where
65 | show (Presentation ens' _ eqs') =
66 | unlines
67 | [ section "generators" $ intercalate "\n" $ sepTup " : " <$> Map.toList ens'
68 | , section "equations" $ intercalate "\n" $ Set.map show eqs'
69 | ]
70 |
71 | instance (NFData ty, NFData sym, NFData en, NFData fk, NFData att, NFData gen, NFData sk)
72 | => NFData (Presentation var ty sym en fk att gen sk) where
73 | rnf (Presentation g s e) = deepseq g $ deepseq s $ rnf e
74 |
75 | -- | Checks that an instance presentation is a well-formed theory.
76 | typecheck
77 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
78 | => Schema var ty sym en fk att
79 | -> Presentation var ty sym en fk att gen sk
80 | -> Err ()
81 | typecheck sch p = typeOfCol $ toCollage sch p
82 |
83 | -- | Converts a presentation to a collage.
84 | toCollage
85 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
86 | => Schema var ty sym en fk att
87 | -> Presentation var ty sym en fk att gen sk
88 | -> Collage (()+var) ty sym en fk att gen sk
89 | toCollage sch (Presentation gens' sks' eqs') =
90 | Collage (Set.union e1 e2) (ctys schcol) (cens schcol) (csyms schcol) (cfks schcol) (catts schcol) gens' sks'
91 | where
92 | schcol = Schema.toCollage sch
93 | e1 = Set.map (\( EQ (l,r)) -> (Map.empty, EQ (upp l, upp r))) $ eqs'
94 | e2 = Set.map (\(g, EQ (l,r)) -> (g, EQ (upp l, upp r))) $ ceqs schcol
95 |
--------------------------------------------------------------------------------
/src/Language/CQL/Parser/Transform.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | module Language.CQL.Parser.Transform (transExpParser) where
22 |
23 | import Language.CQL.Instance
24 | import Language.CQL.Mapping
25 | import Language.CQL.Parser.Instance
26 | import Language.CQL.Parser.LexerRules
27 | import Language.CQL.Parser.Mapping
28 | import Language.CQL.Parser.Parser
29 | import Language.CQL.Term
30 | import Language.CQL.Transform
31 |
32 | -- prelude
33 | import Data.Maybe
34 |
35 | -- megaparsec
36 | import Text.Megaparsec
37 |
38 |
39 | gParser :: Parser (String, RawTerm)
40 | gParser = do
41 | x <- identifier
42 | _ <- constant "->"
43 | e <- rawTermParser
44 | return (x, e)
45 |
46 | transformRawParser :: Parser TransExpRaw'
47 | transformRawParser = do
48 | _ <- constant "literal"
49 | _ <- constant ":"
50 | s <- instExpParser
51 | _ <- constant "->"
52 | t <- instExpParser
53 | braces $ p s t
54 | where
55 | p s t = do
56 | i <- optional $ do
57 | _ <- constant "imports"
58 | many transExpParser
59 | e <- optional $ do
60 | _ <- constant "generators"
61 | many gParser
62 | x <- optional $ do
63 | _ <- constant "options"
64 | many optionParser
65 | pure $ TransExpRaw' s t
66 | (fromMaybe [] e)
67 | (fromMaybe [] x)
68 | (fromMaybe [] i)
69 |
70 | mapTransParser :: String -> (MappingExp -> TransformExp -> [(String, String)] -> TransformExp) -> Parser TransformExp
71 | mapTransParser s constructor = do
72 | _ <- constant s
73 | f <- mapExpParser
74 | i <- transExpParser
75 | o <- optional $ braces $ do { _ <- constant "options"; many optionParser }
76 | return $ constructor f i $ fromMaybe [] o
77 |
78 | mapInstTransParser :: String -> (MappingExp -> InstanceExp -> [(String, String)] -> TransformExp) -> Parser TransformExp
79 | mapInstTransParser s constructor = do
80 | _ <- constant s
81 | f <- mapExpParser
82 | i <- instExpParser
83 | o <- optional $ braces $ do { _ <- constant "options"; many optionParser }
84 | return $ constructor f i $ fromMaybe [] o
85 |
86 | sigmaParser' :: Parser TransformExp
87 | sigmaParser' = mapTransParser "sigma" TransformSigma
88 |
89 | sigmaDeltaUnitParser' :: Parser TransformExp
90 | sigmaDeltaUnitParser' = mapInstTransParser "unit" TransformSigmaDeltaUnit
91 |
92 | sigmaDeltaCoUnitParser' :: Parser TransformExp
93 | sigmaDeltaCoUnitParser' = mapInstTransParser "counit" TransformSigmaDeltaCoUnit
94 |
95 | deltaParser' :: Parser TransformExp
96 | deltaParser' = mapTransParser "delta" TransformDelta
97 |
98 | transCompParser :: Parser TransformExp
99 | transCompParser = do
100 | _ <- constant "["
101 | f <- transExpParser
102 | _ <- constant ";"
103 | g <- transExpParser
104 | _ <- constant "]"
105 | return $ TransformComp f g
106 |
107 | transExpParser :: Parser TransformExp
108 | transExpParser = transCompParser
109 | <|> TransformRaw <$> transformRawParser
110 | <|> TransformVar <$> identifier
111 | <|> sigmaParser'
112 | <|> deltaParser'
113 | <|> sigmaDeltaUnitParser'
114 | <|> sigmaDeltaCoUnitParser'
115 | <|> parens transExpParser
116 | <|> do
117 | _ <- constant "identity"
118 | TransformId <$> instExpParser
119 |
120 |
--------------------------------------------------------------------------------
/src/Language/CQL/Parser/Parser.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | module Language.CQL.Parser.Parser where
22 |
23 | import Language.CQL.Parser.LexerRules
24 | import Language.CQL.Parser.ReservedWords
25 |
26 | -- base
27 | import Data.Char
28 | import Data.Functor (($>), (<$))
29 |
30 | -- megaparsec
31 | import Text.Megaparsec
32 | import Text.Megaparsec.Char
33 | import qualified Text.Megaparsec.Char.Lexer as L
34 |
35 | -- scientific
36 | import Data.Scientific (Scientific)
37 | import Language.CQL.Term
38 |
39 | rawTermParser :: Parser RawTerm
40 | rawTermParser =
41 | try (do
42 | f <- identifier
43 | _ <- constant "("
44 | a <- sepBy rawTermParser $ constant ","
45 | _ <- constant ")"
46 | return $ RawApp f a)
47 | <|> try (do
48 | t <- sepBy1 identifier $ constant "."
49 | return $ Prelude.foldl (\y x -> RawApp x [y]) (RawApp (head t) []) $ tail t)
50 | <|> try (do
51 | i <- identifier
52 | return $ RawApp i [])
53 | <|> try (do
54 | _ <- constant "("
55 | a <- rawTermParser
56 | f <- identifier
57 | b <- rawTermParser
58 | _ <- constant ")"
59 | return $ RawApp f [a, b])
60 |
61 | optionParser :: Parser (String, String)
62 | optionParser = do
63 | i <- identifier
64 | _ <- constant "="
65 | j <- identifier
66 | return (i, j)
67 |
68 | identifier :: Parser String
69 | identifier = (lexeme . try) (p >>= check)
70 | where
71 | unquotedIdentifier = lowerId <|> upperId <|> specialId
72 | quotedIdentifier = between (char '"') (char '"') $ some $ satisfy (\c -> isPrint c && (c /= '"'))
73 | p = unquotedIdentifier <|> quotedIdentifier
74 | check x =
75 | if x `elem` reservedWords
76 | then fail $ "keyword" ++ show x ++ "cannot be used as an identifier"
77 | else return x
78 |
79 | constant :: String -> Parser String
80 | constant = L.symbol spaceConsumer
81 |
82 | braces :: Parser a -> Parser a
83 | braces = between (constant "{") (constant "}")
84 |
85 | parens :: Parser a -> Parser a
86 | parens = between (constant "(") (constant ")")
87 |
88 | integerParser :: Parser Integer
89 | integerParser = lexeme L.decimal
90 |
91 | scientificParser :: Parser Scientific
92 | scientificParser = lexeme L.scientific
93 |
94 | boolParser :: Parser Bool
95 | boolParser
96 | = True <$ constant "true"
97 | <|> False <$ constant "false"
98 |
99 | textParser :: Parser String
100 | textParser = do
101 | _ <- constant "\""
102 | text <- many (escapeSeq <|> show <$> noneOf ['"', '\r', '\n', '\\']) -- TODO: check if the escaping is correct
103 | _ <- constant "\""
104 | pure $ unwords text
105 |
106 | escapeSeq :: Parser String
107 | escapeSeq = do
108 | _ <- char '\\'
109 | show <$> oneOf ['b', 't', 'n', 'f', 'r', '"', '\'', '\\', '.']
110 | <|> unicodeEsc
111 | <|> eof $> ""
112 |
113 | unicodeEsc :: Parser String -- TODO: write tests
114 | unicodeEsc
115 | = char 'u' $> "u"
116 | <|> (:)
117 | <$> char 'u'
118 | <*> (show <$> hexDigitChar)
119 | <|> (:)
120 | <$> char 'u'
121 | <*> ((:) <$> hexDigitChar <*> (show <$> hexDigitChar))
122 | <|> (:)
123 | <$> char 'u'
124 | <*> ((:)
125 | <$> hexDigitChar
126 | <*> ((:) <$> hexDigitChar <*> (show <$> hexDigitChar)))
127 |
--------------------------------------------------------------------------------
/src/Language/CQL/Parser/Instance.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE TupleSections #-}
22 |
23 | module Language.CQL.Parser.Instance where
24 |
25 | import Language.CQL.Instance as I
26 | import Language.CQL.Mapping
27 | import Language.CQL.Parser.LexerRules
28 | import Language.CQL.Parser.Mapping as M
29 | import Language.CQL.Parser.Parser
30 | import Language.CQL.Parser.Schema
31 | import Language.CQL.Schema as S
32 | import Language.CQL.Term
33 |
34 | -- base
35 | import Data.Maybe
36 |
37 | -- megaparsec
38 | import Text.Megaparsec
39 |
40 | eqParser :: Parser (RawTerm, RawTerm)
41 | eqParser = do
42 | l <- rawTermParser
43 | _ <- constant "="
44 | r <- rawTermParser
45 | return (l, r)
46 |
47 | eqParser2 :: Parser [(RawTerm, RawTerm)]
48 | eqParser2 = do
49 | r <- many p'
50 | return $ concat r
51 | where
52 | p = do
53 | p1 <- rawTermParser
54 | p2 <- rawTermParser
55 | return (p1, p2)
56 | p' = do
57 | l <- identifier
58 | _ <- constant "-> {"
59 | m <- sepBy p $ constant ","
60 | _ <- constant "}"
61 | return $ map (\(x, y) -> (RawApp l [x], y)) m
62 |
63 | skParser :: Parser [(Gen, En)]
64 | skParser = genParser
65 |
66 | genParser :: Parser [(Gen, En)]
67 | genParser = do
68 | x <- some identifier
69 | _ <- constant ":"
70 | y <- identifier
71 | return $ map (, y) x
72 |
73 | mapInstParser :: String -> (MappingExp -> InstanceExp -> [(String, String)] -> InstanceExp) -> Parser InstanceExp
74 | mapInstParser s constructor = do
75 | _ <- constant s
76 | f <- mapExpParser
77 | i <- instExpParser
78 | o <- optional $ braces $ do { _ <- constant "options"; many optionParser }
79 | return $ constructor f i $ fromMaybe [] o
80 |
81 | sigmaParser :: Parser InstanceExp
82 | sigmaParser = mapInstParser "sigma" InstanceSigma
83 |
84 | deltaParser :: Parser InstanceExp
85 | deltaParser = mapInstParser "delta" InstanceDelta
86 |
87 | instRawParser :: Parser InstExpRaw'
88 | instRawParser = do
89 | _ <- constant "literal"
90 | _ <- constant ":"
91 | t <- schemaExpParser
92 | braces $ p t
93 | where
94 | p t = do
95 | i <- optional $ do
96 | _ <- constant "imports"
97 | many instExpParser
98 | e <- optional $ do
99 | _ <- constant "generators"
100 | y <- many genParser
101 | return $ concat y
102 | o <- optional $ do
103 | _ <- constant "equations"
104 | many eqParser
105 | o2 <- optional $ do
106 | _ <- constant "multi_equations"
107 | eqParser2
108 | x <- optional $ do
109 | _ <- constant "options"
110 | many optionParser
111 | pure $ InstExpRaw' t
112 | (fromMaybe [] e)
113 | (fromMaybe [] o ++ fromMaybe [] o2)
114 | (fromMaybe [] x)
115 | (fromMaybe [] i)
116 |
117 | instExpParser :: Parser InstanceExp
118 | instExpParser
119 | = InstanceRaw <$> instRawParser
120 | <|> InstanceVar <$> identifier
121 | <|> InstancePivot <$> (constant "pivot" *> instExpParser)
122 | <|> sigmaParser
123 | <|> deltaParser
124 | <|> do
125 | _ <- constant "empty"
126 | _ <- constant ":"
127 | InstanceInitial <$> schemaExpParser
128 | <|> parens instExpParser
129 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # CQL
2 |
3 | [](https://travis-ci.com/statebox/cql)
4 | [](https://www.gnu.org/licenses/agpl-3.0)
5 |
6 | Categorical Query Language (CQL) implementation in Haskell.
7 |
8 |
9 | ## About
10 |
11 | [CQL](https://www.categoricaldata.net) is a functional query language that allows you to specify data migrations declaratively, in a way that guarantees their correctness.
12 |
13 | It is the culmination of years of original mathematical [research](https://www.categoricaldata.net/papers) after the right balance between flexibility and correctness. Its solid grounding in category theory sets it apart from its ad hoc counterparts, and enables the compositional development and analysis of data transformations to a degree previously impossible.
14 |
15 | CQL, formerly known as AQL, was developed by [Statebox](https://www.statebox.org) in collaboration with [Conexus](http://conexus.ai/), who develop the [Java version](https://github.com/CategoricalData/cql) of CQL.
16 |
17 | [Learn more](https://www.categoricaldata.net).
18 |
19 | ## Example
20 |
21 | After building, you can use `cql` to evaluate a `.cql` file, e.g.
22 |
23 | ```sh
24 | # build it
25 | stack build
26 |
27 | # run `cql` on `examples/Employee.cql`
28 | stack exec cql examples/Employee.cql
29 | ```
30 |
31 | Here is an example of what a `.cql` file looks like:
32 |
33 | ```
34 | options
35 | program_allow_nontermination_unsafe = true
36 | allow_empty_sorts_unsafe = true
37 |
38 | typeside T = literal {
39 | types
40 | string
41 | nat
42 |
43 | constants
44 | Al Akin Bob Bo Carl Cork Dan Dunn Math CS : string
45 | zero : nat
46 |
47 | functions
48 | succ : nat -> nat
49 | plus : nat, nat -> nat
50 | }
51 |
52 | schema S = literal : T {
53 | entities
54 | Employee
55 | Department
56 |
57 | foreign_keys
58 | manager : Employee -> Employee
59 | worksIn : Employee -> Department
60 | secretary : Department -> Employee
61 |
62 | attributes
63 | first last : Employee -> string
64 | age : Employee -> nat
65 | name : Department -> string
66 | }
67 |
68 | instance I = literal : S {
69 | generators
70 | a b : Employee
71 |
72 | equations
73 | a.manager = a
74 | a.worksIn.secretary = a
75 | b.manager = a
76 | b.worksIn = a.worksIn
77 | last(b) = Bo
78 |
79 | multi_equations
80 | first -> {a Al, b Bob}
81 | }
82 |
83 | instance J = literal : S {
84 | generators
85 | a b : Employee
86 | c d : Department
87 | y : nat
88 |
89 | equations
90 | a.manager = a
91 | a.worksIn = d
92 | c.secretary = b
93 | b.manager = a
94 | b.worksIn = c
95 | d.secretary = b
96 | first(a) = Al
97 | a.last = Al
98 | d.name = Bob
99 | c.name = Al
100 | age(a) = zero
101 | age(b) = y
102 |
103 | options interpret_as_algebra = true
104 | }
105 | ```
106 |
107 | ## Building
108 |
109 | The package can be built/tested/installed the following ways.
110 |
111 | ### Stack
112 |
113 | Build:
114 |
115 | `stack build`
116 |
117 | Test:
118 |
119 | `stack test`
120 |
121 | Install:
122 |
123 | `stack install`
124 |
125 | Generate docs:
126 |
127 | `stack haddock cql`
128 |
129 | ### Cabal
130 |
131 | Generate `.cabal` file:
132 |
133 | `hpack`
134 |
135 | Build:
136 |
137 | `cabal build`
138 |
139 | Test:
140 |
141 | `cabal test`
142 |
143 | Install:
144 |
145 | `cabal install`
146 |
147 | ### Nix
148 |
149 | Build & test:
150 |
151 | `nix-build`
152 |
153 | Install in current profile:
154 |
155 | `nix-env -f . -i`
156 |
157 | See also [default.nix](default.nix)
158 |
159 | ## HTTP API
160 |
161 | To launch the APIs, use `stack exec cql-http`. Then you can send http requests to port 8080, with an CQL specification in the body. The `Content-Type` of the request needs to be set to `text/plain;charset=utf-8`
162 |
163 | For example, you could try using `cURL` as follows
164 |
165 | ```
166 | curl -X POST \
167 | http://localhost:8080/cql \
168 | -H 'Content-Type: text/plain;charset=utf-8' \
169 | --data-binary "@./examples/Employee.cql"
170 | ```
171 |
172 | You can set the following environment variables to customise the behaviour of the endpoint:
173 |
174 | - `CQL_ENV`: Should be `Development` or `Production`. Regulates the verbosity of the console output.
175 |
176 | - `PORT`: determines on which port the endpoint is exposed
177 |
178 | ### License
179 |
180 | Unless explicitly stated otherwise all files in this repository are licensed under the GNU Affero General Public License.
181 |
182 | Copyright © 2019 [Stichting Statebox](https://statebox.nl).
183 |
--------------------------------------------------------------------------------
/src/Language/CQL/Program.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE AllowAmbiguousTypes #-}
22 | {-# LANGUAGE DataKinds #-}
23 | {-# LANGUAGE DuplicateRecordFields #-}
24 | {-# LANGUAGE ExplicitForAll #-}
25 | {-# LANGUAGE FlexibleContexts #-}
26 | {-# LANGUAGE FlexibleInstances #-}
27 | {-# LANGUAGE GADTs #-}
28 | {-# LANGUAGE ImpredicativeTypes #-}
29 | {-# LANGUAGE InstanceSigs #-}
30 | {-# LANGUAGE LiberalTypeSynonyms #-}
31 | {-# LANGUAGE MultiParamTypeClasses #-}
32 | {-# LANGUAGE RankNTypes #-}
33 | {-# LANGUAGE ScopedTypeVariables #-}
34 | {-# LANGUAGE TupleSections #-}
35 | {-# LANGUAGE TypeOperators #-}
36 | {-# LANGUAGE TypeSynonymInstances #-}
37 | {-# LANGUAGE UndecidableInstances #-}
38 |
39 | module Language.CQL.Program where
40 |
41 | import Control.DeepSeq
42 | import Data.Map.Strict as Map
43 | import Language.CQL.Common (section, TyMap, Kind(..))
44 | import Language.CQL.Instance as I
45 | import Language.CQL.Mapping as M
46 | import Language.CQL.Query as Q
47 | import Language.CQL.Schema as S
48 | import Language.CQL.Term as Term
49 | import Language.CQL.Transform as Tr
50 | import Language.CQL.Typeside as T
51 | import Prelude hiding (EQ)
52 |
53 | -- | Top level CQL expressions, untyped.
54 | data Exp
55 | = ExpTy TypesideExp
56 | | ExpS SchemaExp
57 | | ExpI InstanceExp
58 | | ExpM MappingExp
59 | | ExpT TransformExp
60 | | ExpQ QueryExp
61 |
62 | -- | Top level CQL expressions, dynamically typed.
63 | data Val
64 | = ValTy TypesideEx
65 | | ValS SchemaEx
66 | | ValI InstanceEx
67 | | ValM MappingEx
68 | | ValT TransformEx
69 | | ValQ QueryEx
70 | deriving Show
71 |
72 | instance NFData Val where
73 | rnf v = case v of
74 | ValTy x -> rnf x
75 | ValS x -> rnf x
76 | ValI x -> rnf x
77 | ValM x -> rnf x
78 | ValT x -> rnf x
79 | ValQ x -> rnf x
80 |
81 | -- | Isomorphic to @Ctx (String + ... + String) (ts + ... + t)@.
82 | data KindCtx ts s i m q t o
83 | = KindCtx
84 | { typesides :: Ctx String ts
85 | , schemas :: Ctx String s
86 | , instances :: Ctx String i
87 | , mappings :: Ctx String m
88 | , queries :: Ctx String q
89 | , transforms :: Ctx String t
90 | , other :: o
91 | }
92 |
93 | -- | A CQL program.
94 | type Prog = KindCtx TypesideExp SchemaExp InstanceExp MappingExp QueryExp TransformExp [(String, String)]
95 |
96 | newProg :: KindCtx ts s i m q t [a]
97 | newProg = newEnv []
98 |
99 | -- | The result of an CQL type checking pass.
100 | type Types = KindCtx TypesideExp TypesideExp SchemaExp (SchemaExp,SchemaExp) (SchemaExp,SchemaExp) (InstanceExp,InstanceExp) ()
101 |
102 | newTypes :: KindCtx ts s i m q t ()
103 | newTypes = newEnv ()
104 |
105 | newEnv :: o -> KindCtx ts s i m q t o
106 | newEnv = KindCtx m m m m m m
107 | where m = Map.empty
108 |
109 | instance TyMap Show '[ts, s, i, m, q, t, o] => Show (KindCtx ts s i m q t o) where
110 | show (KindCtx ts s i m q t o) =
111 | section "program" $ unlines
112 | [ section "typesides" $ showCtx ts
113 | , section "schemas" $ showCtx s
114 | , section "instances" $ showCtx i
115 | , section "mappings" $ showCtx m
116 | , section "queries" $ showCtx q
117 | , section "transforms" $ showCtx t
118 | , section "other" $ show o
119 | ]
120 | where
121 | showCtx :: (Show a1, Show a2) => Map a1 a2 -> String
122 | showCtx m = unlines $ (\(k,v) -> show k ++ " = " ++ show v ++ "\n") <$> Map.toList m
123 |
124 | allVars :: KindCtx ts s i m q t o -> [(String, Kind)]
125 | allVars ctx =
126 | (fmap (, TYPESIDE ) . keys . typesides $ ctx) <>
127 | (fmap (, SCHEMA ) . keys . schemas $ ctx) <>
128 | (fmap (, INSTANCE ) . keys . instances $ ctx) <>
129 | (fmap (, MAPPING ) . keys . mappings $ ctx) <>
130 | (fmap (, QUERY ) . keys . queries $ ctx) <>
131 | (fmap (, TRANSFORM) . keys . transforms $ ctx)
132 |
--------------------------------------------------------------------------------
/src/Language/CQL/Query.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE AllowAmbiguousTypes #-}
22 | {-# LANGUAGE DataKinds #-}
23 | {-# LANGUAGE DuplicateRecordFields #-}
24 | {-# LANGUAGE ExplicitForAll #-}
25 | {-# LANGUAGE FlexibleContexts #-}
26 | {-# LANGUAGE FlexibleInstances #-}
27 | {-# LANGUAGE GADTs #-}
28 | {-# LANGUAGE ImpredicativeTypes #-}
29 | {-# LANGUAGE InstanceSigs #-}
30 | {-# LANGUAGE KindSignatures #-}
31 | {-# LANGUAGE LiberalTypeSynonyms #-}
32 | {-# LANGUAGE MultiParamTypeClasses #-}
33 | {-# LANGUAGE RankNTypes #-}
34 | {-# LANGUAGE ScopedTypeVariables #-}
35 | {-# LANGUAGE StandaloneDeriving #-}
36 | {-# LANGUAGE TypeOperators #-}
37 | {-# LANGUAGE TypeSynonymInstances #-}
38 | {-# LANGUAGE UndecidableInstances #-}
39 |
40 | module Language.CQL.Query where
41 | import Control.DeepSeq
42 | import Data.Map.Strict as Map
43 | import Data.Set as Set
44 | import Data.Typeable
45 | import Data.Void
46 | import Language.CQL.Common
47 | import Language.CQL.Schema
48 | import Language.CQL.Term
49 | import Prelude hiding (EQ)
50 |
51 | data Query var ty sym en fk att en' fk' att'
52 | = Query
53 | { srcQ :: Schema var ty sym en fk att
54 | , dstQ :: Schema var ty sym en' fk' att'
55 |
56 | , ens :: Map en' (Ctx var en, Set (EQ var ty sym en fk att Void Void))
57 | , fks :: Map fk' (Ctx var (Term var Void Void en fk Void Void Void))
58 | , atts :: Map att' (Term var ty sym en fk att Void Void)
59 | }
60 |
61 | instance TyMap Show '[var, ty, sym, en, fk, att, en', fk', att']
62 | => Show (Query var ty sym en fk att en' fk' att') where
63 | show (Query _ _ ens' fks' atts') =
64 | "ens = " ++ show ens' ++
65 | "\nfks = " ++ show fks' ++
66 | "\natts = " ++ show atts'
67 |
68 | instance TyMap Eq '[var, ty, sym, en, fk, att, en', fk', att']
69 | => Eq (Query var ty sym en fk att en' fk' att') where
70 | (==) (Query s1' s2' ens' fks' atts') (Query s1'' s2'' ens'' fks'' atts'')
71 | = (s1' == s1'') && (s2' == s2'') && (ens' == ens'') && (fks' == fks'') && (atts' == atts'')
72 |
73 | instance (NFData var, NFData ty, NFData sym, NFData en, NFData fk, NFData att, NFData en', NFData fk', NFData att')
74 | => NFData (Query var ty sym en fk att en' fk' att') where
75 | rnf (Query s t e f a) = deepseq s $ deepseq t $ deepseq e $ deepseq f $ rnf a
76 |
77 | data QueryEx :: * where
78 | QueryEx
79 | :: forall var ty sym en fk att en' fk' att'
80 | . (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym, en, fk, att, en', fk', att'])
81 | => Query var ty sym en fk att en' fk' att' -> QueryEx
82 |
83 | instance NFData QueryEx where
84 | rnf (QueryEx x) = rnf x
85 |
86 | deriving instance Show QueryEx
87 |
88 | data QueryExp where
89 | QueryVar :: String -> QueryExp
90 | QueryId :: SchemaExp -> QueryExp
91 | QueryRaw :: QueryExpRaw' -> QueryExp
92 | deriving (Eq)
93 |
94 | instance Show QueryExp where
95 | show _ = error "todo"
96 |
97 | instance Deps QueryExp where
98 | deps x = case x of
99 | QueryVar v -> [(v, QUERY)]
100 | QueryId s -> deps s
101 | QueryRaw (QueryExpRaw' s t _ _ _ _ i) -> deps s ++ deps t ++ concatMap deps i
102 |
103 | getOptionsQuery :: QueryExp -> [(String, String)]
104 | getOptionsQuery x = case x of
105 | QueryVar _ -> []
106 | QueryId _ -> []
107 | QueryRaw (QueryExpRaw' _ _ _ _ _ o _) -> o
108 |
109 | --old school queries without overlapping names across entities
110 | data QueryExpRaw' = QueryExpRaw'
111 | { qraw_src :: SchemaExp
112 | , qraw_dst :: SchemaExp
113 | , qraw_ens :: [(String, ([(String,String)],[(RawTerm,RawTerm)]))]
114 | , qraw_fks :: [(String, [(String,RawTerm)])]
115 | , qraw_atts :: [(String, RawTerm)]
116 | , qraw_options :: [(String, String)]
117 | , qraw_imports :: [QueryExp]
118 | } deriving (Eq, Show)
119 |
120 | typecheckQuery
121 | :: Query var ty sym en fk att en' fk' att'
122 | -> Err ()
123 | typecheckQuery = undefined
124 |
125 | --------------------------------------------------------------------------------
126 |
--------------------------------------------------------------------------------
/src/Language/CQL/Congruence.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE FlexibleContexts, OverloadedLists, OverloadedStrings, TupleSections #-}
22 | module Language.CQL.Congruence (decide, Term(Function)) where
23 |
24 | import Prelude hiding (any)
25 |
26 | import Control.Monad hiding (unless)
27 | import Control.Monad.Trans.UnionFind (runUnionFind,UnionFindT)
28 | --import qualified Control.Monad.Trans.UnionFind as U
29 | --import Control.Monad.Writer hiding (unless)
30 |
31 | --import Data.Sequence (Seq)
32 | import Data.Foldable (traverse_)
33 | --import Data.Text (Text)
34 | --import qualified Data.Map as M
35 | import Data.Graph.Inductive (LNode)
36 | import Data.Functor.Identity
37 |
38 | import Language.CQL.Internal
39 |
40 |
41 | decide :: Ord t => [(Term t, Term t)] -> Term t -> Term t -> Bool
42 | decide theory lhs rhs = not result
43 | where
44 | conjunctions = fmap (uncurry Equal) theory
45 | Identity result = hasModel (Conjunction $ NotEqual lhs rhs : conjunctions)
46 |
47 |
48 | hasModel :: Ord t => Monad m => Conjunctions t -> m Bool
49 | hasModel (Conjunction conjunctions) = runUnionFind $ do
50 | gr <- termGraph conjunctions
51 | let (pos,neg) = partition gr positive conjunctions
52 | traverse_ (merge gr) pos
53 |
54 | anyEquiv <- any equivalent neg
55 | pure $ not anyEquiv
56 |
57 |
58 | merge :: Monad m => Graph t -> (Vert t, Vert t) -> UnionFindT (LNode t) m ()
59 | merge gr (u,v) =
60 | unless (equivalent u v) $ do
61 | pu <- predOfAllVertEquivTo u
62 | pv <- predOfAllVertEquivTo v
63 | u `union` v
64 | needMerging <- filterM (notEquivalentButCongruent gr)
65 | [ (x,y) | x <- pu, y <- pv ]
66 | traverse_ (merge gr) needMerging
67 | where
68 | predOfAllVertEquivTo vert =
69 | concatMap (predecessors gr) <$> filterM (equivalent vert) (vertices gr)
70 |
71 | notEquivalentButCongruent :: (Monad m) => Graph t -> (Vert t, Vert t) -> UnionFindT (LNode t) m Bool
72 | notEquivalentButCongruent gr (x,y) = do
73 | notEquiv <- not <$> equivalent x y
74 | cong <- congruent gr x y
75 | return $ notEquiv && cong
76 |
77 | -- testing
78 | congruent :: (Monad m) => Graph t -> Vert t -> Vert t -> UnionFindT (LNode t) m Bool
79 | congruent gr x y =
80 | if outDegree gr x /= outDegree gr y
81 | then return False
82 | else and <$> zipWithM equivalent (successors gr x) (successors gr y)
83 |
84 | {--
85 | constructModel :: Monad m => Graph -> UnionFindT (LNode Text) m Satisfiability
86 | constructModel g@(Graph (_,gr)) = do
87 | psi <- forM (labNodes gr) $ \v@(_,(_,vp)) -> do
88 | rp <- U.repr vp
89 | (rn,rt) <- U.descriptor rp
90 | return (term g (Vert v), term g (Vert (rn,(rt,rp))))
91 | return $ Satisfiable (M.fromList psi)
92 | --}
93 |
94 | {--
95 |
96 | Copyright (c) 2014, Sven Keidel
97 |
98 | All rights reserved.
99 |
100 | Redistribution and use in source and binary forms, with or without
101 | modification, are permitted provided that the following conditions are met:
102 |
103 | * Redistributions of source code must retain the above copyright
104 | notice, this list of conditions and the following disclaimer.
105 |
106 | * Redistributions in binary form must reproduce the above
107 | copyright notice, this list of conditions and the following
108 | disclaimer in the documentation and/or other materials provided
109 | with the distribution.
110 |
111 | * Neither the name of Sven Keidel nor the names of other
112 | contributors may be used to endorse or promote products derived
113 | from this software without specific prior written permission.
114 |
115 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
116 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
117 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
118 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
119 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
120 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
121 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
122 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
123 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
124 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
125 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
126 |
127 | --}
128 |
129 |
--------------------------------------------------------------------------------
/test/CQLSpec.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE OverloadedStrings #-}
22 |
23 | module CQLSpec where
24 |
25 | import Language.CQL
26 | import Language.CQL.Schema
27 | import Language.CQL.Term
28 | import Language.CQL.Typeside
29 |
30 | -- base
31 | import Data.Either (isRight)
32 | import Data.Map.Strict as Map
33 | import Data.Set as Set
34 | import Prelude hiding (EQ)
35 |
36 | -- hspec
37 | import Test.Hspec
38 |
39 | -- transformers
40 | import Control.Monad.IO.Class (liftIO)
41 |
42 |
43 | spec :: Spec
44 | spec = do
45 | it "processes correctly the example file Mapping.cql" $ do
46 | fileContent <- liftIO $ readFile ("examples/Mapping.cql" :: String)
47 | parsed <- pure $ runProg fileContent
48 | isRight parsed `shouldBe` True
49 | it "processes correctly the example file Employee.cql" $ do
50 | fileContent <- liftIO $ readFile ("examples/Employee.cql" :: String)
51 | parsed <- pure $ runProg fileContent
52 | isRight parsed `shouldBe` True
53 | it "processes correctly the example file Sigma.cql" $ do
54 | fileContent <- liftIO $ readFile ("examples/Sigma.cql" :: String)
55 | parsed <- pure $ runProg fileContent
56 | isRight parsed `shouldBe` True
57 | it "processes correctly the example file Delta.cql" $ do
58 | fileContent <- liftIO $ readFile ("examples/Delta.cql" :: String)
59 | parsed <- pure $ runProg fileContent
60 | isRight parsed `shouldBe` True
61 | it "processes correctly the example file Import.cql" $ do
62 | fileContent <- liftIO $ readFile ("examples/Import.cql" :: String)
63 | parsed <- pure $ runProg fileContent
64 | isRight parsed `shouldBe` True
65 | it "processes correctly the example file Congruence.cql" $ do
66 | fileContent <- liftIO $ readFile ("examples/Congruence.cql" :: String)
67 | parsed <- pure $ runProg fileContent
68 | isRight parsed `shouldBe` True
69 | it "processes correctly the example file KB.cql" $ do
70 | fileContent <- liftIO $ readFile ("examples/KB.cql" :: String)
71 | parsed <- pure $ runProg fileContent
72 | isRight parsed `shouldBe` True
73 | -- it "processes correctly the example file Petri.cql" $ do
74 | -- fileContent <- liftIO $ readFile ("examples/Petri.cql" :: String)
75 | -- parsed <- pure $ runProg fileContent
76 | -- isRight parsed `shouldBe` True
77 | -- print typesideDom
78 | -- print schemaOne
79 | -- print schemaTwo
80 | -- print mappingTwoToOne
81 | -- print instanceOne
82 |
83 | --------------------------------------------------------------------------------
84 |
85 | schemaOne :: (Eq var, Eq fk) => Schema var String String String fk String
86 | schemaOne =
87 | Schema typesideDom (Set.singleton "A") Map.empty atts' Set.empty Set.empty (\_ (EQ (lhs, rhs)) -> lhs == rhs)
88 | where
89 | atts' = Map.fromList [ ("A_att", ("A", "Dom")) ]
90 |
91 | schemaTwo :: Eq var => Schema var String String String String String
92 | schemaTwo =
93 | Schema typesideDom (Set.fromList ["A", "B"]) atts' atts'' Set.empty Set.empty (\_ (EQ (lhs, rhs)) -> lhs == rhs)
94 | where
95 | atts' = Map.fromList [ ("f" , ("A", "B" )) ]
96 | atts'' = Map.fromList [ ("A_att", ("A", "Dom"))
97 | , ("B_att", ("B", "Dom"))
98 | ]
99 |
100 | --example typeside one sort Dom { c0 ,..., c100 }
101 | typesideDom :: Eq var => Typeside var String String
102 | typesideDom = Typeside (Set.singleton "Dom") sym Set.empty (\_ (EQ (lhs,rhs)) -> lhs == rhs)
103 | where sym = sym' 100
104 |
105 | sym' :: Integer -> Map String ([String], String)
106 | sym' 0 = Map.empty
107 | sym' n = Map.insert ("c" ++ show n) ([], "Dom") $ sym' (n-1)
108 |
109 | --------------------------------------------------------------------------------
110 |
111 | -- instanceOne = Instance schemaOne
112 | -- (Map.insert "g1" "A" Map.empty) Map.empty Set.empty (\(EQ (lhs,rhs)) -> lhs == rhs)
113 | -- $ Algebra schemaOne (Map.fromList [("A", Set.singleton "x")])
114 | -- (Map.empty) (Map.fromList [("A_att", Map.fromList [("x",Sym "c42" [])])])
115 | -- (\t -> "x") (\t -> Gen "g1") (\t -> Sym "c42" []) (\t -> Sym "c42" [])
116 |
117 | --------------------------------------------------------------------------------
118 |
119 | -- mappingTwoToOne = Mapping schemaTwo schemaOne
120 | -- (Map.fromList [("B", "A"), ("A","A")])
121 | -- (Map.fromList [("f", Var ())])
122 | -- (Map.fromList [("A_att", Att "att" (Var ())), ("B_att", Att "att" (Var ()))])
123 |
--------------------------------------------------------------------------------
/src/Language/CQL/Options.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE EmptyDataDeriving #-}
22 |
23 | module Language.CQL.Options where
24 |
25 | import Data.Void
26 | import Language.CQL.Common (Err, intercalate, lower)
27 | import Text.Read
28 |
29 | data Options = Options {
30 | iOps :: IntOption -> Integer,
31 | bOps :: BoolOption -> Bool,
32 | sOps :: StringOption -> String
33 | -- cOps :: Map CharOption Char -- not needed for now
34 | }
35 |
36 | instance Show Options where
37 | show y = intercalate "\n" (map (\x -> show x ++ " = " ++ show (iOps y x)) opsI) ++ "\n" ++
38 | intercalate "\n" (map (\x -> show x ++ " = " ++ show (bOps y x)) opsB) ++ "\n" ++
39 | intercalate "\n" (map (\x -> show x ++ " = " ++ (sOps y x)) opsS)
40 |
41 | toOptions :: Options -> [(String, String)] -> Err Options
42 | toOptions o [] = return o
43 | toOptions def ((k,v):l) = do
44 | Options s t u <- toOptions def l
45 | case a of
46 | Left _ -> case b of
47 | Left _ -> do { (o, i) <- c ; return $ Options s t (f o i u) }
48 | Right (o, i) -> return $ Options s (f o i t) u
49 | Right (o, i) -> return $ Options (f o i s) t u
50 | where
51 | a = toIntegerOption (k, v)
52 | b = toBoolOption (k, v)
53 | c = toStringOption (k, v)
54 | f j u m x = if j == x then u else m x
55 |
56 |
57 | toIntegerOption :: (String, String) -> Err (IntOption, Integer)
58 | toIntegerOption (k, v) = case matches of
59 | [] -> Left $ "No option called " ++ k
60 | (x:_) -> do { a <- parseInt v ; return (x, a) }
61 | where
62 | matches = [ k' | k' <- opsI, lower (show k') == k ]
63 | parseInt :: String -> Err Integer
64 | parseInt x = case readMaybe x of
65 | Nothing -> Left $ "Not an int: " ++ x
66 | Just y -> Right y
67 |
68 |
69 | toStringOption :: (String, String) -> Err (StringOption, String)
70 | toStringOption (k,v) = case matches of
71 | [] -> Left $ "No option called " ++ k
72 | (x:_) -> return (x, v)
73 | where
74 | matches = [ k' | k' <- opsS, lower (show k') == k ]
75 |
76 |
77 | toBoolOption :: (String, String) -> Err (BoolOption, Bool)
78 | toBoolOption (k,v) = case matches of
79 | [] -> Left $ "No option called " ++ k
80 | (x:_) -> do { a <- parseBool v ; return (x, a) }
81 | where
82 | matches = [ k' | k' <- opsB, lower (show k') == k ]
83 | parseBool z = case z of
84 | "true" -> Right True
85 | "false" -> Right False
86 | x -> Left $ "Not a bool: " ++ x
87 |
88 | -- | Default values for Boolean options.
89 | boolDef :: BoolOption -> Bool
90 | boolDef o = case o of
91 | Program_Allow_Nontermination_Unsafe -> False
92 | Allow_Empty_Sorts_Unsafe -> False
93 | Program_Allow_Nonconfluence_Unsafe -> False
94 | Dont_Validate_Unsafe -> False
95 | Interpret_As_Algebra -> False
96 | Require_Consistency -> True
97 |
98 | -- | Default values for Integer options.
99 | intDef :: IntOption -> Integer
100 | intDef o = case o of
101 | Timeout -> 30
102 |
103 | -- | Default values for String options.
104 | stringDef :: StringOption -> String
105 | stringDef o = case o of
106 | Prover -> "auto"
107 |
108 | -- | Default options.
109 | defaultOptions :: Options
110 | defaultOptions = Options intDef boolDef stringDef
111 |
112 | -- | Returns a list of all enums in a given class.
113 | generateEnumValues :: (Enum a) => [a]
114 | generateEnumValues = enumFrom (toEnum 0)
115 |
116 | -- | All the Boolean options.
117 | opsB :: [BoolOption]
118 | opsB = generateEnumValues
119 |
120 | -- | All the Integer options.
121 | opsI :: [IntOption]
122 | opsI = generateEnumValues
123 |
124 | -- | All the String options.
125 | opsS :: [StringOption]
126 | opsS = generateEnumValues
127 |
128 | -- comment out options we can't handle yet.
129 | data BoolOption =
130 | Require_Consistency
131 | | Dont_Validate_Unsafe
132 | -- | Always_Reload
133 | | Program_Allow_Nonconfluence_Unsafe
134 | | Interpret_As_Algebra
135 | | Program_Allow_Nontermination_Unsafe
136 | | Allow_Empty_Sorts_Unsafe
137 | -- | Schema_Only
138 | -- | Query_Remove_Redundancy
139 | -- | Import_As_Theory
140 | -- | Import_Joined
141 | -- | Prepend_Entity_On_Ids
142 | -- | Csv_Generate_Ids
143 | -- | Completion_Sort
144 | -- | Completion_Compose
145 | -- | Completion_Filter_Subsumed
146 | -- | Completion_Syntactic_Ac
147 | -- | Eval_Reorder_Joins
148 | -- | Eval_Join_Selectivity
149 | -- | Eval_Use_Indices
150 | -- | Eval_Approx_Sql_Unsafe
151 | -- | Eval_Sql_PersistentIndices
152 | -- | Coproduct_Allow_Collisions
153 | deriving (Eq, Ord, Show, Enum)
154 |
155 | data StringOption =
156 | -- Csv_File_Extension
157 | -- | Id_Column_
158 | -- | Jdbc_Default_Class
159 | -- | Jdbc_Default_String
160 | -- | Completion_Precedence
161 | Prover
162 | deriving (Eq, Ord, Show, Enum)
163 |
164 | -- | Accessor due to namespace colision.
165 | prover_name :: StringOption
166 | prover_name = Prover -- for name collision
167 |
168 | data IntOption =
169 | -- Num_Threads
170 | -- | Random_Seed
171 | Timeout
172 | -- | Varchar_Length
173 | -- | Start_Ids_At
174 | -- | Gui_Max_Graph_Size
175 | -- | Gui_Max_String_Size
176 | -- | Gui_Rows_To_Display
177 | -- | Eval_Max_Plan_Depth
178 | deriving (Eq, Ord, Show, Enum)
179 |
180 | type CharOption = Void
181 | --data CharOption =
182 | -- Csv_Escape_Char
183 | -- Csv_Quote_Char
184 | -- deriving (Eq, Ord, Show, Enum)
185 |
--------------------------------------------------------------------------------
/src/Language/CQL/Common.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE AllowAmbiguousTypes #-}
22 | {-# LANGUAGE ConstraintKinds #-}
23 | {-# LANGUAGE DataKinds #-}
24 | {-# LANGUAGE DuplicateRecordFields #-}
25 | {-# LANGUAGE ExplicitForAll #-}
26 | {-# LANGUAGE FlexibleContexts #-}
27 | {-# LANGUAGE FlexibleInstances #-}
28 | {-# LANGUAGE GADTs #-}
29 | {-# LANGUAGE ImpredicativeTypes #-}
30 | {-# LANGUAGE InstanceSigs #-}
31 | {-# LANGUAGE KindSignatures #-}
32 | {-# LANGUAGE LiberalTypeSynonyms #-}
33 | {-# LANGUAGE MultiParamTypeClasses #-}
34 | {-# LANGUAGE RankNTypes #-}
35 | {-# LANGUAGE ScopedTypeVariables #-}
36 | {-# LANGUAGE TypeFamilies #-}
37 | {-# LANGUAGE TypeOperators #-}
38 | {-# LANGUAGE TypeSynonymInstances #-}
39 | {-# LANGUAGE UndecidableInstances #-}
40 |
41 | module Language.CQL.Common where
42 |
43 | import Control.Arrow (left)
44 | import Data.Char
45 | import Data.Foldable as Foldable (foldl, toList)
46 | import Data.Kind
47 | import Data.Map.Strict as Map hiding (foldl)
48 | import Data.Maybe
49 | import Data.Set as Set (Set, empty, insert, member, singleton)
50 | import Data.String (lines)
51 | import Data.Typeable
52 |
53 | split' :: [(a, Either b1 b2)] -> ([(a, b1)], [(a, b2)])
54 | split' [] = ([],[])
55 | split' ((w, ei):tl) =
56 | let (a,b) = split' tl
57 | in case ei of
58 | Left x -> ((w,x):a, b )
59 | Right x -> ( a, (w,x):b)
60 |
61 | fromListAccum :: (Ord v, Ord k) => [(k, v)] -> Map k (Set v)
62 | fromListAccum [] = Map.empty
63 | fromListAccum ((k,v):kvs) = Map.insert k op (fromListAccum kvs)
64 | where
65 | op = maybe (Set.singleton v) (Set.insert v) (Map.lookup k r)
66 | r = fromListAccum kvs
67 |
68 | -- | Converts a 'List' to a 'Set', returning an error when there are duplicate bindings.
69 | toSetSafely :: (Show k, Ord k) => [k] -> Err (Set k)
70 | toSetSafely [] = return Set.empty
71 | toSetSafely (k:l) = do
72 | l' <- toSetSafely l
73 | if Set.member k l'
74 | then Left $ "Duplicate binding: " ++ show k
75 | else pure $ Set.insert k l'
76 |
77 | -- | Converts an association list to a 'Map', returning an error when there are duplicate bindings.
78 | toMapSafely :: (Show k, Ord k) => [(k,v)] -> Err (Map k v)
79 | toMapSafely [] = return Map.empty
80 | toMapSafely ((k,v):l) = do
81 | l' <- toMapSafely l
82 | if Map.member k l'
83 | then Left $ "Duplicate binding: " ++ show k
84 | else pure $ Map.insert k v l'
85 |
86 | lookup' :: (Show k, Show a, Ord k) => k -> Map k a -> a
87 | lookup' m v = fromMaybe (error $ "Can't find " ++ show v ++ " in " ++ show m) $ Map.lookup m v
88 |
89 | wrapError :: String -> Either String b -> Either String b
90 | wrapError prefix se = (\s -> prefix ++ ": " ++ s) `left` se
91 |
92 | class Deps a where
93 | deps :: a -> [(String, Kind)]
94 |
95 | type a + b = Either a b
96 |
97 | type Err = Either String
98 |
99 | -- generic helper inspired by https://pursuit.purescript.org/search?q=note
100 | note :: b -> Maybe a -> Either b a
101 | note n = maybe (Left n) Right
102 |
103 | data Kind = CONSTRAINTS | TYPESIDE | SCHEMA | INSTANCE | MAPPING | TRANSFORM | QUERY | COMMAND | GRAPH | COMMENT | SCHEMA_COLIMIT
104 | deriving (Show, Eq, Ord)
105 |
106 | type ID = Integer
107 |
108 | -- | Drop quotes if argument doesn't contain a space.
109 | dropQuotes :: String -> String
110 | dropQuotes s = if ' ' `elem` s then Prelude.filter (not . ('\"' ==)) s
111 | else s
112 |
113 | section :: String -> String -> String
114 | section heading body = heading ++ "\n" ++ indentLines body
115 |
116 | indentLines :: String -> String
117 | indentLines = foldMap (\l -> tab <> l <> "\n"). lines
118 |
119 | tab :: String
120 | tab = " "
121 |
122 | sepTup :: (Show a1, Show a2) => String -> (a1, a2) -> String
123 | sepTup sep (k,v) = show k ++ sep ++ show v
124 |
125 | -- | A version of intercalate that works on Foldables instead of just List,
126 | -- | adapted from PureScript.
127 | intercalate :: (Foldable f, Monoid m) => m -> f m -> m
128 | intercalate sep xs = snd (foldl go (True, mempty) xs)
129 | where
130 | go (True, _) x = (False, x)
131 | go (_ , acc) x = (False, acc <> sep <> x)
132 |
133 | mapl :: Foldable f => (a -> b) -> f a -> [b]
134 | mapl fn = fmap fn . Foldable.toList
135 |
136 | -- | Converts a String to lowercase, like Data.List.Extra.lower.
137 | lower :: String -> String
138 | lower = fmap toLower
139 |
140 | -- | Heterogenous membership in a list
141 | elem' :: (Typeable t, Typeable a, Eq a) => t -> [a] -> Bool
142 | elem' x ys = maybe False (`elem` ys) (cast x)
143 |
144 | -- | Heterogenous membership in the keys of a map list
145 | member' :: (Typeable t, Typeable a, Eq a) => t -> Map a v -> Bool
146 | member' k m = elem' k (Map.keys m)
147 |
148 | mergeMaps :: Ord k => [Map k v] -> Map k v
149 | mergeMaps = foldl Map.union Map.empty
150 |
151 | -- | Allows to set a constraint for multiple type variables at the same time.
152 | -- For example you could use `TyMap Show '[a, b, c]` instead of
153 | -- `(Show a, Show b, Show c)`
154 | -- The drawback of using this is that the compiler will treat this as a unique
155 | -- constraint, so it won't be able to detect specific unused constraints
156 | type family TyMap (f :: * -> Constraint) (xs :: [*]) :: Constraint
157 | type instance TyMap f '[] = ()
158 | type instance TyMap f (t ': ts) = (f t, TyMap f ts)
159 |
160 | -- | Allows to set multiple contraints for multiple type variables at the same
161 | -- time.
162 | -- For example you could use `MultiTyMap '[Show, Ord] '[a, b, c]` insted of
163 | -- `(Show a, Ord a, Show b, Ord b, Show c, Ord c)`
164 | -- The drawback of using this is that the compiler will treat this as a unique
165 | -- constraint, so it won't be able to detect specific unused constraints
166 | type family MultiTyMap (fs :: [* -> Constraint]) (xs :: [*]) :: Constraint
167 | type instance MultiTyMap '[] _ = ()
168 | type instance MultiTyMap (f : fs) xs = (TyMap f xs, MultiTyMap fs xs)
169 |
--------------------------------------------------------------------------------
/src/Language/CQL/Internal.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE ViewPatterns
22 | , FlexibleContexts
23 | , FlexibleInstances
24 | , TypeFamilies
25 | , UndecidableInstances
26 | , MultiParamTypeClasses
27 | , FunctionalDependencies
28 | #-}
29 | module Language.CQL.Internal where
30 |
31 | import Prelude hiding (abs, any)
32 |
33 | import Control.Arrow
34 | import Control.Monad
35 | import Control.Monad.Trans.UnionFind (Point, UnionFindT, fresh)
36 | import qualified Control.Monad.Trans.UnionFind as U
37 |
38 | import qualified Data.List as L
39 | --import Data.Sequence (Seq)
40 | import Data.Foldable (traverse_)
41 | import Data.Graph.Inductive hiding (Graph)
42 | import Data.Map (Map)
43 | import Data.Maybe (fromJust)
44 | import Data.Traversable (traverse)
45 |
46 |
47 |
48 |
49 | newtype Conjunctions t = Conjunction [Equation t]
50 | data Equation t
51 | = Equal (Term t) (Term t)
52 | | NotEqual (Term t) (Term t)
53 | data Term t = Function t [Term t]
54 | deriving (Eq, Ord)
55 |
56 | data Satisfiability t = Satisfiable (Model t) | Unsatisfiable
57 | deriving (Show, Eq)
58 |
59 | type Model t = Map (Term t) (Term t)
60 |
61 | (===) :: Term t -> Term t -> Equation t
62 | (===) = Equal
63 | infix 4 ===
64 |
65 | (=/=) :: Term t -> Term t -> Equation t
66 | (=/=) = NotEqual
67 | infix 4 =/=
68 |
69 | instance Show t => Show (Term t) where
70 | show (Function sym childs) =
71 | show sym ++ "(" ++ L.intercalate "," (map show childs) ++ ")"
72 |
73 | class Conjunction t a | a -> t where
74 | (/\) :: Equation t -> a -> Conjunctions t
75 | infixr 3 /\
76 |
77 | instance (Conjunction t (Equation t)) where
78 | (/\) e1 e2 = Conjunction [e1, e2]
79 |
80 | instance Conjunction t (Conjunctions t) where
81 | (/\) e1 (Conjunction e2) = Conjunction (e1:e2)
82 |
83 | newtype Graph t = Graph (NodeMap (Term t), Gr (t, Point (LNode t)) Int)
84 | newtype Vert t = Vert (LNode (t, Point (LNode t)))
85 |
86 | interleave :: [(a,a)] -> [a]
87 | interleave ((x,y):rest) = x : y : interleave rest
88 | interleave [] = []
89 |
90 | termGraph :: (Monad m, Ord t) => [Equation t] -> UnionFindT (LNode t) m (Graph t)
91 | termGraph = termGraph' . interleave . terms
92 |
93 | termGraph' :: (Monad m, Ord t) => [Term t] -> UnionFindT (LNode t) m (Graph t)
94 | termGraph' ts = do
95 | let (nodeMap, gr) = snd $ run empty $ traverse_ insertTerm ts
96 | vars <- traverse genVars (labNodes gr)
97 | return $ Graph (nodeMap, mkGraph vars (labEdges gr))
98 | where
99 | insertTerm :: Ord t => Term t -> NodeMapM (Term t) Int Gr ()
100 | insertTerm trm@(Function _ childs) = do
101 | _ <- insMapNodeM trm
102 | forM_ (zip childs [1..]) $ \(child,i) -> do
103 | _ <- insMapNodeM child
104 | insMapEdgeM (trm,child,i)
105 | insertTerm child
106 |
107 | genVars (node, Function name _) = do
108 | var <- fresh (node,name)
109 | return (node,(name,var))
110 |
111 | vertex :: Ord t => Graph t -> Term t -> Vert t
112 | vertex gr@(Graph (nodeMap,_)) trm =
113 | let (node,_) = mkNode_ nodeMap trm
114 | in label gr node
115 |
116 | graph :: Graph t -> Gr (t, Point (LNode t)) Int
117 | graph (Graph (_, gr)) = gr
118 |
119 | vertices :: Graph t -> [Vert t]
120 | vertices = map Vert . labNodes . graph
121 |
122 | outDegree :: Graph t -> Vert t -> Int
123 | outDegree (graph -> gr) (Vert (x, _)) = outdeg gr x
124 |
125 | label :: Graph t -> Node -> Vert t
126 | label (graph -> gr) a = Vert (a, fromJust (lab gr a))
127 |
128 | equivalent :: (Monad m) => Vert t -> Vert t -> UnionFindT (LNode t) m Bool
129 | equivalent (Vert (_,(_,x))) (Vert (_,(_,y))) = U.equivalent x y
130 |
131 | union :: (Monad m) => Vert t -> Vert t -> UnionFindT (LNode t) m ()
132 | union (Vert (_,(_,x))) (Vert (_,(_,y))) = U.union x y
133 |
134 | predecessors :: Graph t -> Vert t -> [Vert t]
135 | predecessors gr (Vert (x,_)) = label gr <$> pre (graph gr) x
136 |
137 | successors :: Graph t -> Vert t -> [Vert t]
138 | successors gr (Vert (x,_)) = label gr <$> suc (graph gr) x
139 |
140 | terms :: [Equation t] -> [(Term t, Term t)]
141 | terms = map go
142 | where
143 | go e = case e of
144 | Equal t1 t2 -> (t1,t2)
145 | NotEqual t1 t2 -> (t1,t2)
146 |
147 | term :: Graph t -> Vert t -> Term t
148 | term (Graph (_,gr0)) (Vert (n0,_)) = go gr0 n0
149 | where
150 | go :: Gr (t, a) Int -> Node -> Term t
151 | go gr n =
152 | case match n gr of
153 | (Nothing,_) -> error "context is Nothing"
154 | (Just (_,_,(sym,_),out0),gr') ->
155 | Function sym $ map (go gr') $ sortEdges out0
156 | sortEdges out0 = map snd $ L.sortOn fst out0
157 |
158 | partition :: Ord t => Graph t -> (Equation t -> Bool) -> [Equation t] -> ([(Vert t,Vert t)],[(Vert t,Vert t)])
159 | partition gr f equations =
160 | let (as,bs) = L.partition f equations
161 | in (map (vertex gr *** vertex gr) $ terms as, map (vertex gr *** vertex gr) $ terms bs)
162 |
163 | unless :: Monad m => m Bool -> m () -> m ()
164 | unless mbool m = do
165 | b <- mbool
166 | Control.Monad.unless b m
167 |
168 | instance Show t => Show (Vert t) where
169 | show (Vert (n, _)) = show n
170 |
171 | positive :: Equation t -> Bool
172 | positive t =
173 | case t of
174 | Equal _ _ -> True
175 | NotEqual _ _ -> False
176 |
177 | any :: Monad m => (a -> b -> m Bool) -> [(a,b)] -> m Bool
178 | any _ [] = return False
179 | any f ((a,b):abs) = do
180 | r <- f a b
181 | if r
182 | then return True
183 | else any f abs
184 |
185 |
186 | {--
187 |
188 | Copyright (c) 2014, Sven Keidel
189 |
190 | All rights reserved.
191 |
192 | Redistribution and use in source and binary forms, with or without
193 | modification, are permitted provided that the following conditions are met:
194 |
195 | * Redistributions of source code must retain the above copyright
196 | notice, this list of conditions and the following disclaimer.
197 |
198 | * Redistributions in binary form must reproduce the above
199 | copyright notice, this list of conditions and the following
200 | disclaimer in the documentation and/or other materials provided
201 | with the distribution.
202 |
203 | * Neither the name of Sven Keidel nor the names of other
204 | contributors may be used to endorse or promote products derived
205 | from this software without specific prior written permission.
206 |
207 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
208 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
209 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
210 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
211 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
212 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
213 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
214 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
215 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
216 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
217 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
218 |
219 | --}
220 |
--------------------------------------------------------------------------------
/src/Language/CQL/Morphism.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE AllowAmbiguousTypes #-}
22 | {-# LANGUAGE DataKinds #-}
23 | {-# LANGUAGE DuplicateRecordFields #-}
24 | {-# LANGUAGE ExplicitForAll #-}
25 | {-# LANGUAGE FlexibleContexts #-}
26 | {-# LANGUAGE FlexibleInstances #-}
27 | {-# LANGUAGE GADTs #-}
28 | {-# LANGUAGE ImpredicativeTypes #-}
29 | {-# LANGUAGE IncoherentInstances #-}
30 | {-# LANGUAGE InstanceSigs #-}
31 | {-# LANGUAGE LiberalTypeSynonyms #-}
32 | {-# LANGUAGE MultiParamTypeClasses #-}
33 | {-# LANGUAGE RankNTypes #-}
34 | {-# LANGUAGE ScopedTypeVariables #-}
35 | {-# LANGUAGE StandaloneDeriving #-}
36 | {-# LANGUAGE TypeOperators #-}
37 | {-# LANGUAGE TypeSynonymInstances #-}
38 | {-# LANGUAGE UndecidableInstances #-}
39 |
40 | module Language.CQL.Morphism where
41 |
42 | import Control.DeepSeq
43 | import Data.Map.Strict as Map hiding (foldr, size)
44 | import Data.Maybe
45 | import Data.Set as Set hiding (foldr, size)
46 | import Data.Void
47 | import Language.CQL.Collage (Collage(..))
48 | import Language.CQL.Common
49 | import Language.CQL.Term (Ctx, Term(..), EQ, EQF(..), subst, upp)
50 | import Prelude hiding (EQ)
51 |
52 | -- | A morphism between 'Collage's.
53 | data Morphism var ty sym en fk att gen sk en' fk' att' gen' sk'
54 | = Morphism
55 | { m_src :: Collage (()+var) ty sym en fk att gen sk
56 | , m_dst :: Collage (()+var) ty sym en' fk' att' gen' sk'
57 | , m_ens :: Map en en'
58 | , m_fks :: Map fk (Term () Void Void en' fk' Void Void Void)
59 | , m_atts :: Map att (Term () ty sym en' fk' att' Void Void)
60 | , m_gens :: Map gen (Term Void Void Void en' fk' Void gen' Void)
61 | , m_sks :: Map sk (Term Void ty sym en' fk' att' gen' sk')
62 | }
63 |
64 | -- | Checks totality of the morphism mappings.
65 | checkDoms'
66 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk, en', fk', att', gen', sk'])
67 | => Morphism var ty sym en fk att gen sk en' fk' att' gen' sk'
68 | -> Err ()
69 | checkDoms' mor = do
70 | mapM_ e $ Set.toList $ cens $ m_src mor
71 | mapM_ f $ Map.keys $ cfks $ m_src mor
72 | mapM_ a $ Map.keys $ catts $ m_src mor
73 | mapM_ g $ Map.keys $ cgens $ m_src mor
74 | mapM_ s $ Map.keys $ csks $ m_src mor
75 | where
76 | e en = if Map.member en $ m_ens mor then pure () else Left $ "No entity mapping for " ++ show en
77 | f fk = if Map.member fk $ m_fks mor then pure () else Left $ "No fk mapping for " ++ show fk
78 | a at = if Map.member at $ m_atts mor then pure () else Left $ "No att mapping for " ++ show at
79 | g gn = if Map.member gn $ m_gens mor then pure () else Left $ "No gen mapping for " ++ show gn
80 | s sk = if Map.member sk $ m_sks mor then pure () else Left $ "No sk mapping for " ++ show sk
81 |
82 | -- | Translates a term along a morphism.
83 | translate'
84 | :: forall var var' ty sym en fk att gen sk en' fk' att' gen' sk'
85 | . TyMap Ord '[gen, sk, fk, var, att, var']
86 | => Morphism var ty sym en fk att gen sk en' fk' att' gen' sk'
87 | -> Term var' Void Void en fk Void gen Void
88 | -> Term var' Void Void en' fk' Void gen' Void
89 | translate' _ (Var x) = Var x
90 | translate' mor (Fk f a) = let
91 | x = translate' mor a :: Term var' Void Void en' fk' Void gen' Void
92 | y = upp (m_fks mor ! f) :: Term () Void Void en' fk' Void gen' Void
93 | in subst y x
94 | translate' mor (Gen g) = upp $ m_gens mor ! g
95 | translate' _ (Sym _ _) = undefined
96 | translate' _ (Att _ _) = undefined
97 | translate' _ (Sk _ ) = undefined
98 |
99 | -- | Translates a term along a morphism.
100 | translate
101 | :: forall var var' ty sym en fk att gen sk en' fk' att' gen' sk'
102 | . TyMap Ord '[gen, sk, fk, var, att, var']
103 | => Morphism var ty sym en fk att gen sk en' fk' att' gen' sk'
104 | -> Term var' ty sym en fk att gen sk
105 | -> Term var' ty sym en' fk' att' gen' sk'
106 | translate mor term = case term of
107 | Var x -> Var x
108 | Sym f xs -> Sym f (translate mor <$> xs)
109 | Gen g -> upp $ m_gens mor ! g
110 | Sk s -> upp $ m_sks mor ! s
111 | Att f a -> subst (upp $ m_atts mor ! f) $ translate mor a
112 | Fk f a -> subst (upp y) x
113 | where
114 | x = translate mor a :: Term var' ty sym en' fk' att' gen' sk'
115 | y = m_fks mor ! f :: Term () Void Void en' fk' Void Void Void
116 |
117 | typeOf
118 | :: forall var ty sym en fk att gen sk en' fk' att' gen' sk'
119 | . (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk, en', fk', att', gen', sk'])
120 | => Morphism var ty sym en fk att gen sk en' fk' att' gen' sk'
121 | -> Err ()
122 | typeOf mor = do
123 | checkDoms' mor
124 | mapM_ typeOfMorEns $ Map.toList $ m_ens mor
125 | mapM_ typeOfMorFks $ Map.toList $ m_fks mor
126 | mapM_ typeOfMorAtts $ Map.toList $ m_atts mor
127 | mapM_ typeOfMorGens $ Map.toList $ m_gens mor
128 | mapM_ typeOfMorSks $ Map.toList $ m_sks mor
129 | where
130 | transE en = case (Map.lookup en (m_ens mor)) of
131 | Just x -> x
132 | Nothing -> undefined
133 | typeOfMorEns (e,e') | elem e (cens $ m_src mor) && elem e' (cens $ m_dst mor) = pure ()
134 | typeOfMorEns (e,e') = Left $ "Bad entity mapping " ++ show e ++ " -> " ++ show e'
135 | typeOfMorFks :: (fk, Term () Void Void en' fk' Void Void Void) -> Err ()
136 | typeOfMorFks (fk,e) | Map.member fk (cfks $ m_src mor)
137 | = let (s,t) = fromJust $ Map.lookup fk $ cfks $ m_src mor
138 | (s',t') = (transE s, transE t)
139 | in do t0 <- typeOf' (m_dst mor) (Map.fromList [(Left (), Right s')]) $ upp e
140 | if t0 == Right t' then pure () else Left $ "1Ill typed in " ++ show fk ++ ": " ++ show e
141 | typeOfMorFks (e,e') = Left $ "Bad fk mapping " ++ show e ++ " -> " ++ show e'
142 | typeOfMorAtts (att,e) | Map.member att (catts $ m_src mor)
143 | = let (s,t) = fromJust $ Map.lookup att $ catts $ m_src mor
144 | s' = transE s
145 | in do t0 <- typeOf' (m_dst mor) (Map.fromList [(Left (),Right s')]) $ upp e
146 | if t0 == Left t then pure () else Left $ "2Ill typed attribute, " ++ show att ++ " expression " ++ show e
147 | ++ ", computed type " ++ show t0 ++ " and required type " ++ show t
148 | typeOfMorAtts (e,e') = Left $ "Bad att mapping " ++ show e ++ " -> " ++ show e'
149 | typeOfMorGens (gen,e) | Map.member gen (cgens $ m_src mor)
150 | = let t = fromJust $ Map.lookup gen $ cgens $ m_src mor
151 | t' = transE t
152 | in do t0 <- typeOf' (m_dst mor) (Map.fromList []) $ upp e
153 | if t0 == Right t' then pure () else Left $ "3Ill typed in " ++ show gen ++ ": " ++ show e
154 | typeOfMorGens (e,e') = Left $ "Bad gen mapping " ++ show e ++ " -> " ++ show e'
155 | typeOfMorSks (sk,e) | Map.member sk (csks $ m_src mor)
156 | = let t = fromJust $ Map.lookup sk $ csks $ m_src mor
157 | in do t0 <- typeOf' (m_dst mor) (Map.fromList []) $ upp e
158 | if t0 == Left t then pure () else Left $ "4Ill typed in " ++ show sk ++ ": " ++ show e
159 | typeOfMorSks (e,e') = Left $ "Bad null mapping " ++ show e ++ " -> " ++ show e'
160 |
161 |
162 | typeOf'
163 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
164 | => Collage var ty sym en fk att gen sk
165 | -> Ctx var (ty + en)
166 | -> Term var ty sym en fk att gen sk
167 | -> Err (ty + en)
168 | typeOf' _ ctx (Var v) = note ("Unbound variable: " ++ show v) $ Map.lookup v ctx
169 | typeOf' col _ (Gen g) = case Map.lookup g $ cgens col of
170 | Nothing -> Left $ "Unknown generator: " ++ show g
171 | Just t -> Right $ Right t
172 | typeOf' col _ (Sk s) = case Map.lookup s $ csks col of
173 | Nothing -> Left $ "Unknown labelled null: " ++ show s
174 | Just t -> Right $ Left t
175 | typeOf' col ctx xx@(Fk f a) = case Map.lookup f $ cfks col of
176 | Nothing -> Left $ "Unknown foreign key: " ++ show f
177 | Just (s, t) -> do s' <- typeOf' col ctx a
178 | if (Right s) == s' then pure $ Right t else Left $ "Expected argument to have entity " ++
179 | show s ++ " but given " ++ show s' ++ " in " ++ (show xx)
180 | typeOf' col ctx xx@(Att f a) = case Map.lookup f $ catts col of
181 | Nothing -> Left $ "Unknown attribute: " ++ show f
182 | Just (s, t) -> do s' <- typeOf' col ctx a
183 | if (Right s) == s' then pure $ Left t else Left $ "Expected argument to have entity " ++
184 | show s ++ " but given " ++ show s' ++ " in " ++ (show xx)
185 | typeOf' col ctx xx@(Sym f a) = case Map.lookup f $ csyms col of
186 | Nothing -> Left $ "Unknown function symbol: " ++ show f
187 | Just (s, t) -> do s' <- mapM (typeOf' col ctx) a
188 | if length s' == length s
189 | then if (Left <$> s) == s'
190 | then pure $ Left t
191 | else Left $ "Expected arguments to have types " ++
192 | show s ++ " but given " ++ show s' ++ " in " ++ (show $ xx)
193 | else Left $ "Expected argument to have arity " ++
194 | show (length s) ++ " but given " ++ show (length s') ++ " in " ++ (show $ xx)
195 |
196 | typeOfEq'
197 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
198 | => Collage var ty sym en fk att gen sk
199 | -> (Ctx var (ty + en), EQ var ty sym en fk att gen sk)
200 | -> Err (ty + en)
201 | typeOfEq' col (ctx, EQ (lhs, rhs)) = do
202 | lhs' <- typeOf' col ctx lhs
203 | rhs' <- typeOf' col ctx rhs
204 | if lhs' == rhs'
205 | then Right lhs'
206 | else Left $ "Equation lhs has type " ++ show lhs' ++ " but rhs has type " ++ show rhs'
207 |
--------------------------------------------------------------------------------
/src/Language/CQL/Typeside.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE AllowAmbiguousTypes #-}
22 | {-# LANGUAGE DataKinds #-}
23 | {-# LANGUAGE DuplicateRecordFields #-}
24 | {-# LANGUAGE ExplicitForAll #-}
25 | {-# LANGUAGE FlexibleContexts #-}
26 | {-# LANGUAGE FlexibleInstances #-}
27 | {-# LANGUAGE GADTs #-}
28 | {-# LANGUAGE ImpredicativeTypes #-}
29 | {-# LANGUAGE InstanceSigs #-}
30 | {-# LANGUAGE KindSignatures #-}
31 | {-# LANGUAGE LiberalTypeSynonyms #-}
32 | {-# LANGUAGE MultiParamTypeClasses #-}
33 | {-# LANGUAGE RankNTypes #-}
34 | {-# LANGUAGE ScopedTypeVariables #-}
35 | {-# LANGUAGE StandaloneDeriving #-}
36 | {-# LANGUAGE TypeOperators #-}
37 | {-# LANGUAGE TypeSynonymInstances #-}
38 | {-# LANGUAGE UndecidableInstances #-}
39 |
40 | module Language.CQL.Typeside where
41 | import Control.DeepSeq
42 | import Data.Bifunctor (first)
43 | import Data.List (nub)
44 | import Data.Map.Strict hiding (foldr)
45 | import qualified Data.Map.Strict as Map
46 | import Data.Set (Set)
47 | import qualified Data.Set as Set
48 | import Data.Typeable
49 | import Data.Void
50 | import Language.CQL.Collage (Collage(..), typeOfCol)
51 | import Language.CQL.Common
52 | import Language.CQL.Options
53 | import Language.CQL.Prover
54 | import Language.CQL.Term
55 | import Prelude hiding (EQ)
56 |
57 | -- | A user-defined kind for customization of data types.
58 | data Typeside var ty sym
59 | = Typeside
60 | { tys :: Set ty
61 | , syms :: Map sym ([ty], ty)
62 | , eqs :: Set (Ctx var ty, EQ var ty sym Void Void Void Void Void)
63 | , eq :: Ctx var ty -> EQ var ty sym Void Void Void Void Void -> Bool
64 | }
65 |
66 | instance (Eq var, Eq ty, Eq sym) => Eq (Typeside var ty sym) where
67 | (==) (Typeside tys' syms' eqs' _)
68 | (Typeside tys'' syms'' eqs'' _)
69 | = (tys' == tys'') && (syms' == syms'') && (eqs' == eqs'')
70 |
71 | instance (Show var, Show ty, Show sym) => Show (Typeside var ty sym) where
72 | show (Typeside tys' syms' eqs' _) =
73 | section "typeside" $ unlines
74 | [ section "types" $ unlines . fmap show $ Set.toList tys'
75 | , section "functions" $ unlines syms''
76 | , section "equations" $ unlines eqs''
77 | ]
78 | where
79 | syms'' = (\(k,(s,t)) -> show k ++ " : " ++ show s ++ " -> " ++ show t) <$> Map.toList syms'
80 | eqs'' = (\(k,s) -> "forall " ++ showCtx k ++ " . " ++ show s) <$> Set.toList eqs'
81 |
82 | showCtx :: (Show a1, Show a2) => Map a1 a2 -> String
83 | showCtx m = unwords $ fmap (sepTup " : ") $ Map.toList m
84 |
85 | instance (NFData var, NFData ty, NFData sym) => NFData (Typeside var ty sym) where
86 | rnf (Typeside tys0 syms0 eqs0 eq0) = deepseq tys0 $ deepseq syms0 $ deepseq eqs0 $ deepseq eq0 ()
87 |
88 | typecheckTypeside :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym]) => Typeside var ty sym -> Err ()
89 | typecheckTypeside = typeOfCol . tsToCol
90 |
91 | -- | Converts a typeside to a collage.
92 | tsToCol :: (Ord var, Ord ty, Ord sym) => Typeside var ty sym -> Collage var ty sym Void Void Void Void Void
93 | tsToCol (Typeside tys syms eqs _) =
94 | Collage (leftify eqs) tys Set.empty syms mempty mempty mempty mempty
95 | where
96 | leftify = Set.map (first (fmap Left))
97 |
98 | data TypesideEx :: * where
99 | TypesideEx
100 | :: forall var ty sym. (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym])
101 | => Typeside var ty sym
102 | -> TypesideEx
103 |
104 | instance NFData TypesideEx where
105 | rnf (TypesideEx x) = rnf x
106 |
107 | -- TypesideEx is an implementation detail, so hide its presence
108 | instance (Show TypesideEx) where
109 | show (TypesideEx i) = show i
110 |
111 | ------------------------------------------------------------------------------------------------------------
112 | -- Literal typesides
113 |
114 | type Ty = String
115 | type Sym = String
116 | type Var = String
117 |
118 | data TypesideRaw' = TypesideRaw'
119 | { tsraw_tys :: [String]
120 | , tsraw_syms :: [(String, ([String], String))]
121 | , tsraw_eqs :: [([(String, Maybe String)], RawTerm, RawTerm)]
122 | , tsraw_options :: [(String, String)]
123 | , tsraw_imports :: [TypesideExp]
124 | } deriving (Eq, Show)
125 |
126 |
127 | evalTypesideRaw :: Options -> TypesideRaw' -> [TypesideEx] -> Err TypesideEx
128 | evalTypesideRaw opts tsRaw imports = do
129 | imports' <- doImports imports
130 | ts <- evalTypesideRaw' tsRaw imports'
131 | opts' <- toOptions opts $ tsraw_options tsRaw
132 | prover <- createProver (tsToCol ts) opts'
133 | let eq = \ctx -> prove prover (Map.map Left ctx)
134 | pure $ TypesideEx $ Typeside (tys ts) (syms ts) (eqs ts) eq
135 | where
136 | doImports :: forall var ty sym. (Typeable var, Typeable ty, Typeable sym) => [TypesideEx] -> Err [Typeside var ty sym]
137 | doImports [] = return []
138 | doImports (TypesideEx imp:imps) = do
139 | imp' <- note "Bad import" $ cast imp
140 | imps' <- doImports imps
141 | return $ imp' : imps'
142 |
143 | evalTypesideRaw' :: TypesideRaw' -> [Typeside Var Ty Sym] -> Err (Typeside Var Ty Sym)
144 | evalTypesideRaw' (TypesideRaw' ttys tsyms teqs _ _) importedTys = do
145 | tys' <- toSetSafely ttys
146 | syms' <- toMapSafely tsyms
147 | eqs' <- evalEqs (addImportedSyms syms') teqs
148 | return $ Typeside (Set.union importedTys' tys') (addImportedSyms syms') (Set.union importedEqs eqs') prover
149 | where
150 | prover = undefined -- intentionally left blank; is there a less explosive way to do this?
151 | importedTys' = foldMap tys importedTys
152 | importedEqs = foldMap eqs importedTys
153 | addImportedSyms syms' = foldr (\(f',(s,t)) m -> Map.insert f' (s,t) m) syms' $ concatMap (Map.toList . syms) importedTys
154 |
155 | evalEqs _ [] = pure Set.empty
156 | evalEqs syms' ((ctx, lhs, rhs):eqs') = do
157 | ctx' <- check syms' ctx lhs rhs
158 | lhs' <- evalTerm syms' ctx' lhs
159 | rhs' <- evalTerm syms' ctx' rhs
160 | rest <- evalEqs syms' eqs'
161 | pure $ Set.insert (ctx', EQ (lhs', rhs')) rest
162 |
163 | evalTerm :: Monad m => t -> Ctx String a -> RawTerm -> m (Term String ty String en fk att gen sk)
164 | evalTerm _ ctx (RawApp v []) | Map.member v ctx = pure $ Var v
165 | evalTerm syms' ctx (RawApp v l) = Sym v <$> mapM (evalTerm syms' ctx) l
166 |
167 | check _ [] _ _ = pure Map.empty
168 | check syms' ((v,t):l) lhs rhs = do {x <- check syms' l lhs rhs; t' <- infer v t syms' lhs rhs; pure $ Map.insert v t' x}
169 |
170 | infer _ (Just t) _ _ _ = return t
171 | infer v _ syms' lhs rhs = case (t1s, t2s) of
172 | ([t1] , [t2] ) -> if t1 == t2 then return t1 else Left $ "Type mismatch on " ++ show v ++ " in " ++ show lhs ++ " = " ++ show rhs ++ ", types are " ++ show t1 ++ " and " ++ show t2
173 | (t1 : t2 : _, _ ) -> Left $ "Conflicting types for " ++ show v ++ " in " ++ show lhs ++ ": " ++ show t1 ++ " and " ++ show t2
174 | (_ , t1 : t2 : _) -> Left $ "Conflicting types for " ++ show v ++ " in " ++ show rhs ++ ": " ++ show t1 ++ " and " ++ show t2
175 | ([] , [t] ) -> return t
176 | ([t] , [] ) -> return t
177 | ([] , [] ) -> Left $ "Ambiguous variable: " ++ show v
178 | where
179 | t1s = nub $ typesOf v syms' lhs
180 | t2s = nub $ typesOf v syms' rhs
181 |
182 | typesOf _ _ (RawApp _ []) = []
183 | typesOf v syms' (RawApp f' as) = concatMap fn $ zip as $ maybe [] fst $ Map.lookup f' syms'
184 | where
185 | fn (a',t) = case a' of
186 | RawApp v' [] -> [t | v == v']
187 | RawApp _ _ -> typesOf v syms' a'
188 |
189 | -----------------------------------------------------------------------------------------------------------
190 | -- Simple typesides
191 |
192 | initialTypeside :: Typeside Void Void Void
193 | initialTypeside = Typeside Set.empty Map.empty Set.empty (\_ _ -> error "Impossible, please report.") --todo: use absurd
194 |
195 | sqlTypeside :: Typeside Void String Void
196 | sqlTypeside = Typeside (Set.fromList sqlTypeNames) Map.empty Set.empty (\_ (EQ (l, r)) -> l == r)
197 |
198 | sqlTypeNames :: [String]
199 | sqlTypeNames =
200 | [ "Bigint", "Binary", "Bit", "Blob", "Bool", "Boolean"
201 | , "Char", "Clob" , "Custom"
202 | , "Date", "Decimal", "Dom", "Double", "Doubleprecision"
203 | , "Float"
204 | , "Int", "Integer"
205 | , "Longvarbinary", "Longvarchar"
206 | , "Numeric", "Nvarchar"
207 | , "Other"
208 | , "Real"
209 | , "Smallint", "String"
210 | , "Text", "Time", "Timestamp", "Tinyint"
211 | , "Varbinary", "Varchar"
212 | ]
213 |
214 | -----------------------------------------------------------------------------------------------------------
215 | -- Expression syntax
216 |
217 | -- There are practical haskell type system related reasons to not want this to be a GADT.
218 | data TypesideExp where
219 | TypesideVar :: String -> TypesideExp
220 | TypesideInitial :: TypesideExp
221 | TypesideRaw :: TypesideRaw' -> TypesideExp
222 | TypesideSql :: TypesideExp
223 |
224 | deriving instance Eq TypesideExp
225 | deriving instance Show TypesideExp
226 |
227 | instance Deps TypesideExp where
228 | deps x = case x of
229 | TypesideVar v -> [(v, TYPESIDE)]
230 | TypesideInitial -> []
231 | TypesideSql -> []
232 | TypesideRaw (TypesideRaw' _ _ _ _ i) -> concatMap deps i
233 |
234 | getOptionsTypeside :: TypesideExp -> [(String, String)]
235 | getOptionsTypeside x = case x of
236 | TypesideSql -> []
237 | TypesideVar _ -> []
238 | TypesideInitial -> []
239 | TypesideRaw (TypesideRaw' _ _ _ o _) -> o
240 |
--------------------------------------------------------------------------------
/src/Language/CQL/Collage.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE AllowAmbiguousTypes #-}
22 | {-# LANGUAGE DataKinds #-}
23 | {-# LANGUAGE DuplicateRecordFields #-}
24 | {-# LANGUAGE ExplicitForAll #-}
25 | {-# LANGUAGE FlexibleContexts #-}
26 | {-# LANGUAGE FlexibleInstances #-}
27 | {-# LANGUAGE GADTs #-}
28 | {-# LANGUAGE ImpredicativeTypes #-}
29 | {-# LANGUAGE IncoherentInstances #-}
30 | {-# LANGUAGE InstanceSigs #-}
31 | {-# LANGUAGE LiberalTypeSynonyms #-}
32 | {-# LANGUAGE MultiParamTypeClasses #-}
33 | {-# LANGUAGE RankNTypes #-}
34 | {-# LANGUAGE ScopedTypeVariables #-}
35 | {-# LANGUAGE StandaloneDeriving #-}
36 | {-# LANGUAGE TupleSections #-}
37 | {-# LANGUAGE TypeOperators #-}
38 | {-# LANGUAGE TypeSynonymInstances #-}
39 | {-# LANGUAGE UndecidableInstances #-}
40 |
41 | module Language.CQL.Collage where
42 |
43 | import Control.DeepSeq (NFData)
44 | import Data.Map.Merge.Strict
45 | import Data.Map.Strict as Map hiding (foldr, size)
46 | import Data.Set as Set hiding (foldr, size)
47 | import Data.Void
48 | import Language.CQL.Common
49 | import Language.CQL.Term (Ctx, EQ, EQF(..), Head(..), Term(..), occsTerm, upp)
50 | import qualified Language.CQL.Term as T (simplifyTheory)
51 | import Prelude hiding (EQ)
52 |
53 | data Collage var ty sym en fk att gen sk
54 | = Collage
55 | { ceqs :: Set (Ctx var (ty+en), EQ var ty sym en fk att gen sk)
56 | , ctys :: Set ty
57 | , cens :: Set en
58 | , csyms :: Map sym ([ty], ty)
59 | , cfks :: Map fk (en , en)
60 | , catts :: Map att (en , ty)
61 | , cgens :: Map gen en
62 | , csks :: Map sk ty
63 | } deriving (Eq, Show)
64 |
65 | --------------------------------------------------------------------------------
66 |
67 | occs
68 | :: (Ord sym, Ord fk, Ord att, Ord gen, Ord sk)
69 | => Collage var ty sym en fk att gen sk
70 | -> Map (Head ty sym en fk att gen sk) Int
71 | occs col = foldr (\(_, EQ (lhs, rhs)) x -> m x $ m (occsTerm lhs) $ occsTerm rhs) Map.empty $ ceqs col
72 | where
73 | m = merge preserveMissing preserveMissing $ zipWithMatched (\_ x y -> x + y)
74 |
75 | --------------------------------------------------------------------------------
76 |
77 | -- | Simplify a collage by replacing symbols of the form @gen/sk = term@, yielding also a
78 | -- translation function from the old theory to the new, encoded as a list of (symbol, term) pairs.
79 | simplify
80 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
81 | => Collage var ty sym en fk att gen sk
82 | -> (Collage var ty sym en fk att gen sk, [(Head ty sym en fk att gen sk, Term var ty sym en fk att gen sk)])
83 | simplify (Collage ceqs' ctys' cens' csyms' cfks' catts' cgens' csks' )
84 | = (Collage ceqs'' ctys' cens' csyms' cfks' catts' cgens'' csks'', f)
85 | where
86 | (ceqs'', f) = T.simplifyTheory ceqs' []
87 | cgens'' = Map.fromList $ Prelude.filter (\(x,_) -> notElem (HGen x) $ fmap fst f) $ Map.toList cgens'
88 | csks'' = Map.fromList $ Prelude.filter (\(x,_) -> notElem (HSk x) $ fmap fst f) $ Map.toList csks'
89 |
90 | --------------------------------------------------------------------------------
91 |
92 | eqsAreGround :: Collage var ty sym en fk att gen sk -> Bool
93 | eqsAreGround col = Prelude.null [ x | x <- Set.toList $ ceqs col, not $ Map.null (fst x) ]
94 |
95 | fksFrom :: Eq en => Collage var ty sym en fk att gen sk -> en -> [(fk,en)]
96 | fksFrom sch en' = f $ Map.assocs $ cfks sch
97 | where f [] = []
98 | f ((fk,(en1,t)):l) = if en1 == en' then (fk,t) : (f l) else f l
99 |
100 | attsFrom :: Eq en => Collage var ty sym en fk att gen sk -> en -> [(att,ty)]
101 | attsFrom sch en' = f $ Map.assocs $ catts sch
102 | where f [] = []
103 | f ((fk,(en1,t)):l) = if en1 == en' then (fk,t) : (f l) else f l
104 |
105 | -- TODO Carrier is duplicated here from Instance.Algebra (Carrier) because it is used in assembleGens.
106 | type Carrier en fk gen = Term Void Void Void en fk Void gen Void
107 |
108 | assembleGens
109 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
110 | => Collage var ty sym en fk att gen sk
111 | -> [Carrier en fk gen]
112 | -> Map en (Set (Carrier en fk gen))
113 | assembleGens col [] = Map.fromList $ mapl (, Set.empty) $ cens col
114 | assembleGens col (e:tl) = Map.insert t (Set.insert e s) m
115 | where
116 | m = assembleGens col tl
117 | t = typeOf col e
118 | s = m ! t
119 |
120 | -- | Gets the type of a term that is already known to be well-typed.
121 | typeOf
122 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
123 | => Collage var ty sym en fk att gen sk
124 | -> Term Void Void Void en fk Void gen Void
125 | -> en
126 | typeOf col e = case typeOf' col Map.empty (upp e) of
127 | Left _ -> error "Impossible in typeOf, please report."
128 | Right x -> case x of
129 | Left _ -> error "Impossible in typeOf, please report."
130 | Right y -> y
131 |
132 | checkDoms
133 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
134 | => Collage var ty sym en fk att gen sk
135 | -> Err ()
136 | checkDoms col = do
137 | mapM_ f $ Map.elems $ csyms col
138 | mapM_ g $ Map.elems $ cfks col
139 | mapM_ h $ Map.elems $ catts col
140 | mapM_ isEn $ Map.elems $ cgens col
141 | mapM_ isTy $ Map.elems $ csks col
142 | where
143 | f (t1,t2) = do { mapM_ isTy t1 ; isTy t2 }
144 | g (e1,e2) = do { isEn e1 ; isEn e2 }
145 | h (e ,t ) = do { isEn e ; isTy t }
146 | isEn x = if Set.member x $ cens col
147 | then pure ()
148 | else Left $ "Not an entity: " ++ show x
149 | isTy x = if Set.member x $ ctys col
150 | then pure ()
151 | else Left $ "Not a type: " ++ show x
152 |
153 | typeOfCol
154 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
155 | => Collage var ty sym en fk att gen sk
156 | -> Err ()
157 | typeOfCol col = do
158 | checkDoms col
159 | mapM_ (typeOfEq' col) $ Set.toList $ ceqs col
160 |
161 | --------------------------------------------------------------------------------
162 |
163 | typeOf'
164 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
165 | => Collage var ty sym en fk att gen sk
166 | -> Ctx var (ty + en)
167 | -> Term var ty sym en fk att gen sk
168 | -> Err (ty + en)
169 | typeOf' _ ctx (Var v) = note ("Unbound variable: " ++ show v) $ Map.lookup v ctx
170 | typeOf' col _ (Gen g) = case Map.lookup g $ cgens col of
171 | Nothing -> Left $ "Unknown generator: " ++ show g
172 | Just t -> Right $ Right t
173 | typeOf' col _ (Sk s) = case Map.lookup s $ csks col of
174 | Nothing -> Left $ "Unknown labelled null: " ++ show s
175 | Just t -> Right $ Left t
176 | typeOf' col ctx xx@(Fk f a) = case Map.lookup f $ cfks col of
177 | Nothing -> Left $ "Unknown foreign key: " ++ show f
178 | Just (s, t) -> do s' <- typeOf' col ctx a
179 | if (Right s) == s' then pure $ Right t else Left $ "Expected argument to have entity " ++
180 | show s ++ " but given " ++ show s' ++ " in " ++ (show xx)
181 | typeOf' col ctx xx@(Att f a) = case Map.lookup f $ catts col of
182 | Nothing -> Left $ "Unknown attribute: " ++ show f
183 | Just (s, t) -> do s' <- typeOf' col ctx a
184 | if (Right s) == s' then pure $ Left t else Left $ "Expected argument to have entity " ++
185 | show s ++ " but given " ++ show s' ++ " in " ++ (show xx)
186 | typeOf' col ctx xx@(Sym f a) = case Map.lookup f $ csyms col of
187 | Nothing -> Left $ "Unknown function symbol: " ++ show f
188 | Just (s, t) -> do s' <- mapM (typeOf' col ctx) a
189 | if length s' == length s
190 | then if (Left <$> s) == s'
191 | then pure $ Left t
192 | else Left $ "Expected arguments to have types " ++
193 | show s ++ " but given " ++ show s' ++ " in " ++ (show $ xx)
194 | else Left $ "Expected argument to have arity " ++
195 | show (length s) ++ " but given " ++ show (length s') ++ " in " ++ (show $ xx)
196 |
197 | typeOfEq'
198 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
199 | => Collage var ty sym en fk att gen sk
200 | -> (Ctx var (ty + en), EQ var ty sym en fk att gen sk)
201 | -> Err (ty + en)
202 | typeOfEq' col (ctx, EQ (lhs, rhs)) = do
203 | lhs' <- typeOf' col ctx lhs
204 | rhs' <- typeOf' col ctx rhs
205 | if lhs' == rhs'
206 | then Right lhs'
207 | else Left $ "Equation lhs has type " ++ show lhs' ++ " but rhs has type " ++ show rhs'
208 |
209 | --------------------------------------------------------------------------------
210 |
211 | -- | Initialize a mapping of sorts to bools for sort inhabition check.
212 | initGround :: (Ord ty, Ord en) => Collage var ty sym en fk att gen sk -> (Map en Bool, Map ty Bool)
213 | initGround col = (me', mt')
214 | where
215 | me = Map.fromList $ fmap (\en -> (en, False)) $ Set.toList $ cens col
216 | mt = Map.fromList $ fmap (\ty -> (ty, False)) $ Set.toList $ ctys col
217 | me' = Prelude.foldr (\(_, en) m -> Map.insert en True m) me $ Map.toList $ cgens col
218 | mt' = Prelude.foldr (\(_, ty) m -> Map.insert ty True m) mt $ Map.toList $ csks col
219 |
220 | -- | Applies one layer of symbols to the sort to boolean inhabitation map.
221 | closeGround :: (Ord ty, Ord en) => Collage var ty sym en fk att gen sk -> (Map en Bool, Map ty Bool) -> (Map en Bool, Map ty Bool)
222 | closeGround col (me, mt) = (me', mt'')
223 | where
224 | mt''= Prelude.foldr (\(_, (tys,ty)) m -> if and ((!) mt' <$> tys) then Map.insert ty True m else m) mt' $ Map.toList $ csyms col
225 | mt' = Prelude.foldr (\(_, (en, ty)) m -> if (!) me' en then Map.insert ty True m else m) mt $ Map.toList $ catts col
226 | me' = Prelude.foldr (\(_, (en, _ )) m -> if (!) me en then Map.insert en True m else m) me $ Map.toList $ cfks col
227 |
228 | -- | Does a fixed point of closeGround.
229 | iterGround :: (MultiTyMap '[Show, Ord, NFData] '[ty, en]) => Collage var ty sym en fk att gen sk -> (Map en Bool, Map ty Bool) -> (Map en Bool, Map ty Bool)
230 | iterGround col r = if r == r' then r else iterGround col r'
231 | where r' = closeGround col r
232 |
233 | -- | Gets the inhabitation map for the sorts of a collage.
234 | computeGround :: (MultiTyMap '[Show, Ord, NFData] '[ty, en]) => Collage var ty sym en fk att gen sk -> (Map en Bool, Map ty Bool)
235 | computeGround col = iterGround col $ initGround col
236 |
237 | -- | True iff all sorts in a collage are inhabited.
238 | allSortsInhabited :: (MultiTyMap '[Show, Ord, NFData] '[ty, en]) => Collage var ty sym en fk att gen sk -> Bool
239 | allSortsInhabited col = t && f
240 | where (me, mt) = computeGround col
241 | t = and $ Map.elems me
242 | f = and $ Map.elems mt
243 |
--------------------------------------------------------------------------------
/src/Language/CQL/Instance/Algebra.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE AllowAmbiguousTypes #-}
22 | {-# LANGUAGE DataKinds #-}
23 | {-# LANGUAGE DuplicateRecordFields #-}
24 | {-# LANGUAGE ExplicitForAll #-}
25 | {-# LANGUAGE FlexibleContexts #-}
26 | {-# LANGUAGE FlexibleInstances #-}
27 | {-# LANGUAGE GADTs #-}
28 | {-# LANGUAGE KindSignatures #-}
29 | {-# LANGUAGE LiberalTypeSynonyms #-}
30 | {-# LANGUAGE MultiParamTypeClasses #-}
31 | {-# LANGUAGE RankNTypes #-}
32 | {-# LANGUAGE ScopedTypeVariables #-}
33 | {-# LANGUAGE StandaloneDeriving #-}
34 | {-# LANGUAGE TupleSections #-}
35 | {-# LANGUAGE TypeOperators #-}
36 | {-# LANGUAGE TypeSynonymInstances #-}
37 | {-# LANGUAGE UndecidableInstances #-}
38 |
39 | module Language.CQL.Instance.Algebra where
40 |
41 | import Control.DeepSeq
42 | import Control.Monad
43 | import qualified Data.Foldable as Foldable
44 | import Data.List as List hiding (intercalate)
45 | import Data.Map.Strict (Map, (!))
46 | import qualified Data.Map.Strict as Map
47 | import Data.Set (Set)
48 | import qualified Data.Set as Set
49 | import Data.Void
50 | import Language.CQL.Common (intercalate, mapl, section, MultiTyMap, TyMap, type (+))
51 | import Language.CQL.Schema as Schema
52 | import Language.CQL.Term (EQ, Head(HSk), Term(..), subst, upp, replaceRepeatedly, simplifyTheory)
53 | import Language.CQL.Typeside as Typeside
54 | import Prelude hiding (EQ)
55 | import qualified Text.Tabular as T
56 | import qualified Text.Tabular.AsciiArt as Ascii
57 |
58 |
59 | -- | An algebra (model) of a 'Schema'.
60 | --
61 | -- * For entities, consists of a carrier set, evaluation function @nf@, and its "inverse" @repr@.
62 | --
63 | -- * For types, consists of a generating set of labelled nulls, evaluation function @nf'@, and its "inverse" @repr'@,
64 | -- as well as a set of equations (the so-called type algebra).
65 | --
66 | -- The @Eq@ instance is not defined because for now we define instance equality to be based on equations.
67 | --
68 | -- @x@: type of Carrier
69 | -- @y@: type of generators for type algebra presentation
70 | data Algebra var ty sym en fk att gen sk x y
71 | = Algebra
72 | { aschema :: Schema var ty sym en fk att
73 |
74 | , en :: en -> Set x -- globally unique xs
75 | , aGen :: gen -> x
76 | , aFk :: fk -> x -> x
77 | , repr :: x -> Term Void Void Void en fk Void gen Void
78 |
79 | , ty :: ty -> Set y -- globally unique ys
80 | , nf' :: sk + (x, att) -> Term Void ty sym Void Void Void Void y
81 | , repr' :: y -> Term Void ty sym en fk att gen sk
82 |
83 | , teqs :: Set (EQ Void ty sym Void Void Void Void y)
84 | }
85 |
86 | instance (NFData var, NFData ty, NFData sym, NFData en, NFData fk, NFData att, NFData x, NFData y)
87 | => NFData (Algebra var ty sym en fk att gen sk x y)
88 | where
89 | rnf (Algebra s0 e0 nf0 nf02 repr0 ty0 nf1 repr1 eqs1) =
90 | deepseq s0 $ f e0 $ deepseq nf0 $ deepseq repr0 $ w ty0 $ deepseq nf1 $ deepseq repr1 $ deepseq nf02 $ rnf eqs1
91 | where
92 | f g = deepseq (Set.map (rnf . g) $ Schema.ens s0)
93 | w g = deepseq (Set.map (rnf . g) $ tys (typeside s0))
94 |
95 | -- | Evaluate an entity-side schema term with one free variable, given a value for that variable.
96 | evalSchTerm' :: Algebra var ty sym en fk att gen sk x y -> x -> Term () Void Void en fk Void Void Void -> x
97 | evalSchTerm' alg x term = case term of
98 | Var _ -> x
99 | Fk f a -> aFk alg f $ evalSchTerm' alg x a
100 | Gen g -> absurd g
101 | Sk g -> absurd g
102 | Sym f _ -> absurd f
103 | Att f _ -> absurd f
104 |
105 | -- | Evaluate a type-side schema term with one free variable, given a value for that variable.
106 | evalSchTerm :: Algebra var ty sym en fk att gen sk x y -> x -> Term () ty sym en fk att Void Void
107 | -> Term Void ty sym Void Void Void Void y
108 | evalSchTerm alg x term = case term of
109 | Att f a -> aAtt alg f $ evalSchTerm' alg x $ down1 a
110 | Sk g -> absurd g
111 | Sym f as -> Sym f $ fmap (evalSchTerm alg x) as
112 | _ -> error "Impossibility in evalSchTerm, please report. Given a term of non-type sort."
113 |
114 | -- | Helper to convert terms in the 'Collage' of entity sort into terms with 'Void's in the attribute etc slots.
115 | -- Morally, 'Collage' should store two or more classes of equation, but having to convert like this is relatively rare.
116 | -- Indeed, 'IP.satisfiesSchema' itself is redundant; a properly functioning CQL would not generate unsatisfying
117 | -- instances.
118 | down1
119 | :: Term x ty sym en fk att gen sk
120 | -> Term x Void Void en fk Void gen Void
121 | down1 (Var v) = Var v
122 | down1 (Gen g) = Gen g
123 | down1 (Fk f a) = Fk f (down1 a)
124 | down1 _ = error "Anomaly: please report. Function name: down1."
125 |
126 |
127 |
128 | -- | Evaluates a type side term to a term in the type algebra. Crashes if given a term of entity sort.
129 | nf'' :: Algebra var ty sym en fk att gen sk x y -> Term Void ty sym en fk att gen sk -> Term Void ty sym Void Void Void Void y
130 | nf'' alg t = case t of
131 | Sym f as -> Sym f (nf'' alg <$> as)
132 | Att f a -> nf' alg $ Right (nf alg (down1 a), f)
133 | Sk s -> nf' alg $ Left s
134 | _ -> error "Impossible, please report. Non typeside term passed to nf''."
135 |
136 | -- | Evaluates a entity side term to a carrier. Crashes if given a term of type sort.
137 | nf :: Algebra var ty sym en fk att gen sk x y -> Term Void ty' sym' en fk att' gen sk' -> x
138 | nf alg (Gen g ) = aGen alg g
139 | nf alg (Fk f a) = aFk alg f $ nf alg a
140 | nf _ _ = error "Impossible, error in nf"
141 |
142 | -- | "Reverse evaluates" a type algebra term to a term in instance.
143 | repr'' :: Algebra var ty sym en fk att gen sk x y -> Term Void ty sym Void Void Void Void y -> Term Void ty sym en fk att gen sk
144 | repr'' alg t = case t of
145 | Sym f as -> Sym f (repr'' alg <$> as)
146 | Sk s -> repr' alg s
147 | Gen g -> absurd g
148 | Att a _ -> absurd a
149 | Fk f _ -> absurd f
150 | Var v -> absurd v
151 |
152 | -- | Evaluates an attribute on a value.
153 | aAtt :: Algebra var ty sym en fk att gen sk x y -> att -> x -> Term Void ty sym Void Void Void Void y
154 | aAtt alg f x = nf'' alg $ Att f $ upp $ repr alg x
155 |
156 | -- | Evaluates a labelled null.
157 | aSk :: Algebra var ty sym en fk att gen sk x y -> sk -> Term Void ty sym Void Void Void Void y
158 | aSk alg g = nf'' alg $ Sk g
159 |
160 |
161 | ---------------------------------------------------------------------------------------------------------------
162 | -- Initial algebras
163 |
164 | -- | The carrier for the initial algebra of an instance; they are just terms.
165 | -- Made into a separate type so this could be changed; cql-java for example just uses natural numbers as the carrier.
166 | -- TODO should be called ETerm, for 'entity term'.
167 | type Carrier en fk gen = Term Void Void Void en fk Void gen Void
168 |
169 | -- | The generating labelled nulls for the type algebra of the associated instance.
170 | newtype TalgGen en fk att gen sk = MkTalgGen (Either sk (Carrier en fk gen, att))
171 |
172 | -- | Inlines type-algebra equations of the form @gen = term@.
173 | -- The hard work is delegated to functions from the 'Term' module.
174 | simplify
175 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk, x, y])
176 | => Algebra var ty sym en fk att gen sk x y
177 | -> Algebra var ty sym en fk att gen sk x y
178 | simplify
179 | (Algebra sch en' nf''' nf'''2 repr''' ty' nf'''' repr'''' teqs' ) =
180 | Algebra sch en' nf''' nf'''2 repr''' ty'' nf''''' repr'''' teqs''''
181 | where
182 | teqs'' = Set.map (\x -> (Map.empty, x)) teqs'
183 | (teqs''', f) = simplifyTheory teqs'' []
184 | teqs'''' = Set.map snd teqs'''
185 | ty'' t = Set.filter (\x -> notElem (HSk x) $ map fst f) $ ty' t
186 | nf''''' e = replaceRepeatedly f $ nf'''' e
187 |
188 | instance TyMap NFData '[en, fk, att, gen, sk] => NFData (TalgGen en fk att gen sk) where
189 | rnf (MkTalgGen x) = rnf x
190 |
191 | instance TyMap Show '[en, fk, att, gen, sk] => Show (TalgGen en fk att gen sk) where
192 | show (MkTalgGen (Left x)) = show x
193 | show (MkTalgGen (Right x)) = show x
194 |
195 | deriving instance TyMap Ord '[en, fk, att, gen, sk] => Ord (TalgGen en fk att gen sk)
196 |
197 | deriving instance TyMap Eq '[fk, att, gen, sk] => Eq (TalgGen en fk att gen sk)
198 |
199 | ---------------------------------------------------------------------------------------------------------------
200 | -- Functorial data migration
201 |
202 | changeEn
203 | :: (Ord k1, Ord k2, Eq var)
204 | => Map k1 (Term () Void Void en1 fk Void Void Void)
205 | -> Map k2 (Term () ty1 sym en1 fk att Void Void)
206 | -> Term Void ty2 sym en2 k1 k2 gen sk
207 | -> Term var ty1 sym en1 fk att gen sk
208 | changeEn fks' atts' t = case t of
209 | Var v -> absurd v
210 | Sym h as -> Sym h $ changeEn fks' atts' <$> as
211 | Sk k -> Sk k
212 | Gen g -> Gen g
213 | Fk h a -> subst (upp $ fks' ! h) $ changeEn fks' atts' a
214 | Att h a -> subst (upp $ atts' ! h) $ changeEn fks' atts' a
215 |
216 | changeEn'
217 | :: (Ord k, Eq var)
218 | => Map k (Term () Void Void en1 fk Void Void Void)
219 | -> t
220 | -> Term Void ty1 Void en2 k Void gen Void
221 | -> Term var ty2 sym en1 fk att gen sk
222 | changeEn' fks' atts' t = case t of
223 | Var v -> absurd v
224 | Sym h _ -> absurd h
225 | Sk k -> absurd k
226 | Gen g -> Gen g
227 | Fk h a -> subst (upp $ fks' ! h) $ changeEn' fks' atts' a
228 | Att h _ -> absurd h
229 |
230 | mapGen :: (t1 -> t2) -> Term var ty sym en (t2 -> t2) att t1 sk -> t2
231 | mapGen f (Gen g) = f g
232 | mapGen f (Fk fk a) = fk $ mapGen f a
233 | mapGen _ _ = error "please report, error on mapGen"
234 |
235 |
236 | -------------------------------------------------------------------------------------------------------------------
237 | -- Printing
238 |
239 | instance (TyMap Show '[var, ty, sym, en, fk, att, gen, sk, x, y], Eq en, Eq fk, Eq att)
240 | => Show (Algebra var ty sym en fk att gen sk x y) where
241 | show alg@(Algebra sch _ _ _ _ ty' _ _ teqs') =
242 | unlines $
243 | [ section "entities" $ unlines prettyEntities
244 | , section "type-algebra" $ intercalate "\n" prettyTypeEqns
245 | , section "nulls" $ intercalate "\n" w
246 | ]
247 | where
248 | w = mapl w2 . Typeside.tys . Schema.typeside $ sch
249 | w2 ty'' = show ty'' ++ " (" ++ (show . Set.size $ ty' ty'') ++ ") = " ++ show (Foldable.toList $ ty' ty'') ++ " "
250 | prettyEntities = prettyEntityTable alg `mapl` Schema.ens sch
251 | prettyTypeEqns = Set.map show teqs'
252 |
253 | prettyEntity
254 | :: forall var ty sym en fk att gen sk x y
255 | . (TyMap Show '[ty, sym, en, fk, att, x, y], Eq en)
256 | => Algebra var ty sym en fk att gen sk x y
257 | -> en
258 | -> String
259 | prettyEntity alg@(Algebra sch en' _ _ _ _ _ _ _) es =
260 | show es ++ " (" ++ (show . Set.size $ en' es) ++ ")\n" ++
261 | "--------------------------------------------------------------------------------\n" ++
262 | intercalate "\n" (prettyEntityRow es `mapl` en' es)
263 | where
264 | prettyEntityRow :: en -> x -> String
265 | prettyEntityRow en'' e =
266 | show e ++ ": " ++
267 | intercalate "," (prettyFk e <$> fksFrom' sch en'') ++ ", " ++
268 | intercalate "," (prettyAtt e <$> attsFrom' sch en'')
269 |
270 | prettyAtt :: x -> (att, w) -> String
271 | prettyAtt x (att,_) = show att ++ " = " ++ prettyTerm (aAtt alg att x)
272 | prettyFk x (fk, _) = show fk ++ " = " ++ show (aFk alg fk x)
273 | prettyTerm = show
274 |
275 | -- TODO unquote identifiers; stick fks and attrs in separate `Group`s?
276 | prettyEntityTable
277 | :: forall var ty sym en fk att gen sk x y
278 | . (TyMap Show '[ty, sym, en, fk, att, x, y], Eq en)
279 | => Algebra var ty sym en fk att gen sk x y
280 | -> en
281 | -> String
282 | prettyEntityTable alg@(Algebra sch en' _ _ _ _ _ _ _) es =
283 | show es ++ " (" ++ show (Set.size (en' es)) ++ ")\n" ++
284 | Ascii.render show id id tbl
285 | where
286 | tbl :: T.Table x String String
287 | tbl = T.Table
288 | (T.Group T.SingleLine (T.Header <$> Foldable.toList (en' es)))
289 | (T.Group T.SingleLine (T.Header <$> prettyColumnHeaders))
290 | (prettyRow <$> Foldable.toList (en' es))
291 |
292 | prettyColumnHeaders :: [String]
293 | prettyColumnHeaders =
294 | (prettyTypedIdent <$> fksFrom' sch es) ++
295 | (prettyTypedIdent <$> attsFrom' sch es)
296 |
297 | prettyRow e =
298 | (prettyFk e <$> fksFrom' sch es) ++ (prettyAtt e <$> attsFrom' sch es)
299 |
300 | prettyTypedIdent (ident, typ) = show ident ++ " : " ++ show typ
301 |
302 | prettyFk x (fk, _) = show $ aFk alg fk x
303 |
304 | prettyAtt :: x -> (att, ty) -> String
305 | prettyAtt x (att,_) = prettyTerm $ aAtt alg att x
306 |
307 | prettyTerm = show
308 |
--------------------------------------------------------------------------------
/src/Language/CQL/Prover.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE AllowAmbiguousTypes #-}
22 | {-# LANGUAGE DataKinds #-}
23 | {-# LANGUAGE DuplicateRecordFields #-}
24 | {-# LANGUAGE ExplicitForAll #-}
25 | {-# LANGUAGE FlexibleContexts #-}
26 | {-# LANGUAGE FlexibleInstances #-}
27 | {-# LANGUAGE GADTs #-}
28 | {-# LANGUAGE ImpredicativeTypes #-}
29 | {-# LANGUAGE InstanceSigs #-}
30 | {-# LANGUAGE LiberalTypeSynonyms #-}
31 | {-# LANGUAGE MultiParamTypeClasses #-}
32 | {-# LANGUAGE RankNTypes #-}
33 | {-# LANGUAGE ScopedTypeVariables #-}
34 | {-# LANGUAGE TypeOperators #-}
35 | {-# LANGUAGE TypeSynonymInstances #-}
36 | {-# LANGUAGE UndecidableInstances #-}
37 |
38 | module Language.CQL.Prover where
39 |
40 | import Control.DeepSeq
41 | import Data.List
42 | import Data.Map
43 | import Data.Maybe
44 | import Data.Rewriting.CriticalPair as CP
45 | import Data.Rewriting.Rule as R
46 | import Data.Rewriting.Rules as Rs
47 | import Data.Rewriting.Term as T
48 | import Data.Set as Set
49 | import Language.CQL.Common
50 | import Language.CQL.Collage as Collage (simplify)
51 | import Language.CQL.Collage
52 | import Language.CQL.Options as O hiding (Prover)
53 | import Language.CQL.Term as S
54 | import Prelude hiding (EQ)
55 | import Twee as Twee
56 | import Twee.Base as TweeBase
57 | import Twee.Equation as TweeEq
58 | import qualified Twee.KBO as KBO
59 | import Twee.Proof as TweeProof hiding (defaultConfig)
60 | import Data.Map.Strict as Map
61 | import Data.Typeable
62 | import Language.CQL.Congruence as Cong
63 | import Language.CQL.Internal (Term)
64 |
65 |
66 |
67 | -- Theorem proving ------------------------------------------------
68 |
69 | data ProverName = Free | Congruence | Orthogonal | Completion | Auto
70 | deriving Show
71 |
72 | proverStringToName :: Options -> Err ProverName
73 | proverStringToName m = case sOps m prover_name of
74 | "auto" -> pure Auto
75 | "completion" -> pure Completion
76 | "program" -> pure Orthogonal
77 | "congruence" -> pure Congruence
78 | x -> Left $ "Not a prover: " ++ x
79 |
80 | -- | A decision procedure for equality of terms in a collage.
81 | data Prover var ty sym en fk att gen sk = Prover
82 | { collage :: Collage var ty sym en fk att gen sk
83 | , prove :: Ctx var (ty+en) -> EQ var ty sym en fk att gen sk -> Bool
84 | }
85 |
86 | -- | Create a prover from a collage and user-provided options.
87 | createProver
88 | :: (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym, en, fk, att, gen, sk])
89 | => Collage var ty sym en fk att gen sk
90 | -> Options
91 | -> Err (Prover var ty sym en fk att gen sk)
92 | createProver col ops = do
93 | p <- proverStringToName ops
94 | case p of
95 | Free -> freeProver col
96 | Orthogonal -> orthProver col ops
97 | Auto -> if Set.null (ceqs col) && eqsAreGround col
98 | then congProver col
99 | else orthProver col ops
100 | Completion -> kbProver col ops
101 | Congruence -> congProver col
102 |
103 | -------------------------------------------------------------------------------------------
104 |
105 | -- | For theories with no equations, syntactic equality works.
106 | freeProver
107 | :: TyMap Eq '[var, sym, fk, att, gen, sk]
108 | => Collage var ty sym en fk att gen sk
109 | -> Either String (Prover var ty sym en fk att gen sk)
110 | freeProver col | Set.size (ceqs col) == 0 = return $ Prover col p
111 | | otherwise = Left "Cannot use free prover when there are equations"
112 | where
113 | p _ (EQ (lhs', rhs')) = lhs' == rhs'
114 |
115 | -------------------------------------------------------------------------------------------
116 |
117 | -- | A prover for weakly orthogonal theories: http://hackage.haskell.org/package/term-rewriting.
118 | -- We must have size reducing equations of the form lhs -> rhs
119 | -- without empty sorts and without non-trivial critical pairs (rule overlaps).
120 | -- Runs the rules non deterministically to get a unique normal form.
121 | orthProver
122 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
123 | => Collage var ty sym en fk att gen sk
124 | -> Options
125 | -> Err (Prover var ty sym en fk att gen sk)
126 | orthProver col ops = if isDecreasing eqs1 || allow_nonTerm
127 | then if nonConOk || noOverlaps eqs2
128 | then if allSortsInhabited col || allow_empty
129 | then let p' ctx (EQ (l, r)) = p ctx $ EQ (replaceRepeatedly f l, replaceRepeatedly f r)
130 | in pure $ Prover col p'
131 | else Left "Rewriting Error: contains uninhabited sorts"
132 | else Left $ "Rewriting Error: not orthogonal. Pairs are " ++ show (findCps eqs2)
133 | else Left "Rewriting Error: not size decreasing"
134 | where
135 | (col', f) = Collage.simplify col
136 |
137 | p _ (EQ (lhs', rhs')) = nf (convert' lhs') == nf (convert' rhs')
138 |
139 | eqs1 = Prelude.map snd $ Set.toList $ ceqs col'
140 | eqs2 = Prelude.map convert'' eqs1
141 |
142 | nf x = case outerRewrite eqs2 x of
143 | [] -> x
144 | y:_ -> nf $ result y
145 |
146 | allow_nonTerm = bOps ops Program_Allow_Nontermination_Unsafe
147 | allow_empty = bOps ops Allow_Empty_Sorts_Unsafe
148 | nonConOk = bOps ops Program_Allow_Nonconfluence_Unsafe
149 | convert'' (EQ (lhs', rhs')) = Rule (convert' lhs') (convert' rhs')
150 |
151 | -- | Gets the non-reflexive critical pairs
152 | findCps :: (Eq f, Ord v') => [Rule f v'] -> [(R.Term f (Either v' v'), R.Term f (Either v' v'))]
153 | findCps x = Prelude.map (\y -> (CP.left y, CP.right y)) $ Prelude.filter g $ cps' x
154 | where
155 | g q = not $ (CP.left q) == (CP.right q)
156 |
157 | noOverlaps :: (Ord v, Eq f) => [Rule f v] -> Bool
158 | noOverlaps x = all R.isLeftLinear x && Prelude.null (findCps x)
159 |
160 | isDecreasing :: Eq var => [EQ var ty sym en fk att gen sk] -> Bool
161 | isDecreasing [] = True
162 | isDecreasing (EQ (lhs', rhs') : tl) = S.size lhs' > S.size rhs' && isDecreasing tl && moreOnLhs (S.vars lhs') (S.vars rhs')
163 | where
164 | moreOnLhs lvars rvars = and $ fmap (\r -> count lvars r >= count rvars r) rvars
165 | count [] _ = 0
166 | count (a:b) x = count b x + if a == x then 1 else 0 :: Integer
167 |
168 | convert' :: S.Term var ty sym en fk att gen sk -> T.Term (Head ty sym en fk att gen sk) var
169 | convert' x = case x of
170 | S.Var v -> T.Var v
171 | S.Gen g -> T.Fun (HGen g) []
172 | S.Sk g -> T.Fun (HSk g) []
173 | S.Att g a -> T.Fun (HAtt g) [convert' a]
174 | S.Fk g a -> T.Fun (HFk g) [convert' a]
175 | S.Sym g as -> T.Fun (HSym g) $ Prelude.map convert' as
176 |
177 | ----------------------------------------------------------------------------------------------
178 | -- for arbitrary theories: http://hackage.haskell.org/package/twee
179 |
180 | data Constant x = Constant
181 | { con_prec :: !Precedence
182 | , con_id :: !x
183 | , con_arity :: !Int
184 | , con_size :: !Int
185 | , con_bonus :: !(Maybe (Maybe Bool))
186 | } deriving (Eq, Ord)
187 |
188 | instance Sized (Constant x) where
189 | size (Constant _ _ _ y _) = y
190 |
191 | instance Arity (Constant x) where
192 | arity (Constant _ _ y _ _) = y
193 |
194 | instance Show x => Pretty (Constant x) where
195 | pPrint (Constant _ y _ _ _) = text $ show y
196 |
197 | instance Show x => PrettyTerm (Constant x) where
198 |
199 | instance (Show x, Ord x, Typeable x) => Ordered (Extended (Constant x)) where
200 | lessEq = KBO.lessEq
201 | lessIn = KBO.lessIn
202 |
203 | instance EqualsBonus (Constant x) where
204 | hasEqualsBonus = isJust . con_bonus
205 | isEquals = isNothing . fromJust . con_bonus
206 | isTrue = fromJust . fromJust . con_bonus
207 | isFalse = fromJust . fromJust . con_bonus
208 |
209 | data Precedence = Precedence !Bool !(Maybe Int) !Int
210 | deriving (Eq, Ord)
211 |
212 | prec
213 | :: (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym, en, fk, att, gen, sk])
214 | => Collage var ty sym en fk att gen sk
215 | -> Head ty sym en fk att gen sk
216 | -> Precedence
217 | prec col c = Precedence p q r -- trace (show (p,q,r)) $
218 | where
219 | prec' = [] --[show "I", show "o", show "e"] -- for now
220 | p = isNothing $ elemIndex (show c) prec'
221 | q = fmap negate (elemIndex (show c) prec')
222 | r = negate (Map.findWithDefault 0 c $ occs col)
223 |
224 | toTweeConst
225 | :: (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym, en, fk, att, gen, sk])
226 | => Collage var ty sym en fk att gen sk
227 | -> Head ty sym en fk att gen sk
228 | -> Constant (Head ty sym en fk att gen sk)
229 | toTweeConst col c = Constant (prec col c) c arr sz Nothing
230 | where
231 | sz = 1 -- for now
232 | arr = case c of
233 | HGen _ -> 0
234 | HSk _ -> 0
235 | HAtt _ -> 1
236 | HFk _ -> 1
237 | HSym s -> length $ fst $ (csyms col) ! s
238 |
239 | convert
240 | :: (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym, en, fk, att, gen, sk])
241 | => Collage var ty sym en fk att gen sk
242 | -> Ctx var (ty+en)
243 | -> S.Term var ty sym en fk att gen sk
244 | -> TweeBase.Term (Extended (Constant (Head ty sym en fk att gen sk)))
245 | convert col ctx x = case x of
246 | S.Var v -> build $ var $ V (fromJust $ elemIndex v $ keys ctx)
247 | S.Gen g -> build $ con (fun $ TweeBase.Function $ toTweeConst col $ HGen g)
248 | S.Sk g -> build $ con (fun $ TweeBase.Function $ toTweeConst col $ HSk g)
249 | S.Att g a -> build $ app (fun $ TweeBase.Function $ toTweeConst col $ HAtt g) [convert col ctx a]
250 | S.Fk g a -> build $ app (fun $ TweeBase.Function $ toTweeConst col $ HFk g) [convert col ctx a]
251 | S.Sym g as -> build $ app (fun $ TweeBase.Function $ toTweeConst col $ HSym g) $ fmap (convert col ctx) as
252 |
253 | initState
254 | :: forall var ty sym en fk att gen sk
255 | . (MultiTyMap '[Show, Ord, Typeable, NFData] '[ var, ty, sym, en, fk, att, gen, sk])
256 | => Collage var ty sym en fk att gen sk
257 | -> State (Extended (Constant (Head ty sym en fk att gen sk)))
258 | initState col = Set.foldr (\z s -> addAxiom defaultConfig s (toAxiom z)) initialState $ ceqs col
259 | where
260 | toAxiom :: (Ctx var (ty+en), EQ var ty sym en fk att gen sk) -> Axiom (Extended (Constant (Head ty sym en fk att gen sk)))
261 | toAxiom (ctx, EQ (lhs0, rhs0)) = Axiom 0 "" $ convert col ctx lhs0 :=: convert col ctx rhs0
262 |
263 | -- | Does Knuth-Bendix completion. Attempts to orient equations into rewrite rules
264 | -- lhs -> rhs where the lhs is larger than the rhs, adding additional equations whenever
265 | -- critical pairs (rule overlaps) are detected.
266 | kbProver
267 | :: forall var ty sym en fk att gen sk
268 | . (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym, en, fk, att, gen, sk])
269 | => Collage var ty sym en fk att gen sk
270 | -> Options
271 | -> Err (Prover var ty sym en fk att gen sk)
272 | kbProver col ops =
273 | if allSortsInhabited col || allow_empty
274 | then let p' ctx (EQ (l, r)) = p ctx $ EQ (replaceRepeatedly f l, replaceRepeatedly f r)
275 | in pure $ Prover col p'
276 | else Left "Completion Error: contains uninhabited sorts"
277 | where
278 | (col', f) = Collage.simplify col
279 | p ctx (EQ (lhs', rhs')) = normaliseTerm (completed ctx lhs' rhs') (convert col ctx lhs') == normaliseTerm (completed ctx lhs' rhs') (convert col ctx rhs')
280 | completed g l r = completePure defaultConfig $ addGoal defaultConfig (initState col') (toGoal g l r)
281 | allow_empty = bOps ops Allow_Empty_Sorts_Unsafe
282 |
283 | toGoal :: Ctx var (ty+en) -> S.Term var ty sym en fk att gen sk -> S.Term var ty sym en fk att gen sk -> Goal (Extended (Constant (Head ty sym en fk att gen sk)))
284 | toGoal ctx lhs0 rhs0 = goal 0 "" $ convert col ctx lhs0 :=: convert col ctx rhs0
285 |
286 | -------------------------------------------------------------------------------------------
287 | -- for ground theories
288 |
289 | -- | A Nelson-Oppen style decision procedure for ground (variable-free) theories. Its unclear
290 | -- how much of the congruence graph gets preserved between calls; the code we have could re-run
291 | -- building the congruence graph on each call to eq.
292 | congProver
293 | :: (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym, en, fk, att, gen, sk])
294 | => Collage var ty sym en fk att gen sk
295 | -> Err (Prover var ty sym en fk att gen sk)
296 | congProver col = if eqsAreGround col'
297 | then let prv _ (EQ (l, r)) = doProof (replaceRepeatedly f l) (replaceRepeatedly f r)
298 | in pure $ Prover col' prv
299 | else Left "Congruence Error: Not ground"
300 | where
301 | hidden = decide rules'
302 | rules' = fmap (\(_, EQ (l, r)) -> (convertCong l, convertCong r)) $ Set.toList $ ceqs col
303 | doProof l r = hidden (convertCong l) (convertCong r)
304 | (col', f) = Collage.simplify col
305 |
306 | convertCong
307 | :: (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym, en, fk, att, gen, sk])
308 | => S.Term var ty sym en fk att gen sk
309 | -> Language.CQL.Internal.Term (Head ty sym en fk att gen sk)
310 | convertCong x = case x of
311 | S.Var _ -> error "Anomaly, please report. Congruence conversion received variable."
312 | S.Gen g -> Cong.Function (HGen g) []
313 | S.Sk g -> Cong.Function (HSk g) []
314 | S.Att g a -> Cong.Function (HAtt g) [convertCong a]
315 | S.Fk g a -> Cong.Function (HFk g) [convertCong a]
316 | S.Sym g as -> Cong.Function (HSym g) $ fmap convertCong as
317 |
--------------------------------------------------------------------------------
/src/Language/CQL/Schema.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE AllowAmbiguousTypes #-}
22 | {-# LANGUAGE DataKinds #-}
23 | {-# LANGUAGE DuplicateRecordFields #-}
24 | {-# LANGUAGE ExplicitForAll #-}
25 | {-# LANGUAGE FlexibleContexts #-}
26 | {-# LANGUAGE FlexibleInstances #-}
27 | {-# LANGUAGE GADTs #-}
28 | {-# LANGUAGE ImpredicativeTypes #-}
29 | {-# LANGUAGE InstanceSigs #-}
30 | {-# LANGUAGE KindSignatures #-}
31 | {-# LANGUAGE LiberalTypeSynonyms #-}
32 | {-# LANGUAGE MultiParamTypeClasses #-}
33 | {-# LANGUAGE RankNTypes #-}
34 | {-# LANGUAGE ScopedTypeVariables #-}
35 | {-# LANGUAGE StandaloneDeriving #-}
36 | {-# LANGUAGE TypeOperators #-}
37 | {-# LANGUAGE TypeSynonymInstances #-}
38 | {-# LANGUAGE UndecidableInstances #-}
39 |
40 | module Language.CQL.Schema where
41 |
42 | import Control.Arrow ((***))
43 | import Control.DeepSeq
44 | import Data.Bifunctor (second)
45 | import Data.List (nub)
46 | import Data.Map.Strict as Map
47 | import Data.Maybe
48 | import Data.Set as Set
49 | import Data.Typeable
50 | import Data.Void
51 |
52 | import Language.CQL.Collage (Collage(..), typeOfCol)
53 | import Language.CQL.Common
54 | import Language.CQL.Options
55 | import Language.CQL.Prover
56 | import Language.CQL.Term
57 | import Language.CQL.Typeside
58 | -- cyclic import Language.CQL.Instance
59 | import Prelude hiding (EQ)
60 |
61 |
62 | data Schema var ty sym en fk att
63 | = Schema
64 | { typeside :: Typeside var ty sym
65 | , ens :: Set en
66 | , fks :: Map fk (en, en)
67 | , atts :: Map att (en, ty)
68 | , path_eqs :: Set (en, EQ () Void Void en fk Void Void Void)
69 | , obs_eqs :: Set (en, EQ () ty sym en fk att Void Void)
70 | , eq :: en -> EQ () ty sym en fk att Void Void -> Bool
71 | }
72 |
73 | instance TyMap NFData '[var, ty, sym, en, fk, att] => NFData (Schema var ty sym en fk att) where
74 | rnf (Schema tys0 ens0 fks0 atts0 p0 o0 e0) = deepseq tys0 $ deepseq ens0 $ deepseq fks0 $ deepseq atts0 $ deepseq p0 $ deepseq o0 $ rnf e0
75 |
76 | instance TyMap Eq '[var, ty, sym, en, fk, att]
77 | => Eq (Schema var ty sym en fk att) where
78 | (==) (Schema ts' ens' fks' atts' path_eqs' obs_eqs' _)
79 | (Schema ts'' ens'' fks'' atts'' path_eqs'' obs_eqs'' _)
80 | = (ens' == ens'') && (fks' == fks'') && (atts' == atts'')
81 | && (path_eqs' == path_eqs'') && (obs_eqs' == obs_eqs'')
82 | && (ts' == ts'')
83 |
84 | instance TyMap Show '[var, ty, sym, en, fk, att]
85 | => Show (Schema var ty sym en fk att) where
86 | show (Schema _ ens' fks' atts' path_eqs' obs_eqs' _) =
87 | section "schema" $ unlines
88 | [ section "entities" $ unlines $ show <$> Set.toList ens'
89 | , section "foreign_keys" $ unlines $ fks''
90 | , section "atts" $ unlines $ atts''
91 | , section "path_equations" $ unlines $ eqs'' path_eqs'
92 | , section "observation_equations " $ unlines $ eqs'' obs_eqs'
93 | ]
94 | where
95 | fks'' = (\(k,(s,t)) -> show k ++ " : " ++ show s ++ " -> " ++ show t) <$> Map.toList fks'
96 | atts'' = (\(k,(s,t)) -> show k ++ " : " ++ show s ++ " -> " ++ show t) <$> Map.toList atts'
97 | eqs'' x = (\(en,EQ (l,r)) -> "forall x : " ++ show en ++ " . " ++ show (mapTermVar (const "x") l) ++ " = " ++ show (mapTermVar (const "x") r)) <$> Set.toList x
98 |
99 | -- | Checks that the underlying theory is well-sorted.
100 | -- I.e. rule out "1" = one kind of errors.
101 | typecheckSchema
102 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att])
103 | => Schema var ty sym en fk att
104 | -> Err ()
105 | typecheckSchema = typeOfCol . toCollage
106 |
107 | -- | Converts a schema to a collage.
108 | toCollage
109 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att])
110 | => Schema var ty sym en fk att
111 | -> Collage (() + var) ty sym en fk att Void Void
112 | toCollage (Schema ts ens' fks' atts' path_eqs' obs_eqs' _) =
113 | Collage (eqs1 <> eqs2 <> eqs3) (ctys tscol) ens' (csyms tscol) fks' atts' Map.empty Map.empty
114 | where
115 | tscol = tsToCol ts
116 |
117 | eqs1 = Set.map (unitCtx *** fmap upp) path_eqs'
118 | eqs2 = Set.map (unitCtx *** fmap upp) obs_eqs'
119 | eqs3 = Set.map (up1Ctx *** fmap upp) (ceqs tscol)
120 |
121 | unitCtx en = Map.singleton (Left ()) (Right en)
122 |
123 | up1Ctx
124 | :: (Ord var)
125 | => Ctx var (ty+Void)
126 | -> Ctx (()+var) (ty+x)
127 | up1Ctx = (second absurd <$>) . Map.mapKeys Right
128 |
129 | typesideToSchema :: Typeside var ty sym -> Schema var ty sym Void Void Void
130 | typesideToSchema ts'' = Schema ts'' Set.empty Map.empty Map.empty Set.empty Set.empty $ \x _ -> absurd x
131 |
132 | fksFrom' :: (Eq en) => Schema var ty sym en fk att -> en -> [(fk,en)]
133 | fksFrom' sch en' = f $ Map.assocs $ fks sch
134 | where
135 | f [] = []
136 | f ((fk, (en1, t)):l) = if en1 == en' then (fk,t) : f l else f l
137 |
138 | attsFrom' :: Eq en => Schema var ty sym en fk att -> en -> [(att,ty)]
139 | attsFrom' sch en' = f $ Map.assocs $ atts sch
140 | where
141 | f [] = []
142 | f ((fk, (en1, t)):l) = if en1 == en' then (fk,t) : f l else f l
143 |
144 | -- | Accessor due to namespace conflicts.
145 | sch_fks :: Schema var ty sym en fk att -> Map fk (en, en)
146 | sch_fks = fks
147 |
148 | -- | Accessor due to namespace conflicts.
149 | sch_atts :: Schema var ty sym en fk att -> Map att (en, ty)
150 | sch_atts = atts
151 |
152 | ---------------------------------------------------------------------------------------------------
153 | -- Expressions
154 |
155 | data SchemaExp where
156 | SchemaVar :: String -> SchemaExp
157 | SchemaInitial :: TypesideExp -> SchemaExp
158 | SchemaCoProd :: SchemaExp -> SchemaExp -> SchemaExp
159 | SchemaRaw :: SchemaExpRaw' -> SchemaExp
160 | -- hold off for now, causes cyclic import
161 | -- SchemaPivot :: InstanceExp -> SchemaExp
162 | deriving (Eq,Show)
163 |
164 | getOptionsSchema :: SchemaExp -> [(String, String)]
165 | getOptionsSchema x = case x of
166 | SchemaVar _ -> []
167 | SchemaInitial _ -> []
168 | SchemaCoProd _ _ -> []
169 | SchemaRaw (SchemaExpRaw' _ _ _ _ _ _ o _) -> o
170 |
171 | instance Deps SchemaExp where
172 | deps x = case x of
173 | SchemaVar v -> [(v, SCHEMA)]
174 | SchemaInitial t -> deps t
175 | SchemaCoProd a b -> deps a ++ deps b
176 | SchemaRaw (SchemaExpRaw' t _ _ _ _ _ _ i) -> deps t ++ concatMap deps i
177 |
178 | data SchemaEx :: * where
179 | SchemaEx
180 | :: forall var ty sym en fk att . (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym, en, fk, att])
181 | => Schema var ty sym en fk att
182 | -> SchemaEx
183 |
184 | -- SchemaEx is an implementation detail, so hide its presence
185 | instance (Show SchemaEx) where
186 | show (SchemaEx i) = show i
187 |
188 | instance NFData SchemaEx where
189 | rnf (SchemaEx x) = rnf x
190 |
191 | ------------------------------------------------------------------------------------------------------
192 | -- Literals
193 |
194 | data SchemaExpRaw' = SchemaExpRaw'
195 | { schraw_ts :: TypesideExp
196 | , schraw_ens :: [String]
197 | , schraw_fks :: [(String, (String, String))]
198 | , schraw_atts :: [(String, (String, String))]
199 | , schraw_peqs :: [([String], [String])]
200 | , schraw_oeqs :: [(String, Maybe String, RawTerm, RawTerm)]
201 | , schraw_options :: [(String, String)]
202 | , schraw_imports :: [SchemaExp]
203 | } deriving (Eq, Show)
204 |
205 | -- | Type of entities for literal schemas.
206 | type En = String
207 |
208 | -- | Type of foreign keys for literal schemas.
209 | type Fk = String
210 |
211 | -- | Type of attributes for literal schemas.
212 | type Att = String
213 |
214 | -- | Evaluates a schema literal into a theory, but does not create the theorem prover.
215 | evalSchemaRaw'
216 | :: (Ord ty, Typeable ty, Ord sym, Typeable sym)
217 | => Typeside var ty sym -> SchemaExpRaw'
218 | -> [Schema var ty sym En Fk Att]
219 | -> Err (Schema var ty sym En Fk Att)
220 | evalSchemaRaw' x (SchemaExpRaw' _ ens'x fks'x atts'x peqs oeqs _ _) is = do
221 | ens'' <- return $ Set.fromList $ ie ++ ens'x
222 | fks'' <- toMapSafely $ fks'x ++ (concatMap (Map.toList . fks ) is)
223 | atts'2 <- convTys atts'x
224 | atts'' <- toMapSafely $ atts'2 ++ (concatMap (Map.toList . atts) is)
225 | peqs' <- procPeqs (Set.toList ens'') (Map.toList fks'' ) peqs
226 | oeqs' <- procOeqs (Map.toList fks'') (Map.toList atts'') oeqs
227 | return $ Schema x ens'' fks'' atts'' (Set.union ip peqs') (Set.union io oeqs') undefined --leave prover blank
228 | where
229 | ie = concatMap (Set.toList . ens) is
230 | ip = Set.fromList $ concatMap (Set.toList . path_eqs) is
231 | io = Set.fromList $ concatMap (Set.toList . obs_eqs ) is
232 |
233 | keys' = fmap fst
234 |
235 | procOeqs _ _ [] = pure $ Set.empty
236 | procOeqs fks' atts' ((v, en', lhs, rhs):eqs') = do
237 | en <- infer v en' (Map.fromList fks') (Map.fromList atts') lhs rhs
238 | _ <- return $ Map.fromList [((),en)]
239 | let lhs' = procTerm v (keys' fks') (keys' atts') lhs
240 | let rhs' = procTerm v (keys' fks') (keys' atts') rhs
241 | rest <- procOeqs fks' atts' eqs'
242 | if not $ hasTypeType'' lhs'
243 | then Left $ "Bad observation equation: " ++ show lhs ++ " == " ++ show rhs
244 | else pure $ Set.insert (en, EQ (lhs', rhs')) rest
245 |
246 | infer _ (Just t) _ _ _ _ = return t
247 | infer v _ fks' atts' lhs rhs = let
248 | t1s = nub $ typesOf v fks' atts' lhs
249 | t2s = nub $ typesOf v fks' atts' rhs
250 | in case (t1s, t2s) of
251 | ([t1] , [t2] ) -> if t1 == t2 then return t1 else Left $ "Type mismatch on " ++ show v ++ " in " ++ show lhs ++ " = " ++ show rhs ++ ", types are " ++ show t1 ++ " and " ++ show t2
252 | (t1 : t2 : _, _ ) -> Left $ "Conflicting types for " ++ show v ++ " in " ++ show lhs ++ ": " ++ show t1 ++ " and " ++ show t2
253 | (_ , t1 : t2 : _) -> Left $ "Conflicting types for " ++ show v ++ " in " ++ show rhs ++ ": " ++ show t1 ++ " and " ++ show t2
254 | ([] , [t] ) -> return t
255 | ([t] , [] ) -> return t
256 | ([] , [] ) -> Left $ "Untypeable variable: " ++ show v
257 |
258 | typesOf _ _ _ (RawApp _ []) = []
259 | typesOf v fks' atts' (RawApp f' [RawApp a []]) | a == v = case Map.lookup f' fks' of
260 | Nothing -> case Map.lookup f' atts' of
261 | Nothing -> []
262 | Just (s,_) -> [s]
263 | Just (s,_) -> [s]
264 | typesOf v fks' atts' (RawApp _ as) = concatMap (typesOf v fks' atts') as
265 |
266 | procTerm :: Typeable sym => String -> [String] -> [String] -> RawTerm -> Term () ty sym en Fk Att Void Void
267 | procTerm v _ _ (RawApp x' []) | v == x' = Var ()
268 | procTerm v fks''' atts''' (RawApp x' [a]) | x' `elem` fks''' = Fk x' $ procTerm v fks''' atts''' a
269 | procTerm v fks''' atts''' (RawApp x' [a]) | x' `elem` atts''' = Att x' $ procTerm v fks''' atts''' a
270 | procTerm u fks''' atts''' (RawApp v l) = let l' = Prelude.map (procTerm u fks''' atts''') l
271 | in case cast v of
272 | Just x'' -> Sym x'' l'
273 | Nothing -> error "impossible until complex typesides"
274 |
275 | procPath :: [String] -> [String] -> Term () Void Void En Fk Void Void Void
276 | procPath ens'' (s:ex) | s `elem` ens'' = procPath ens'' ex
277 | procPath ens'' (s:ex) | otherwise = Fk s $ procPath ens'' ex
278 | procPath _ [] = Var ()
279 |
280 | procPeqs _ _ [] = pure Set.empty
281 | procPeqs ens' fks' ((l,r):eqs') = do
282 | let lhs' = procPath ens' $ reverse l
283 | let rhs' = procPath ens' $ reverse r
284 | en <- findEn ens' fks' l
285 | _ <- return $ Map.fromList [((),en)]
286 | rest <- procPeqs ens' fks' eqs'
287 | _ <- if hasTypeType'' lhs'
288 | then Left $ "Bad path equation: " ++ show lhs' ++ " = " ++ show rhs'
289 | else pure $ Set.insert (en, EQ (lhs', rhs')) rest
290 | pure $ Set.insert (en, EQ (lhs', rhs')) rest
291 |
292 | findEn ens'' _ (s:_ ) | s `elem` ens'' = return s
293 | findEn _ fks'' (s:_ ) | Map.member s (Map.fromList fks'') = return $ fst $ fromJust $ Prelude.lookup s fks''
294 | findEn ens'' fks'' (_:ex) | otherwise = findEn ens'' fks'' ex
295 | findEn _ _ [] = Left "Path equation cannot be typed"
296 |
297 | convTys [] = return []
298 | convTys ((att, (en, ty)):tl) = case cast ty of
299 | Just ty' -> do
300 | xx <- convTys tl
301 | return $ (att, (en, ty')):xx
302 | Nothing -> Left $ "Not a type: " ++ show ty
303 |
304 | -- | Evaluate a typeside into a theory. Does not validate.
305 | evalSchemaRaw
306 | :: (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym])
307 | => Options
308 | -> Typeside var ty sym
309 | -> SchemaExpRaw'
310 | -> [SchemaEx]
311 | -> Err SchemaEx
312 | evalSchemaRaw ops ty t a' = do
313 | (a :: [Schema var ty sym En Fk Att]) <- doImports a'
314 | r <- evalSchemaRaw' ty t a
315 | o <- toOptions ops $ schraw_options t
316 | p <- createProver (toCollage r) o
317 | pure $ SchemaEx $ Schema ty (ens r) (fks r) (atts r) (path_eqs r) (obs_eqs r) (mkProver p)
318 | where
319 | mkProver p en (EQ (l,r)) = prove p (Map.fromList [(Left (),Right en)]) (EQ (upp l, upp r))
320 | doImports [] = return []
321 | doImports ((SchemaEx ts):r) = case cast ts of
322 | Nothing -> Left $ "Bad import" ++ show ts
323 | Just ts' -> do { r' <- doImports r ; return $ ts' : r' }
324 |
--------------------------------------------------------------------------------
/src/Language/CQL/Mapping.hs:
--------------------------------------------------------------------------------
1 | {-
2 | SPDX-License-Identifier: AGPL-3.0-only
3 |
4 | This file is part of `statebox/cql`, the categorical query language.
5 |
6 | Copyright (C) 2019 Stichting Statebox
7 |
8 | This program is free software: you can redistribute it and/or modify
9 | it under the terms of the GNU Affero General Public License as published by
10 | the Free Software Foundation, either version 3 of the License, or
11 | (at your option) any later version.
12 |
13 | This program is distributed in the hope that it will be useful,
14 | but WITHOUT ANY WARRANTY; without even the implied warranty of
15 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 | GNU Affero General Public License for more details.
17 |
18 | You should have received a copy of the GNU Affero General Public License
19 | along with this program. If not, see .
20 | -}
21 | {-# LANGUAGE AllowAmbiguousTypes #-}
22 | {-# LANGUAGE DataKinds #-}
23 | {-# LANGUAGE DuplicateRecordFields #-}
24 | {-# LANGUAGE ExplicitForAll #-}
25 | {-# LANGUAGE FlexibleContexts #-}
26 | {-# LANGUAGE FlexibleInstances #-}
27 | {-# LANGUAGE GADTs #-}
28 | {-# LANGUAGE ImpredicativeTypes #-}
29 | {-# LANGUAGE InstanceSigs #-}
30 | {-# LANGUAGE KindSignatures #-}
31 | {-# LANGUAGE LiberalTypeSynonyms #-}
32 | {-# LANGUAGE MultiParamTypeClasses #-}
33 | {-# LANGUAGE RankNTypes #-}
34 | {-# LANGUAGE ScopedTypeVariables #-}
35 | {-# LANGUAGE StandaloneDeriving #-}
36 | {-# LANGUAGE TypeOperators #-}
37 | {-# LANGUAGE TypeSynonymInstances #-}
38 | {-# LANGUAGE UndecidableInstances #-}
39 |
40 | module Language.CQL.Mapping where
41 |
42 | import Control.DeepSeq
43 | import Data.Map.Strict (Map)
44 | import Data.Map.Strict as Map
45 | import Data.Maybe
46 | import qualified Data.Set as Set
47 | import Data.Typeable
48 | import Data.Void
49 | import Language.CQL.Common
50 | import Language.CQL.Morphism (Morphism(..), translate, translate')
51 | import Language.CQL.Morphism as Morphism (typeOf)
52 | import Language.CQL.Schema as Schema
53 | import Language.CQL.Term
54 | import Prelude hiding (EQ)
55 |
56 | -- | Morphism of schemas.
57 | data Mapping var ty sym en fk att en' fk' att'
58 | = Mapping
59 | { src :: Schema var ty sym en fk att
60 | , dst :: Schema var ty sym en' fk' att'
61 |
62 | , ens :: Map en en'
63 | , fks :: Map fk (Term () Void Void en' fk' Void Void Void)
64 | , atts :: Map att (Term () ty sym en' fk' att' Void Void)
65 | }
66 |
67 | instance TyMap NFData '[var, ty, sym, en, fk, att, en', fk', att']
68 | => NFData (Mapping var ty sym en fk att en' fk' att') where
69 | rnf (Mapping s t e f a) = deepseq s $ deepseq t $ deepseq e $ deepseq f $ rnf a
70 |
71 | instance TyMap Show '[var, ty, sym, en, fk, att, en', fk', att']
72 | => Show (Mapping var ty sym en fk att en' fk' att') where
73 | show (Mapping _ _ ens' fks' atts') =
74 | "mapping {" ++ "\n" ++
75 | "entities " ++ "\n" ++
76 | "\t" ++ intercalate "\n\t" ens'' ++ "\n" ++
77 | "foreign_keys\n" ++
78 | "\t" ++ intercalate "\n\t" fks'' ++ "\n" ++
79 | "attributes \n" ++
80 | "\t" ++ intercalate "\n\t" atts'' ++ "\n" ++
81 | "}\n"
82 | where
83 | ens'' = (\(s,t) -> show s ++ " -> " ++ show t) <$> Map.toList ens'
84 | fks'' = (\(k,s) -> show k ++ " -> " ++ show s) <$> Map.toList fks'
85 | atts'' = (\(k,s) -> show k ++ " -> " ++ show s) <$> Map.toList atts'
86 |
87 | instance TyMap Eq '[var, ty, sym, en, fk, att, en', fk', att']
88 | => Eq (Mapping var ty sym en fk att en' fk' att') where
89 | (Mapping s1' s2' ens' fks' atts') == (Mapping s1'' s2'' ens'' fks'' atts'')
90 | = (s1' == s1'') && (s2' == s2'') && (ens' == ens'') && (fks' == fks'') && (atts' == atts'')
91 |
92 | -- | Accessor due to name conflict
93 | getEns :: Mapping var ty sym en fk att en' fk' att' -> Map en en'
94 | getEns = ens
95 |
96 | -- | Accessor due to name conflict
97 | getFks :: Mapping var ty sym en fk att en' fk' att' -> Map fk (Term () Void Void en' fk' Void Void Void)
98 | getFks = fks
99 |
100 | -- | Accessor due to name conflict
101 | getAtts :: Mapping var ty sym en fk att en' fk' att' -> Map att (Term () ty sym en' fk' att' Void Void)
102 | getAtts = atts
103 |
104 | toMorphism
105 | :: MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, en', fk', att']
106 | => Mapping var ty sym en fk att en' fk' att'
107 | -> Morphism var ty sym en fk att Void Void en' fk' att' Void Void
108 | toMorphism (Mapping src' dst' ens' fks' atts') = Morphism (Schema.toCollage src') (Schema.toCollage dst') ens' fks' atts' Map.empty Map.empty
109 |
110 | -- | Checks well-typedness of underlying theory.
111 | typecheckMapping
112 | :: (MultiTyMap '[Show, Ord, NFData] '[var, ty], MultiTyMap '[Show, Ord, Typeable, NFData] '[sym, en, fk, att, en', fk', att'])
113 | => Mapping var ty sym en fk att en' fk' att'
114 | -> Err ()
115 | typecheckMapping m = Morphism.typeOf $ toMorphism m
116 |
117 | -- | Given @F@ checks that each @S |- p = q -> T |- F p = F q@.
118 | validateMapping
119 | :: forall var ty sym en fk att en' fk' att'
120 | . (MultiTyMap '[Show, Ord, NFData] '[var, ty], MultiTyMap '[Show, Ord, Typeable, NFData] '[sym, en, fk, att, en', fk', att'])
121 | => Mapping var ty sym en fk att en' fk' att'
122 | -> Err ()
123 | validateMapping m@(Mapping src' dst' ens' _ _) = do
124 | mapM_ validatePathEq (Set.toList $ path_eqs src')
125 | mapM_ validateObsEq (Set.toList $ obs_eqs src')
126 | where
127 | validateObsEq :: (en, EQ () ty sym en fk att Void Void) -> Err ()
128 | validateObsEq (enx, EQ (l,r)) = let
129 | l' = translate (toMorphism m) l
130 | r' = translate (toMorphism m) r :: Term () ty sym en' fk' att' Void Void
131 | en' = ens' ! enx
132 | in if eq dst' en' (EQ (l', r'))
133 | then pure ()
134 | else Left $ show l ++ " = " ++ show r ++ " translates to " ++ show l' ++ " = " ++ show r' ++ " which is not provable"
135 | validatePathEq :: (en, EQ () Void Void en fk Void Void Void) -> Err ()
136 | validatePathEq (enx, EQ (l,r)) = let
137 | l' = translate' (toMorphism m) l
138 | r' = translate' (toMorphism m) r :: Term () Void Void en' fk' Void Void Void
139 | en' = ens' ! enx
140 | in if eq dst' en' (EQ (upp l', upp r'))
141 | then pure ()
142 | else Left $ show l ++ " = " ++ show r ++ " translates to " ++ show l' ++ " = " ++ show r' ++ " which is not provable"
143 |
144 | -----------------------------------------------------------------------------------------------------------------
145 | -- Syntax
146 |
147 | data MappingExp where
148 | MappingVar :: String -> MappingExp
149 | MappingId :: SchemaExp -> MappingExp
150 | MappingRaw :: MappingExpRaw' -> MappingExp
151 | MappingComp :: MappingExp -> MappingExp -> MappingExp
152 | deriving (Eq, Show)
153 |
154 | getOptionsMapping :: MappingExp -> [(String, String)]
155 | getOptionsMapping x = case x of
156 | MappingVar _ -> []
157 | MappingId _ -> []
158 | MappingComp _ _ -> []
159 | MappingRaw (MappingExpRaw' _ _ _ _ _ o _) -> o
160 |
161 | instance Deps MappingExp where
162 | deps x = case x of
163 | MappingVar v -> [(v, MAPPING)]
164 | MappingId s -> deps s
165 | MappingComp f g -> deps f ++ deps g
166 | MappingRaw (MappingExpRaw' s t _ _ _ _ i) -> deps s ++ deps t ++ concatMap deps i
167 |
168 | data MappingEx :: * where
169 | MappingEx
170 | :: forall var ty sym en fk att en' fk' att' . (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym, en, fk, att, en', fk', att'])
171 | => Mapping var ty sym en fk att en' fk' att'
172 | -> MappingEx
173 |
174 | deriving instance Show MappingEx
175 |
176 | instance NFData MappingEx where
177 | rnf (MappingEx x) = rnf x
178 |
179 | -----------------------------------------------------------------------------------------------------------------
180 | -- Operations
181 |
182 | -- | Compose two mappings.
183 | composeMapping
184 | :: (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym, en, fk, att, en', fk', att', en', fk', att', en'', fk'', att''])
185 | => Mapping var ty sym en fk att en' fk' att'
186 | -> Mapping var ty sym en' fk' att' en'' fk'' att''
187 | -> Err (Mapping var ty sym en fk att en'' fk'' att'')
188 | composeMapping (Mapping s t e f a) m2@(Mapping s' t' e' _ _) =
189 | if t == s'
190 | then let e'' = Map.fromList [ (k, e' ! v) | (k, v) <- Map.toList e ]
191 | f'' = Map.fromList [ (k, translate' (toMorphism m2) v) | (k, v) <- Map.toList f ]
192 | a'' = Map.fromList [ (k, translate (toMorphism m2) v) | (k, v) <- Map.toList a ]
193 | in pure $ Mapping s t' e'' f'' a''
194 | else Left $ "Source and target schemas do not match: " ++ show t ++ " and " ++ show s'
195 |
196 | -----------------------------------------------------------------------------------------------------------------
197 | -- Literals
198 |
199 | data MappingExpRaw' =
200 | MappingExpRaw'
201 | { mapraw_src :: SchemaExp
202 | , mapraw_dst :: SchemaExp
203 | , mapraw_ens :: [(String, String)]
204 | , mapraw_fks :: [(String, [String])]
205 | , mapraw_atts :: [(String, (String, Maybe String, RawTerm)+[String])]
206 | , mapraw_options :: [(String, String)]
207 | , mapraw_imports :: [MappingExp]
208 | } deriving (Eq, Show)
209 |
210 | -- | Does the hard work of @evalMappingRaw@.
211 | evalMappingRaw'
212 | :: forall var ty sym en fk att en' fk' att' . (MultiTyMap '[Show, Ord, Typeable, NFData] '[sym, en, fk, att, en', fk', att'])
213 | => Schema var ty sym en fk att -> Schema var ty sym en' fk' att'
214 | -> MappingExpRaw'
215 | -> [Mapping var ty sym en fk att en' fk' att']
216 | -> Err (Mapping var ty sym en fk att en' fk' att')
217 | evalMappingRaw' src' dst' (MappingExpRaw' _ _ ens0 fks0 atts0 _ _) is = do
218 | ens1 <- multiCast ens0
219 | ens2 <- toMapSafely ens1
220 | theFks <- evalFks fks0
221 | theAtts <- evalAtts (allEns ens2) atts0
222 | return $ Mapping src' dst' (allEns ens2) (mergeMaps $ theFks : fmap getFks is) (mergeMaps $ theAtts : fmap getAtts is)
223 | where
224 | allEns ensX = Map.fromList $ Map.toList ensX ++ concatMap (Map.toList . getEns) is
225 | keys' = fmap fst
226 | fks' = Map.toList $ Schema.fks dst'
227 | ens' = Set.toList $ Schema.ens dst'
228 | atts' = Map.toList $ Schema.atts dst'
229 | transE ens2 en = case Map.lookup en ens2 of
230 | Just x -> return x
231 | Nothing -> Left $ "No entity mapping for " ++ show en
232 |
233 | evalAtts _ [] = pure $ Map.empty
234 | evalAtts x ((att, Right l):ts) = do
235 | att' <- note ("Not a src attribute " ++ att) (cast att)
236 | att2 <- note ("Not a dst attribute " ++ att) (cast $ last l)
237 | t'x <- inferPath ens' $ tail $ reverse l
238 | let t' = Att att2 $ upp t'x
239 | rest <- evalAtts x ts
240 | pure $ Map.insert att' t' rest
241 | evalAtts x ((att, Left (v, t2, t)):ts) = do
242 | att' <- note ("Not an attribute " ++ att) (cast att)
243 | let t' = inferTerm v (keys' fks') (keys' atts') t
244 | rest <- evalAtts x ts
245 | let ret = pure $ Map.insert att' t' rest
246 | (s,_) = Schema.atts src' ! att'
247 | s' <- transE x s
248 | case t2 of
249 | Nothing -> ret
250 | Just t3 -> case cast t3 of
251 | Nothing -> Left $ "Not an entity: " ++ t3
252 | Just t4 -> if t4 == s'
253 | then ret
254 | else Left $ "Type mismatch: " ++ show s' ++ " and " ++ show t3
255 |
256 | -- :: String ->[String]-> [String] -> RawTerm-> Term () Void Void en Fk Void Void Void
257 | inferTerm' v _ _ (RawApp x []) | v == x = Var ()
258 | inferTerm' v fks'' atts'' (RawApp x (a:[])) | elem' x fks'' = Fk (fromJust $ cast x) $ inferTerm' v fks'' atts'' a
259 | inferTerm' _ _ _ _ = error "impossible"
260 |
261 | --inferTerm :: Typeable sym => String ->[fk']-> [att'] -> RawTerm -> Term () ty sym en' fk' att' Void Void
262 | inferTerm v _ _ (RawApp x []) | v == x = Var ()
263 | inferTerm v fks'' atts'' (RawApp x (a:[])) | elem' x fks'' = Fk (fromJust $ cast x) $ inferTerm' v fks'' atts'' a
264 | inferTerm v fks'' atts'' (RawApp x (a:[])) | elem' x atts'' = Att (fromJust $ cast x) $ inferTerm' v fks'' atts'' a
265 | inferTerm u fks'' atts'' (RawApp v l) = let l' = Prelude.map (inferTerm u fks'' atts'') l in
266 | case cast v of
267 | Just x -> Sym x l'
268 | Nothing -> error "impossible until complex typesides"
269 |
270 | -- :: [en'] -> [String] -> Err (Term () Void Void en' fk' Void Void Void)
271 | inferPath ens'' (s:ex) | elem' s ens'' = inferPath ens'' ex
272 | inferPath ens'' (s:ex) | elem' s (keys' fks') = do { h' <- inferPath ens'' ex ; return $ Fk (fromJust $ cast s) h' }
273 | | otherwise = Left $ "Not a target fk: " ++ s
274 | inferPath _ [] = return $ Var ()
275 |
276 | -- :: [(String, [String])] -> Err (Map fk (Term () Void Void en' fk' Void Void Void))
277 | evalFks [] = pure Map.empty
278 | evalFks ((fk,p):eqs') = do
279 | p' <- inferPath ens' $ reverse p
280 | -- _ <- findEn ens' fks' p
281 | rest <- evalFks eqs'
282 | fk' <- note ("Not a src fk: " ++ fk) (cast fk)
283 | pure $ Map.insert fk' p' rest
284 |
285 | multiCast :: forall tyx ty2x
286 | . (Typeable tyx, Show tyx, Typeable ty2x, Show ty2x)
287 | => [(String, String)]
288 | -> Err [(ty2x, tyx)]
289 | multiCast [] = pure []
290 | multiCast ((ty2,ty):tl) = case (cast ty :: Maybe tyx) of
291 | Just ty' -> do
292 | x <- multiCast tl
293 | case cast ty2 :: Maybe ty2x of
294 | Just ty2' -> return $ (ty2', ty'):x
295 | Nothing -> Left $ "Not in source schema/typeside: " ++ show ty2
296 | Nothing -> Left $ "Not in target schema/typeside: " ++ show ty
297 |
298 | -- | Evaluates a literal into a mapping. Does not typecheck or validate.
299 | evalMappingRaw
300 | :: (MultiTyMap '[Show, Ord, Typeable, NFData] '[var, ty, sym, en, fk, att, en', fk', att'])
301 | => Schema var ty sym en fk att
302 | -> Schema var ty sym en' fk' att'
303 | -> MappingExpRaw'
304 | -> [MappingEx]
305 | -> Err MappingEx
306 | evalMappingRaw src' dst' t is = do
307 | (a :: [Mapping var ty sym en fk att en' fk' att']) <- doImports is
308 | r <- evalMappingRaw' src' dst' t a
309 | --l <- toOptions $ mapraw_options t
310 | pure $ MappingEx r
311 | where
312 | -- g :: forall var ty sym en fk att en' fk' att'. TyMap Typeable '[var, ty, sym, en, fk, att, fk', en', att']
313 | -- => [MappingEx] -> Err [Mapping var ty sym en fk att en' fk' att']
314 | doImports [] = return []
315 | doImports (MappingEx ts : r) = case cast ts of
316 | Nothing -> Left "Bad import"
317 | Just ts' -> do { r' <- doImports r ; return $ ts' : r' }
318 |
--------------------------------------------------------------------------------