Skip to content

Commit 3788609

Browse files
epostepost
committed
Third batch of refactorings. #82 
1 parent ce69f7c commit 3788609

File tree

3 files changed

+203
-176
lines changed

3 files changed

+203
-176
lines changed

‎src/Language/Mapping.hs

+21-18
Original file line numberDiff line numberDiff line change
@@ -116,23 +116,28 @@ trans'' _ (Att _ _) = undefined
116116
trans'' _ (Gen (_,g)) = Gen g
117117
trans'' _ _ = undefined
118118

119-
data MappingExp where
119+
data MappingExp where
120120
MappingVar :: String -> MappingExp
121121
MappingId :: SchemaExp -> MappingExp
122122
MappingRaw :: MappingExpRaw' -> MappingExp
123123
deriving (Eq, Show)
124124

125-
data MappingExpRaw' = MappingExpRaw' {
126-
mapraw_src :: SchemaExp,
127-
mapraw_dst :: SchemaExp,
128-
mapraw_ens :: [(String, String)]
129-
, mapraw_fks :: [(String, [String])]
130-
, mapraw_atts :: [(String, (String, RawTerm))]
125+
data MappingExpRaw' =
126+
MappingExpRaw'
127+
{ mapraw_src :: SchemaExp
128+
, mapraw_dst :: SchemaExp
129+
, mapraw_ens :: [(String, String)]
130+
, mapraw_fks :: [(String, [String])]
131+
, mapraw_atts :: [(String, (String, RawTerm))]
131132
, mapraw_options :: [(String, String)]
132133
} deriving (Eq, Show)
133134

134135
--todo: combine with schema
135-
conv'' :: forall ty ty2. (Typeable ty,Show ty, Typeable ty2, Show ty2) => [(String, String)] -> Err [(ty2, ty)]
136+
conv''
137+
:: forall ty ty2
138+
. (Typeable ty,Show ty, Typeable ty2, Show ty2)
139+
=> [(String, String)]
140+
-> Err [(ty2, ty)]
136141
conv'' [] = pure []
137142
conv'' ((ty2,ty):tl) = case cast ty :: Maybe ty of
138143
Just ty' -> do x <- conv'' tl
@@ -141,16 +146,14 @@ conv'' ((ty2,ty):tl) = case cast ty :: Maybe ty of
141146
Nothing -> Left $ "Not in source schema/typeside: " ++ show ty2
142147
Nothing -> Left $ "Not in target schema/typeside: " ++ show ty
143148

144-
cast' :: (Typeable x, Typeable y) => x -> String -> Err y
145-
cast' x s = case cast x of
146-
Nothing -> Left s
147-
Just y -> return y
148-
149149
elem' :: (Typeable t, Typeable a, Eq a) => t -> [a] -> Bool
150150
elem' _ [] = False
151-
elem' x (a:b) = case cast x of
152-
Nothing -> elem' x b
153-
Just x' -> x' == a || elem' x b
151+
elem' x (y:ys) = case cast x of
152+
Nothing -> elem' x ys
153+
Just x' -> x' == y || elem' x ys
154+
155+
member' :: (Typeable t, Typeable a, Eq a) => t -> Map a v -> Bool
156+
member' k m = elem' k (Map.keys m)
154157

155158
evalMappingRaw' :: forall var ty sym en fk att en' fk' att' .
156159
(Ord var, Ord ty, Ord sym, Show att, Show att', Show sym, Show var, Show ty, Typeable en, Typeable en', Ord en, Show en, Show en', Typeable sym, Typeable att, Typeable fk, Show fk,
@@ -171,7 +174,7 @@ evalMappingRaw' src' dst' (MappingExpRaw' _ _ ens0 fks0 atts0 _) =
171174
f [] = pure $ Map.empty
172175
f ((att, (v, t)):ts) = do t' <- return $ g v (keys' fks') (keys' atts') t
173176
rest <- f ts
174-
att' <- cast' att $ "Not an attribute " ++ att
177+
att' <- note ("Not an attribute " ++ att) (cast att)
175178
pure $ Map.insert att' t' rest
176179
--g' :: String ->[String]-> [String] -> RawTerm-> Term () Void Void en Fk Void Void Void
177180
g' v _ _ (RawApp x []) | v == x = Var ()
@@ -195,7 +198,7 @@ evalMappingRaw' src' dst' (MappingExpRaw' _ _ ens0 fks0 atts0 _) =
195198
k ((fk,p):eqs') =do p' <- h ens' $ reverse p
196199
_ <- findEn ens' fks' p
197200
rest <- k eqs'
198-
fk' <- cast' fk $ "Not a src fk: fk"
201+
fk' <- note ("Not a src fk: " ++ fk) (cast fk)
199202
pure $ Map.insert fk' p' rest
200203
findEn ens'' _ (s:_) | elem' s ens'' = return $ fromJust $ cast s
201204
findEn _ fks'' (s:_) | elem' s (keys' $ fks'') = return $ fst $ fromJust $ Prelude.lookup (fromJust $ cast s) fks''

‎src/Language/Term.hs

+40-40
Original file line numberDiff line numberDiff line change
@@ -266,14 +266,17 @@ trans mor (Fk f a) = let x = trans mor a :: Term var' ty sym en' fk' att' gen' s
266266
trans mor (Att f a) = subst (up14 $ fromJust $ Map.lookup f (m_atts mor)) $ trans mor a
267267

268268

269-
subst :: Eq var => Term () ty sym en fk att gen sk ->
270-
Term var ty sym en fk att gen sk -> Term var ty sym en fk att gen sk
271-
subst (Var ()) t = t
272-
subst (Sym f as) t = Sym f $ Prelude.map (\x -> subst x t) as
273-
subst (Fk f a) t = Fk f $ subst a t
274-
subst (Att f a) t = Att f $ subst a t
275-
subst (Gen g) _ = Gen g
276-
subst (Sk g) _ = Sk g
269+
subst
270+
:: Eq var
271+
=> Term () ty sym en fk att gen sk
272+
-> Term var ty sym en fk att gen sk
273+
-> Term var ty sym en fk att gen sk
274+
subst (Var () ) t = t
275+
subst (Sym f as) t = Sym f $ (\a -> subst a t) <$> as
276+
subst (Fk f a ) t = Fk f $ subst a t
277+
subst (Att f a ) t = Att f $ subst a t
278+
subst (Gen g ) _ = Gen g
279+
subst (Sk g ) _ = Sk g
277280

278281

279282
checkDoms' :: forall var ty sym en fk att gen sk en' fk' att' gen' sk' .
@@ -351,9 +354,9 @@ initGround col = (me', mt')
351354

352355
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)
353356
closeGround col (me, mt) = (me', mt'')
354-
where mt''= Prelude.foldr (\(_, (tys,ty)) m -> if and (Prelude.map (\ty'->lookup2 ty' mt') tys) then Map.insert ty True m else m) mt' $ Map.toList $ csyms col
355-
mt' = Prelude.foldr (\(_, (en,ty)) m -> if lookup2 en me' then Map.insert ty True m else m) mt $ Map.toList $ catts col
356-
me' = Prelude.foldr (\(_, (en,_)) m -> if lookup2 en me then Map.insert en True m else m) me $ Map.toList $ cfks col
357+
where mt''= Prelude.foldr (\(_, (tys,ty)) m -> if and ((flip lookup2 mt') <$> tys) then Map.insert ty True m else m) mt' $ Map.toList $ csyms col
358+
mt' = Prelude.foldr (\(_, (en, ty)) m -> if lookup2 en me' then Map.insert ty True m else m) mt $ Map.toList $ catts col
359+
me' = Prelude.foldr (\(_, (en, _)) m -> if lookup2 en me then Map.insert en True m else m) me $ Map.toList $ cfks col
357360

358361
iterGround :: (Ord ty, Ord en, Show en, Show ty) => Collage var ty sym en fk att gen sk -> (Map en Bool, Map ty Bool) -> (Map en Bool, Map ty Bool)
359362
iterGround col r = if r == r' then r else iterGround col r'
@@ -379,12 +382,12 @@ typeOf'
379382
typeOf' _ ctx (Var v) = note ("Unbound variable: " ++ show v) $ Map.lookup v ctx
380383
typeOf' col _ (Gen g) = case Map.lookup g $ cgens col of
381384
Nothing -> Left $ "Unknown generator: " ++ show g
382-
Just t -> pure $ Right t
385+
Just t -> Right $ Right t
383386
typeOf' col _ (Sk s) = case Map.lookup s $ csks col of
384387
Nothing -> Left $ "Unknown labelled null: " ++ show s
385-
Just t -> pure $ Left t
388+
Just t -> Right $ Left t
386389
typeOf' col ctx (xx@(Fk f a)) = case Map.lookup f $ cfks col of
387-
Nothing -> Left $ "Unknown foreign key: " ++ show f
390+
Nothing -> Left $ "Unknown foreign key: " ++ show f
388391
Just (s, t) -> do s' <- typeOf' col ctx a
389392
if (Right s) == s' then pure $ Right t else Left $ "Expected argument to have entity " ++
390393
show s ++ " but given " ++ show s' ++ " in " ++ (show xx)
@@ -397,7 +400,7 @@ typeOf' col ctx (xx@(Sym f a)) = case Map.lookup f $ csyms col of
397400
Nothing -> Left $ "Unknown function symbol: " ++ show f
398401
Just (s, t) -> do s' <- mapM (typeOf' col ctx) a
399402
if length s' == length s
400-
then if (fmap Left s) == s'
403+
then if (Left <$> s) == s'
401404
then pure $ Left t
402405
else Left $ "Expected arguments to have types " ++
403406
show s ++ " but given " ++ show s' ++ " in " ++ (show $ xx)
@@ -409,19 +412,20 @@ typeOfEq'
409412
=> Collage var ty sym en fk att gen sk
410413
-> (Ctx var (ty + en), EQ var ty sym en fk att gen sk)
411414
-> Err (ty + en)
412-
typeOfEq' col (ctx, EQ (lhs, rhs)) = do lhs' <- typeOf' col ctx lhs
413-
rhs' <- typeOf' col ctx rhs
414-
if lhs' == rhs'
415-
then pure lhs'
416-
else Left $ "Equation lhs has type " ++ show lhs' ++ " but rhs has type " ++ show rhs'
415+
typeOfEq' col (ctx, EQ (lhs, rhs)) = do
416+
lhs' <- typeOf' col ctx lhs
417+
rhs' <- typeOf' col ctx rhs
418+
if lhs' == rhs'
419+
then Right $ lhs'
420+
else Left $ "Equation lhs has type " ++ show lhs' ++ " but rhs has type " ++ show rhs'
417421

418422
checkDoms :: (Ord var, Show var, Ord gen, Show gen, Ord sk, Show sk, Ord fk, Show fk, Ord en, Show en, Show ty, Ord ty, Show att, Ord att, Show sym, Ord sym)
419423
=> Collage var ty sym en fk att gen sk
420424
-> Err ()
421425
checkDoms col = do
422-
_ <- mapM f $ Map.elems $ csyms col
423-
_ <- mapM g $ Map.elems $ cfks col
424-
_ <- mapM h $ Map.elems $ catts col
426+
_ <- mapM f $ Map.elems $ csyms col
427+
_ <- mapM g $ Map.elems $ cfks col
428+
_ <- mapM h $ Map.elems $ catts col
425429
_ <- mapM isEn $ Map.elems $ cgens col
426430
_ <- mapM isTy $ Map.elems $ csks col
427431
pure ()
@@ -443,10 +447,10 @@ typeOfCol
443447
:: (Ord var, Show var, Ord gen, Show gen, Ord sk, Show sk, Ord fk, Show fk, Ord en, Show en, Show ty, Ord ty, Show att, Ord att, Show sym, Ord sym)
444448
=> Collage var ty sym en fk att gen sk
445449
-> Err ()
446-
typeOfCol col = do checkDoms col
447-
_ <- mapM (typeOfEq' col) $ Set.toList $ ceqs col
448-
pure ()
449-
450+
typeOfCol col = do
451+
checkDoms col
452+
mapM_ (typeOfEq' col) $ Set.toList $ ceqs col
453+
pure ()
450454

451455
data RawTerm = RawApp String [RawTerm]
452456
deriving Eq
@@ -455,18 +459,14 @@ instance Show RawTerm where
455459
show (RawApp sym az) = show sym ++ "(" ++ (intercalate "," . fmap show $ az) ++ ")"
456460

457461
upTerm
458-
:: Term var Void Void en fk Void gen Void -> Term var ty sym en fk att gen sk
459-
upTerm
460-
(Var v) = Var v
461-
upTerm
462-
(Fk f a) = Fk f $ upTerm a
463-
upTerm
464-
(Gen g) = Gen g
465-
upTerm
466-
(Sym f _) = absurd f
467-
upTerm
468-
(Sk f) = absurd f
469-
upTerm
470-
(Att f _) = absurd f
462+
:: Term var Void Void en fk Void gen Void
463+
-> Term var ty sym en fk att gen sk
464+
upTerm t = case t of
465+
Var v -> Var v
466+
Fk f a -> Fk f $ upTerm a
467+
Gen g -> Gen g
468+
Sym f _ -> absurd f
469+
Sk f -> absurd f
470+
Att f _ -> absurd f
471471

472472
--Set is not Traversable! Lame

0 commit comments

Comments
 (0)