Skip to content

Commit a058652

Browse files
epostepost
committed
Indent, unqualify fns, etc. #38 #82 
1 parent 8e42d29 commit a058652

File tree

1 file changed

+91
-91
lines changed

1 file changed

+91
-91
lines changed

‎src/Language/AQL.hs

+91-91
Original file line numberDiff line numberDiff line change
@@ -4,8 +4,8 @@
44
module Language.AQL where
55

66
import Prelude hiding (EQ)
7-
import Data.Set as Set
8-
import Data.Map.Strict as Map
7+
import qualified Data.Map.Strict as Map
8+
import qualified Data.Set as Set
99
import Language.Common as C
1010
import Language.Term as Term
1111
import Language.Schema as S
@@ -14,30 +14,29 @@ import Language.Mapping as M
1414
import Language.Typeside as T
1515
import Language.Transform as Tr
1616
import Language.Query as Q
17-
import Data.List as List
17+
import Data.List (nub)
1818
import Data.Maybe
1919
import Language.Parser (parseAqlProgram)
2020
import Language.Program as P
2121
import Data.Void
2222
import Data.Typeable
2323
import Language.Options
24-
--import Control.Arrow ((***), first)
24+
import Control.Arrow (left)
2525

2626
-- simple three phase evaluation and reporting
2727
runProg :: String -> Err (Prog, Types, Env)
28-
runProg p = do p1 <- parseAqlProgram p
29-
o <- findOrder p1
30-
p2 <- typecheckAqlProgram o p1
31-
p3 <- evalAqlProgram o p1 newEnv
32-
return (p1, p2, p3)
28+
runProg p = do
29+
p1 <- parseAqlProgram p
30+
o <- findOrder p1
31+
p2 <- typecheckAqlProgram o p1
32+
p3 <- evalAqlProgram o p1 newEnv
33+
return (p1, p2, p3)
3334

3435
--todo: store exception info in other field
3536
type Env = KindCtx TypesideEx SchemaEx InstanceEx MappingEx QueryEx TransformEx ()
3637

37-
wrapError :: [Char] -> Either [Char] b -> Either [Char] b
38-
wrapError s e = case e of
39-
Left s' -> Left $ s ++ ": " ++ s'
40-
Right r -> Right r
38+
wrapError :: String -> Either String b -> Either String b
39+
wrapError prefix se = (\s -> prefix ++ ": " ++ s) `left` se
4140

4241
-- type Types = KindCtx () TypesideExp SchemaExp (SchemaExp,SchemaExp) (SchemaExp,SchemaExp) (InstanceExp,InstanceExp) ()
4342

@@ -135,15 +134,10 @@ typecheckTypesideExp p (TypesideVar v) = do t <- note ("Undefined typeside: " ++
135134
typecheckTypesideExp _ TypesideInitial = pure TypesideInitial
136135
typecheckTypesideExp _ (TypesideRaw r) = pure $ TypesideRaw r
137136

138-
typecheckSchemaExp :: KindCtx
139-
TypesideExp
140-
SchemaExp
141-
InstanceExp
142-
MappingExp
143-
QueryExp
144-
TransformExp
145-
[(String, Kind)]
146-
-> SchemaExp -> Either [Char] TypesideExp
137+
typecheckSchemaExp
138+
:: KindCtx TypesideExp SchemaExp InstanceExp MappingExp QueryExp TransformExp [(String, Kind)]
139+
-> SchemaExp
140+
-> Either String TypesideExp
147141
typecheckSchemaExp _ (SchemaRaw r) = pure $ schraw_ts r
148142
typecheckSchemaExp p (SchemaVar v) = do t <- note ("Undefined schema: " ++ show v) $ Map.lookup v $ schemas p
149143
typecheckSchemaExp p t
@@ -158,11 +152,11 @@ typecheckSchemaExp p (SchemaCoProd l r) = do l' <- typecheckSchemaExp p l
158152
evalAqlProgram :: [(String,Kind)] -> Prog -> Env -> Err Env
159153
evalAqlProgram [] _ e = pure e
160154
evalAqlProgram ((v,TYPESIDE):l) prog env = do t <- wrapError ("Eval Error in " ++ v) $ evalTypeside prog env $ lookup2 v (typesides prog)
161-
_ <- case t of
155+
_ <- case t of
162156
TypesideEx x -> typecheckTypeside x
163157
evalAqlProgram l prog $ env { typesides = Map.insert v t $ typesides env }
164158
evalAqlProgram ((v,SCHEMA):l) prog env = do t <- wrapError ("Eval Error in " ++ v) $ evalSchema prog env $ lookup2 v (schemas prog)
165-
_ <- case t of
159+
_ <- case t of
166160
SchemaEx x -> typecheckSchema x
167161
evalAqlProgram l prog $ env { schemas = Map.insert v t $ schemas env }
168162
evalAqlProgram ((v,INSTANCE):l) prog env = do t <- wrapError ("Eval Error in " ++ v) $ evalInstance prog env $ lookup2 v (instances prog)
@@ -171,21 +165,21 @@ evalAqlProgram ((v,INSTANCE):l) prog env = do t <- wrapError ("Eval Error in " +
171165
evalAqlProgram l prog $ env { instances = Map.insert v t $ instances env }
172166
evalAqlProgram ((v,MAPPING):l) prog env = do t <- wrapError ("Eval Error in " ++ v) $ evalMapping prog env $ lookup2 v (mappings prog)
173167
_ <- case t of
174-
MappingEx i -> do {_ <- typecheckMapping i; validateMapping i}
168+
MappingEx i -> do {_ <- typecheckMapping i; validateMapping i}
175169
evalAqlProgram l prog $ env { mappings = Map.insert v t $ mappings env }
176170
evalAqlProgram ((v,TRANSFORM):l) prog env = do t <- wrapError ("Eval Error in " ++ v) $ evalTransform prog env $ lookup2 v (transforms prog)
177171
_ <- case t of
178-
TransformEx i -> do {_ <- typecheckTransform i; validateTransform i}
172+
TransformEx i -> do {_ <- typecheckTransform i; validateTransform i}
179173
evalAqlProgram l prog $ env { transforms = Map.insert v t $ transforms env }
180174
evalAqlProgram _ _ _ = undefined
181175

182176
data Graph a = Graph { vertices :: [a], edges :: [(a, a)] } deriving Show
183177

184178
removeEdge :: (Eq a) => (a, a) -> Graph a -> Graph a
185-
removeEdge x (Graph v e) = Graph v (Prelude.filter (/=x) e)
179+
removeEdge x (Graph v e) = Graph v (filter (/=x) e)
186180

187181
connections :: (Eq a) => ((a, a) -> a) -> a -> Graph a -> [(a, a)]
188-
connections f0 x (Graph _ e) = Prelude.filter ((==x) . f0) e
182+
connections f0 x (Graph _ e) = filter ((==x) . f0) e
189183

190184
outbound :: Eq b => b -> Graph b -> [(b, b)]
191185
outbound a = connections fst a
@@ -195,22 +189,24 @@ inbound a = connections snd a
195189

196190
tsort :: (Eq a) => Graph a -> Err [a]
197191
tsort graph = tsort' [] (noInbound graph) graph
198-
where noInbound (Graph v e) = Prelude.filter (flip notElem $ fmap snd e) v
199-
tsort' l [] (Graph _ []) = pure $ reverse l
200-
tsort' _ [] _ = Left "There is at least one cycle in the AQL dependency graph."
201-
tsort' l (n:s) g = tsort' (n:l) s' g'
202-
where outEdges = outbound n g
203-
outNodes = fmap snd outEdges
204-
g' = Prelude.foldr removeEdge g outEdges
205-
s' = s ++ Prelude.filter (Prelude.null . flip inbound g') outNodes
192+
where
193+
noInbound (Graph v e) = filter (flip notElem $ fmap snd e) v
194+
tsort' l [] (Graph _ []) = pure $ reverse l
195+
tsort' _ [] _ = Left "There is at least one cycle in the AQL dependency graph."
196+
tsort' l (n:s) g = tsort' (n:l) s' g'
197+
where
198+
outEdges = outbound n g
199+
outNodes = snd <$> outEdges
200+
g' = foldr removeEdge g outEdges
201+
s' = s ++ filter (null . flip inbound g') outNodes
206202

207203
findOrder :: Prog -> Err [(String, Kind)]
208-
findOrder (KindCtx t s i m q tr o) = do
209-
ret <- tsort g
210-
return $ reverse ret
211-
where
212-
g = Graph o $ nub $ (f0 t TYPESIDE) ++ (f0 s SCHEMA) ++ (f0 i INSTANCE) ++ (f0 m MAPPING) ++ (f0 q QUERY) ++ (f0 tr TRANSFORM)
213-
f0 m0 k = concatMap (\(v,e) -> [ ((v,k),x) | x <- deps e ]) $ Map.toList m0
204+
findOrder (KindCtx t s i m q tr o) = do
205+
ret <- tsort g
206+
pure $ reverse ret
207+
where
208+
g = Graph o $ nub $ f0 t TYPESIDE ++ f0 s SCHEMA ++ f0 i INSTANCE ++ f0 m MAPPING ++ f0 q QUERY ++ f0 tr TRANSFORM
209+
f0 m0 k = concatMap (\(v,e) -> [ ((v,k),x) | x <- deps e ]) $ Map.toList m0
214210
------------------------------------------------------------------------------------------------------------
215211

216212
evalTypeside :: Prog -> Env -> TypesideExp -> Err TypesideEx
@@ -234,60 +230,65 @@ convInstance x = fromJust $ cast x
234230

235231
evalTransform :: Prog -> Env -> TransformExp -> Err TransformEx
236232
evalTransform _ env (TransformVar v) = note ("Could not find " ++ show v ++ " in ctx") $ Map.lookup v $ transforms env
237-
evalTransform p env (TransformId s) = do (InstanceEx i) <- evalInstance p env s
238-
return $ TransformEx $ Transform i i (h i) (g i)
239-
where h i = Prelude.foldr (\(gen,_) m -> Map.insert gen (Gen gen) m) Map.empty $ Map.toList $ I.gens $ pres i
240-
g i = Prelude.foldr (\(sk,_) m -> Map.insert sk (Sk sk) m) Map.empty $ Map.toList $ I.sks $ pres i
241-
242-
evalTransform p env (TransformRaw r) = do s0 <- evalInstance p env $ transraw_src r
243-
s1 <- evalInstance p env $ transraw_dst r
244-
is <- mapM (evalTransform p env) $ transraw_imports r
245-
case s0 of
246-
InstanceEx s -> case s1 of
247-
InstanceEx (t :: Instance var ty sym en fk att gen sk x y) ->
248-
evalTransformRaw ((convInstance s)::Instance var ty sym en fk att gen sk x y) t r is
249-
evalTransform prog env (TransformSigma f' i o) = do (MappingEx (f'' :: Mapping var ty sym en fk att en' fk' att')) <- evalMapping prog env f'
250-
(TransformEx (i' :: Transform var'' ty'' sym'' en'' fk'' att'' gen sk x y gen' sk' x' y')) <- evalTransform prog env i
251-
o' <- toOptions o
252-
r <- evalSigmaTrans f'' (fromJust $ ((cast i') :: Maybe (Transform var ty sym en fk att gen sk x y gen' sk' x' y'))) o'
253-
return $ TransformEx r
254-
evalTransform prog env (TransformDelta f' i o) = do (MappingEx (f'' :: Mapping var ty sym en' fk' att' en fk att)) <- evalMapping prog env f'
255-
(TransformEx (i' :: Transform var'' ty'' sym'' en'' fk'' att'' gen sk x y gen' sk' x' y')) <- evalTransform prog env i
256-
o' <- toOptions o
257-
r <- evalDeltaTrans f'' (fromJust $ ((cast i') :: Maybe (Transform var ty sym en fk att gen sk x y gen' sk' x' y'))) o'
258-
return $ TransformEx r
259-
evalTransform prog env (TransformSigmaDeltaUnit f' i o) =
260-
do (MappingEx (f'' :: Mapping var ty sym en fk att en' fk' att')) <- evalMapping prog env f'
261-
(InstanceEx (i' :: Instance var'' ty'' sym'' en'' fk'' att'' gen sk x y)) <- evalInstance prog env i
262-
o' <- toOptions o
263-
r <- evalDeltaSigmaUnit f'' (fromJust $ ((cast i') :: Maybe (Instance var ty sym en fk att gen sk x y))) o'
264-
return $ TransformEx r
265-
evalTransform prog env (TransformSigmaDeltaCoUnit f' i o) =
266-
do (MappingEx (f'' :: Mapping var ty sym en fk att en' fk' att')) <- evalMapping prog env f'
267-
(InstanceEx (i' :: Instance var'' ty'' sym'' en'' fk'' att'' gen sk x y)) <- evalInstance prog env i
268-
o' <- toOptions o
269-
r <- evalDeltaSigmaCoUnit f'' (fromJust $ ((cast i') :: Maybe (Instance var ty sym en' fk' att' gen sk x y))) o'
270-
return $ TransformEx r
233+
evalTransform p env (TransformId s) = do
234+
(InstanceEx i) <- evalInstance p env s
235+
pure $ TransformEx $ Transform i i (h i) (g i)
236+
where
237+
h i = foldr (\(gen,_) m -> Map.insert gen (Gen gen) m) Map.empty $ Map.toList $ I.gens $ pres i
238+
g i = foldr (\(sk ,_) m -> Map.insert sk (Sk sk) m) Map.empty $ Map.toList $ I.sks $ pres i
239+
evalTransform p env (TransformRaw r) = do
240+
s0 <- evalInstance p env $ transraw_src r
241+
s1 <- evalInstance p env $ transraw_dst r
242+
is <- mapM (evalTransform p env) $ transraw_imports r
243+
case s0 of
244+
InstanceEx s -> case s1 of
245+
InstanceEx (t :: Instance var ty sym en fk att gen sk x y) ->
246+
evalTransformRaw ((convInstance s)::Instance var ty sym en fk att gen sk x y) t r is
247+
evalTransform prog env (TransformSigma f' i o) = do
248+
(MappingEx (f'' :: Mapping var ty sym en fk att en' fk' att')) <- evalMapping prog env f'
249+
(TransformEx (i' :: Transform var'' ty'' sym'' en'' fk'' att'' gen sk x y gen' sk' x' y')) <- evalTransform prog env i
250+
o' <- toOptions o
251+
r <- evalSigmaTrans f'' (fromJust $ ((cast i') :: Maybe (Transform var ty sym en fk att gen sk x y gen' sk' x' y'))) o'
252+
pure $ TransformEx r
253+
evalTransform prog env (TransformDelta f' i o) = do
254+
(MappingEx (f'' :: Mapping var ty sym en' fk' att' en fk att)) <- evalMapping prog env f'
255+
(TransformEx (i' :: Transform var'' ty'' sym'' en'' fk'' att'' gen sk x y gen' sk' x' y')) <- evalTransform prog env i
256+
o' <- toOptions o
257+
r <- evalDeltaTrans f'' (fromJust $ ((cast i') :: Maybe (Transform var ty sym en fk att gen sk x y gen' sk' x' y'))) o'
258+
pure $ TransformEx r
259+
evalTransform prog env (TransformSigmaDeltaUnit f' i o) = do
260+
(MappingEx (f'' :: Mapping var ty sym en fk att en' fk' att')) <- evalMapping prog env f'
261+
(InstanceEx (i' :: Instance var'' ty'' sym'' en'' fk'' att'' gen sk x y)) <- evalInstance prog env i
262+
o' <- toOptions o
263+
r <- evalDeltaSigmaUnit f'' (fromJust $ ((cast i') :: Maybe (Instance var ty sym en fk att gen sk x y))) o'
264+
pure $ TransformEx r
265+
evalTransform prog env (TransformSigmaDeltaCoUnit f' i o) = do
266+
(MappingEx (f'' :: Mapping var ty sym en fk att en' fk' att')) <- evalMapping prog env f'
267+
(InstanceEx (i' :: Instance var'' ty'' sym'' en'' fk'' att'' gen sk x y)) <- evalInstance prog env i
268+
o' <- toOptions o
269+
r <- evalDeltaSigmaCoUnit f'' (fromJust $ ((cast i') :: Maybe (Instance var ty sym en' fk' att' gen sk x y))) o'
270+
pure $ TransformEx r
271271

272272
evalTransform _ _ _ = undefined
273273

274274

275275
evalMapping :: Prog -> Env -> MappingExp -> Err MappingEx
276276
evalMapping _ env (MappingVar v) = note ("Could not find " ++ show v ++ " in ctx") $ Map.lookup v $ mappings env
277-
evalMapping p env (MappingId s) = do (SchemaEx s') <- evalSchema p env s
278-
return $ MappingEx $ Prelude.foldr (\en' (Mapping s'' t e f' a) -> Mapping s'' t (Map.insert en' en' e) (f'' en' s' f') (g' en' s' a)) (Mapping s' s' Map.empty Map.empty Map.empty) (S.ens s')
279-
where
280-
--Prelude prefix necessary bc Set and Map also define foldr
281-
f'' en' s' f''' = Prelude.foldr (\(fk,_) m -> Map.insert fk (Fk fk $ Var ()) m) f''' $ fksFrom' s' en'
282-
g' en' s' f''' = Prelude.foldr (\(fk,_) m -> Map.insert fk (Att fk $ Var ()) m) f''' $ attsFrom' s' en'
283-
284-
evalMapping p env (MappingRaw r) = do s0 <- evalSchema p env $ mapraw_src r
285-
s1 <- evalSchema p env $ mapraw_dst r
286-
ix <- mapM (evalMapping p env) $ mapraw_imports r
287-
case s0 of
288-
SchemaEx s -> case s1 of
289-
SchemaEx (t::Schema var ty sym en fk att) ->
290-
evalMappingRaw ((convSchema s) :: Schema var ty sym en fk att) t r ix
277+
evalMapping p env (MappingId s) = do
278+
(SchemaEx s') <- evalSchema p env s
279+
pure $ MappingEx $ foldr (\en' (Mapping s'' t e f' a) -> Mapping s'' t (Map.insert en' en' e) (f'' en' s' f') (g' en' s' a)) (Mapping s' s' Map.empty Map.empty Map.empty) (S.ens s')
280+
where
281+
f'' en' s' f''' = foldr (\(fk,_) m -> Map.insert fk (Fk fk $ Var ()) m) f''' $ fksFrom' s' en'
282+
g' en' s' f''' = foldr (\(fk,_) m -> Map.insert fk (Att fk $ Var ()) m) f''' $ attsFrom' s' en'
283+
284+
evalMapping p env (MappingRaw r) = do
285+
s0 <- evalSchema p env $ mapraw_src r
286+
s1 <- evalSchema p env $ mapraw_dst r
287+
ix <- mapM (evalMapping p env) $ mapraw_imports r
288+
case s0 of
289+
SchemaEx s -> case s1 of
290+
SchemaEx (t::Schema var ty sym en fk att) ->
291+
evalMappingRaw ((convSchema s) :: Schema var ty sym en fk att) t r ix
291292

292293
f :: Typeside var ty sym -> Schema var ty sym Void Void Void
293294
f ts'' = Schema ts'' Set.empty Map.empty Map.empty Set.empty Set.empty (\x _ -> absurd x)
@@ -328,4 +329,3 @@ evalInstance prog env (InstanceDelta f' i o) = do (MappingEx (f'' :: Mapping var
328329
return $ InstanceEx r
329330

330331
evalInstance _ _ _ = undefined
331-

0 commit comments

Comments
 (0)