Skip to content

Commit d911bab

Browse files
epostepost
authored
148/more cleanup (WIP) (#150)
* Some cleanup and explicit typing. 148. * Move modules to Language.CQL. #148 * Clean up Program parsers. #148 * Clean up Program parsers. #148 * Move into Language.CQL.Parser.Program. * Simplify some of the stuff inside. * Move QuickCheck generator for Parser into test dir. #148 * More cleanup. #148 * Segregate morphism code into Morphism.hs. #148 * Tighten imports from Morphism. #148 * Rename Morphism-related functions for clarity. #148 * Improve naming and qualification of Morphism-related functions. #148 * Move Collage into its own separate module. #148 * Fix typo in 'lower' doc comment. #148
1 parent c8cc768 commit d911bab

31 files changed

+1198
-1053
lines changed

‎src/Language/CQL.hs

+24-24
Original file line numberDiff line numberDiff line change
@@ -42,26 +42,26 @@ module Language.CQL where
4242
import Control.Concurrent
4343
import Control.DeepSeq
4444
import Control.Exception
45-
import Data.List (nub)
46-
import qualified Data.Map.Strict as Map
45+
import Data.List (nub)
46+
import qualified Data.Map.Strict as Map
4747
import Data.Maybe
4848
import Data.Typeable
49-
import Language.Common as C
50-
import Language.Graph
51-
import Language.Instance as I
52-
import Language.Mapping as M
53-
import Language.Options
54-
import Language.Parser (parseCqlProgram)
55-
import Language.Program as P
56-
import Language.Query as Q
57-
import Language.Schema as S
58-
import Language.Term as Term
59-
import Language.Transform as Tr
60-
import Language.Typeside as T
61-
import Prelude hiding (EQ, exp)
49+
import Language.CQL.Common as C
50+
import Language.CQL.Graph
51+
import Language.CQL.Instance as I
52+
import Language.CQL.Mapping as M
53+
import Language.CQL.Options
54+
import Language.CQL.Parser.Program (parseProgram)
55+
import Language.CQL.Program as P
56+
import Language.CQL.Query as Q
57+
import Language.CQL.Schema as S
58+
import Language.CQL.Term as Term
59+
import Language.CQL.Transform as Tr
60+
import Language.CQL.Typeside as T
61+
import Prelude hiding (EQ, exp)
6262
import System.IO.Unsafe
6363

64-
-- | Timesout a computation after @i@ microseconds.
64+
-- | Times out a computation after @i@ microseconds.
6565
timeout' :: NFData x => Integer -> Err x -> Err x
6666
timeout' i p = unsafePerformIO $ do
6767
m <- newEmptyMVar
@@ -240,15 +240,15 @@ typecheckSchemaExp p x = case x of
240240
-- | The result of evaluating an CQL program.
241241
type Env = KindCtx TypesideEx SchemaEx InstanceEx MappingEx QueryEx TransformEx Options
242242

243-
-- | Simple three phase evaluation and reporting.
243+
-- | Parse, typecheck, and evaluate the CQL program.
244244
runProg :: String -> Err (Prog, Types, Env)
245-
runProg p = do
246-
p1 <- parseCqlProgram p
247-
ops <- toOptions defaultOptions $ other p1
248-
o <- findOrder p1
249-
p2 <- typecheckCqlProgram o p1 newTypes
250-
p3 <- evalCqlProgram o p1 $ newEnv ops
251-
return (p1, p2, p3)
245+
runProg srcText = do
246+
progE <- parseProgram srcText
247+
opts <- toOptions defaultOptions $ other progE
248+
o <- findOrder progE
249+
typesE <- typecheckCqlProgram o progE newTypes
250+
envE <- evalCqlProgram o progE $ newEnv opts
251+
return (progE, typesE, envE)
252252

253253
evalCqlProgram :: [(String,Kind)] -> Prog -> Env -> Err Env
254254
evalCqlProgram [] _ env = pure env

‎src/Language/CQL/Collage.hs

+226
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,226 @@
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 <https://statebox.nl>
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 <https://www.gnu.org/licenses/>.
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.Collage where
41+
42+
import Control.DeepSeq (NFData)
43+
import Data.Map.Merge.Strict
44+
import Data.Map.Strict as Map hiding (foldr, size)
45+
import Data.Set as Set hiding (foldr, size)
46+
import Data.Void
47+
import Language.CQL.Common
48+
import Language.CQL.Term (Head(..), Term(..), simplifyFix, occsTerm, upp)
49+
import Language.CQL.Term (EQ(..), Ctx)
50+
import Prelude hiding (EQ)
51+
52+
data Collage var ty sym en fk att gen sk
53+
= Collage
54+
{ ceqs :: Set (Ctx var (ty+en), EQ var ty sym en fk att gen sk)
55+
, ctys :: Set ty
56+
, cens :: Set en
57+
, csyms :: Map sym ([ty],ty)
58+
, cfks :: Map fk (en, en)
59+
, catts :: Map att (en, ty)
60+
, cgens :: Map gen en
61+
, csks :: Map sk ty
62+
} deriving (Eq, Show)
63+
64+
--------------------------------------------------------------------------------
65+
66+
occs
67+
:: (Ord sym, Ord fk, Ord att, Ord gen, Ord sk)
68+
=> Collage var ty sym en fk att gen sk
69+
-> Map (Head ty sym en fk att gen sk) Int
70+
occs col = foldr (\(_, EQ (lhs, rhs)) x -> m x $ m (occsTerm lhs) $ occsTerm rhs) Map.empty $ ceqs col
71+
where
72+
m = merge preserveMissing preserveMissing $ zipWithMatched (\_ x y -> x + y)
73+
74+
--------------------------------------------------------------------------------
75+
76+
-- | Simplify a collage by replacing symbols of the form @gen/sk = term@, yielding also a
77+
-- translation function from the old theory to the new, encoded as a list of (symbol, term) pairs.
78+
simplify
79+
:: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
80+
=> Collage var ty sym en fk att gen sk
81+
-> (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)])
82+
simplify (Collage ceqs' ctys' cens' csyms' cfks' catts' cgens' csks' )
83+
= (Collage ceqs'' ctys' cens' csyms' cfks' catts' cgens'' csks'', f)
84+
where
85+
(ceqs'', f) = simplifyFix ceqs' []
86+
cgens'' = Map.fromList $ Prelude.filter (\(x,_) -> notElem (HGen x) $ fmap fst f) $ Map.toList cgens'
87+
csks'' = Map.fromList $ Prelude.filter (\(x,_) -> notElem (HSk x) $ fmap fst f) $ Map.toList csks'
88+
89+
--------------------------------------------------------------------------------
90+
91+
eqsAreGround :: Collage var ty sym en fk att gen sk -> Bool
92+
eqsAreGround col = Prelude.null [ x | x <- Set.toList $ ceqs col, not $ Map.null (fst x) ]
93+
94+
fksFrom :: Eq en => Collage var ty sym en fk att gen sk -> en -> [(fk,en)]
95+
fksFrom sch en' = f $ Map.assocs $ cfks sch
96+
where f [] = []
97+
f ((fk,(en1,t)):l) = if en1 == en' then (fk,t) : (f l) else f l
98+
99+
attsFrom :: Eq en => Collage var ty sym en fk att gen sk -> en -> [(att,ty)]
100+
attsFrom sch en' = f $ Map.assocs $ catts sch
101+
where f [] = []
102+
f ((fk,(en1,t)):l) = if en1 == en' then (fk,t) : (f l) else f l
103+
104+
-- | Gets the type of a term that is already known to be well-typed.
105+
typeOf
106+
:: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
107+
=> Collage var ty sym en fk att gen sk
108+
-> Term Void Void Void en fk Void gen Void
109+
-> en
110+
typeOf col e = case typeOf' col Map.empty (upp e) of
111+
Left _ -> error "Impossible in typeOf, please report."
112+
Right x -> case x of
113+
Left _ -> error "Impossible in typeOf, please report."
114+
Right y -> y
115+
116+
checkDoms
117+
:: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
118+
=> Collage var ty sym en fk att gen sk
119+
-> Err ()
120+
checkDoms col = do
121+
mapM_ f $ Map.elems $ csyms col
122+
mapM_ g $ Map.elems $ cfks col
123+
mapM_ h $ Map.elems $ catts col
124+
mapM_ isEn $ Map.elems $ cgens col
125+
mapM_ isTy $ Map.elems $ csks col
126+
where
127+
f (t1,t2) = do { mapM_ isTy t1 ; isTy t2 }
128+
g (e1,e2) = do { isEn e1 ; isEn e2 }
129+
h (e ,t ) = do { isEn e ; isTy t }
130+
isEn x = if Set.member x $ cens col
131+
then pure ()
132+
else Left $ "Not an entity: " ++ show x
133+
isTy x = if Set.member x $ ctys col
134+
then pure ()
135+
else Left $ "Not a type: " ++ show x
136+
137+
typeOfCol
138+
:: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
139+
=> Collage var ty sym en fk att gen sk
140+
-> Err ()
141+
typeOfCol col = do
142+
checkDoms col
143+
mapM_ (typeOfEq' col) $ Set.toList $ ceqs col
144+
145+
--------------------------------------------------------------------------------
146+
147+
typeOf'
148+
:: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
149+
=> Collage var ty sym en fk att gen sk
150+
-> Ctx var (ty + en)
151+
-> Term var ty sym en fk att gen sk
152+
-> Err (ty + en)
153+
typeOf' _ ctx (Var v) = note ("Unbound variable: " ++ show v) $ Map.lookup v ctx
154+
typeOf' col _ (Gen g) = case Map.lookup g $ cgens col of
155+
Nothing -> Left $ "Unknown generator: " ++ show g
156+
Just t -> Right $ Right t
157+
typeOf' col _ (Sk s) = case Map.lookup s $ csks col of
158+
Nothing -> Left $ "Unknown labelled null: " ++ show s
159+
Just t -> Right $ Left t
160+
typeOf' col ctx xx@(Fk f a) = case Map.lookup f $ cfks col of
161+
Nothing -> Left $ "Unknown foreign key: " ++ show f
162+
Just (s, t) -> do s' <- typeOf' col ctx a
163+
if (Right s) == s' then pure $ Right t else Left $ "Expected argument to have entity " ++
164+
show s ++ " but given " ++ show s' ++ " in " ++ (show xx)
165+
typeOf' col ctx xx@(Att f a) = case Map.lookup f $ catts col of
166+
Nothing -> Left $ "Unknown attribute: " ++ show f
167+
Just (s, t) -> do s' <- typeOf' col ctx a
168+
if (Right s) == s' then pure $ Left t else Left $ "Expected argument to have entity " ++
169+
show s ++ " but given " ++ show s' ++ " in " ++ (show xx)
170+
typeOf' col ctx xx@(Sym f a) = case Map.lookup f $ csyms col of
171+
Nothing -> Left $ "Unknown function symbol: " ++ show f
172+
Just (s, t) -> do s' <- mapM (typeOf' col ctx) a
173+
if length s' == length s
174+
then if (Left <$> s) == s'
175+
then pure $ Left t
176+
else Left $ "Expected arguments to have types " ++
177+
show s ++ " but given " ++ show s' ++ " in " ++ (show $ xx)
178+
else Left $ "Expected argument to have arity " ++
179+
show (length s) ++ " but given " ++ show (length s') ++ " in " ++ (show $ xx)
180+
181+
typeOfEq'
182+
:: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk])
183+
=> Collage var ty sym en fk att gen sk
184+
-> (Ctx var (ty + en), EQ var ty sym en fk att gen sk)
185+
-> Err (ty + en)
186+
typeOfEq' col (ctx, EQ (lhs, rhs)) = do
187+
lhs' <- typeOf' col ctx lhs
188+
rhs' <- typeOf' col ctx rhs
189+
if lhs' == rhs'
190+
then Right lhs'
191+
else Left $ "Equation lhs has type " ++ show lhs' ++ " but rhs has type " ++ show rhs'
192+
193+
--------------------------------------------------------------------------------
194+
195+
-- | Initialize a mapping of sorts to bools for sort inhabition check.
196+
initGround :: (Ord ty, Ord en) => Collage var ty sym en fk att gen sk -> (Map en Bool, Map ty Bool)
197+
initGround col = (me', mt')
198+
where
199+
me = Map.fromList $ Prelude.map (\en -> (en, False)) $ Set.toList $ cens col
200+
mt = Map.fromList $ Prelude.map (\ty -> (ty, False)) $ Set.toList $ ctys col
201+
me' = Prelude.foldr (\(_, en) m -> Map.insert en True m) me $ Map.toList $ cgens col
202+
mt' = Prelude.foldr (\(_, ty) m -> Map.insert ty True m) mt $ Map.toList $ csks col
203+
204+
-- | Applies one layer of symbols to the sort to boolean inhabitation map.
205+
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)
206+
closeGround col (me, mt) = (me', mt'')
207+
where
208+
mt''= Prelude.foldr (\(_, (tys,ty)) m -> if and ((!) mt' <$> tys) then Map.insert ty True m else m) mt' $ Map.toList $ csyms col
209+
mt' = Prelude.foldr (\(_, (en, ty)) m -> if (!) me' en then Map.insert ty True m else m) mt $ Map.toList $ catts col
210+
me' = Prelude.foldr (\(_, (en, _ )) m -> if (!) me en then Map.insert en True m else m) me $ Map.toList $ cfks col
211+
212+
-- | Does a fixed point of closeGround.
213+
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)
214+
iterGround col r = if r == r' then r else iterGround col r'
215+
where r' = closeGround col r
216+
217+
-- | Gets the inhabitation map for the sorts of a collage.
218+
computeGround :: (MultiTyMap '[Show, Ord, NFData] '[ty, en]) => Collage var ty sym en fk att gen sk -> (Map en Bool, Map ty Bool)
219+
computeGround col = iterGround col $ initGround col
220+
221+
-- | True iff all sorts in a collage are inhabited.
222+
allSortsInhabited :: (MultiTyMap '[Show, Ord, NFData] '[ty, en]) => Collage var ty sym en fk att gen sk -> Bool
223+
allSortsInhabited col = t && f
224+
where (me, mt) = computeGround col
225+
t = and $ Map.elems me
226+
f = and $ Map.elems mt

‎src/Language/Common.hs ‎src/Language/CQL/Common.hs

+18-11
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,7 @@ along with this program. If not, see <https://www.gnu.org/licenses/>.
3838
{-# LANGUAGE TypeSynonymInstances #-}
3939
{-# LANGUAGE UndecidableInstances #-}
4040

41-
module Language.Common where
41+
module Language.CQL.Common where
4242

4343
import Control.Arrow (left)
4444
import Data.Char
@@ -65,15 +65,16 @@ fromListAccum ((k,v):kvs) = Map.insert k op (fromListAccum kvs)
6565
op = maybe (Set.singleton v) (Set.insert v) (Map.lookup k r)
6666
r = fromListAccum kvs
6767

68-
fromList'' :: (Show k, Ord k) => [k] -> Err (Set k)
69-
fromList'' [] = return Set.empty
70-
fromList'' (k:l) = do
71-
l' <- fromList'' l
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
7273
if Set.member k l'
7374
then Left $ "Duplicate binding: " ++ show k
7475
else pure $ Set.insert k l'
7576

76-
-- | Converts a map to a finite list, returning an error when there are duplicate bindings.
77+
-- | Converts an association list to a 'Map', returning an error when there are duplicate bindings.
7778
toMapSafely :: (Show k, Ord k) => [(k,v)] -> Err (Map k v)
7879
toMapSafely [] = return Map.empty
7980
toMapSafely ((k,v):l) = do
@@ -100,12 +101,14 @@ note :: b -> Maybe a -> Either b a
100101
note n = maybe (Left n) Right
101102

102103
data Kind = CONSTRAINTS | TYPESIDE | SCHEMA | INSTANCE | MAPPING | TRANSFORM | QUERY | COMMAND | GRAPH | COMMENT | SCHEMA_COLIMIT
103-
deriving (Show, Eq, Ord)
104+
deriving (Show, Eq, Ord)
104105

105106
type ID = Integer
106107

107-
sepTup :: (Show a1, Show a2) => String -> (a1, a2) -> String
108-
sepTup sep (k,v) = show k ++ sep ++ show v
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
109112

110113
section :: String -> String -> String
111114
section heading body = heading ++ "\n" ++ indentLines body
@@ -116,6 +119,9 @@ indentLines = foldMap (\l -> tab <> l <> "\n"). lines
116119
tab :: String
117120
tab = " "
118121

122+
sepTup :: (Show a1, Show a2) => String -> (a1, a2) -> String
123+
sepTup sep (k,v) = show k ++ sep ++ show v
124+
119125
-- | A version of intercalate that works on Foldables instead of just List,
120126
-- | adapted from PureScript.
121127
intercalate :: (Foldable f, Monoid m) => m -> f m -> m
@@ -127,8 +133,9 @@ intercalate sep xs = snd (foldl go (True, mempty) xs)
127133
mapl :: Foldable f => (a -> b) -> f a -> [b]
128134
mapl fn = fmap fn . Foldable.toList
129135

130-
toLowercase :: String -> String
131-
toLowercase = Prelude.map toLower
136+
-- | Converts a String to lowercase, like Data.List.Extra.lower.
137+
lower :: String -> String
138+
lower = fmap toLower
132139

133140
-- | Heterogenous membership in a list
134141
elem' :: (Typeable t, Typeable a, Eq a) => t -> [a] -> Bool

‎src/Language/Congruence.hs ‎src/Language/CQL/Congruence.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,7 @@ You should have received a copy of the GNU Affero General Public License
1919
along with this program. If not, see <https://www.gnu.org/licenses/>.
2020
-}
2121
{-# LANGUAGE FlexibleContexts, OverloadedLists, OverloadedStrings, TupleSections #-}
22-
module Language.Congruence (decide, Term(Function)) where
22+
module Language.CQL.Congruence (decide, Term(Function)) where
2323

2424
import Prelude hiding (any)
2525

@@ -35,7 +35,7 @@ import Data.Foldable (traverse_)
3535
import Data.Graph.Inductive (LNode)
3636
import Data.Functor.Identity
3737

38-
import Language.Internal
38+
import Language.CQL.Internal
3939

4040

4141
decide :: Ord t => [(Term t, Term t)] -> Term t -> Term t -> Bool

‎src/Language/Graph.hs ‎src/Language/CQL/Graph.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,7 @@ You should have received a copy of the GNU Affero General Public License
1919
along with this program. If not, see <https://www.gnu.org/licenses/>.
2020
-}
2121

22-
module Language.Graph where
22+
module Language.CQL.Graph where
2323

2424
import Prelude
2525

0 commit comments

Comments
 (0)