├── .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 | [![Build Status](https://travis-ci.com/statebox/cql.svg?branch=master&token=Ljpteop2x6Z8X4NsFyyn)](https://travis-ci.com/statebox/cql) 4 | [![License: AGPL v3](https://img.shields.io/badge/License-AGPL%20v3-blue.svg)](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 | --------------------------------------------------------------------------------