Skip to content

Commit

Permalink
Third batch of refactorings. #82
Browse files Browse the repository at this point in the history
  • Loading branch information
@epost
epost committed Oct 19, 2018
1 parent ce69f7c commit 3788609
Show file tree
Hide file tree
Showing 3 changed files with 203 additions and 176 deletions.
39 changes: 21 additions & 18 deletions src/Language/Mapping.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -116,23 +116,28 @@ trans'' _ (Att _ _) = undefined
trans'' _ (Gen (_,g)) = Gen g
trans'' _ _ = undefined

data MappingExp where
data MappingExp where
MappingVar :: String -> MappingExp
MappingId :: SchemaExp -> MappingExp
MappingRaw :: MappingExpRaw' -> MappingExp
deriving (Eq, Show)

data MappingExpRaw' = MappingExpRaw' {
mapraw_src :: SchemaExp,
mapraw_dst :: SchemaExp,
mapraw_ens :: [(String, String)]
, mapraw_fks :: [(String, [String])]
, mapraw_atts :: [(String, (String, RawTerm))]
data MappingExpRaw' =
MappingExpRaw'
{ mapraw_src :: SchemaExp
, mapraw_dst :: SchemaExp
, mapraw_ens :: [(String, String)]
, mapraw_fks :: [(String, [String])]
, mapraw_atts :: [(String, (String, RawTerm))]
, mapraw_options :: [(String, String)]
} deriving (Eq, Show)

--todo: combine with schema
conv'' :: forall ty ty2. (Typeable ty,Show ty, Typeable ty2, Show ty2) => [(String, String)] -> Err [(ty2, ty)]
conv''
:: forall ty ty2
. (Typeable ty,Show ty, Typeable ty2, Show ty2)
=> [(String, String)]
-> Err [(ty2, ty)]
conv'' [] = pure []
conv'' ((ty2,ty):tl) = case cast ty :: Maybe ty of
Just ty' -> do x <- conv'' tl
Expand All @@ -141,16 +146,14 @@ conv'' ((ty2,ty):tl) = case cast ty :: Maybe ty of
Nothing -> Left $ "Not in source schema/typeside: " ++ show ty2
Nothing -> Left $ "Not in target schema/typeside: " ++ show ty

cast' :: (Typeable x, Typeable y) => x -> String -> Err y
cast' x s = case cast x of
Nothing -> Left s
Just y -> return y

elem' :: (Typeable t, Typeable a, Eq a) => t -> [a] -> Bool
elem' _ [] = False
elem' x (a:b) = case cast x of
Nothing -> elem' x b
Just x' -> x' == a || elem' x b
elem' x (y:ys) = case cast x of
Nothing -> elem' x ys
Just x' -> x' == y || elem' x ys

member' :: (Typeable t, Typeable a, Eq a) => t -> Map a v -> Bool
member' k m = elem' k (Map.keys m)

evalMappingRaw' :: forall var ty sym en fk att en' fk' att' .
(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,
Expand All @@ -171,7 +174,7 @@ evalMappingRaw' src' dst' (MappingExpRaw' _ _ ens0 fks0 atts0 _) =
f [] = pure $ Map.empty
f ((att, (v, t)):ts) = do t' <- return $ g v (keys' fks') (keys' atts') t
rest <- f ts
att' <- cast' att $ "Not an attribute " ++ att
att' <- note ("Not an attribute " ++ att) (cast att)
pure $ Map.insert att' t' rest
--g' :: String ->[String]-> [String] -> RawTerm-> Term () Void Void en Fk Void Void Void
g' v _ _ (RawApp x []) | v == x = Var ()
Expand All @@ -195,7 +198,7 @@ evalMappingRaw' src' dst' (MappingExpRaw' _ _ ens0 fks0 atts0 _) =
k ((fk,p):eqs') =do p' <- h ens' $ reverse p
_ <- findEn ens' fks' p
rest <- k eqs'
fk' <- cast' fk $ "Not a src fk: fk"
fk' <- note ("Not a src fk: " ++ fk) (cast fk)
pure $ Map.insert fk' p' rest
findEn ens'' _ (s:_) | elem' s ens'' = return $ fromJust $ cast s
findEn _ fks'' (s:_) | elem' s (keys' $ fks'') = return $ fst $ fromJust $ Prelude.lookup (fromJust $ cast s) fks''
Expand Down
80 changes: 40 additions & 40 deletions src/Language/Term.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -266,14 +266,17 @@ trans mor (Fk f a) = let x = trans mor a :: Term var' ty sym en' fk' att' gen' s
trans mor (Att f a) = subst (up14 $ fromJust $ Map.lookup f (m_atts mor)) $ trans mor a


subst :: Eq var => Term () ty sym en fk att gen sk ->
Term var ty sym en fk att gen sk -> Term var ty sym en fk att gen sk
subst (Var ()) t = t
subst (Sym f as) t = Sym f $ Prelude.map (\x -> subst x t) as
subst (Fk f a) t = Fk f $ subst a t
subst (Att f a) t = Att f $ subst a t
subst (Gen g) _ = Gen g
subst (Sk g) _ = Sk g
subst
:: Eq var
=> Term () ty sym en fk att gen sk
-> Term var ty sym en fk att gen sk
-> Term var ty sym en fk att gen sk
subst (Var () ) t = t
subst (Sym f as) t = Sym f $ (\a -> subst a t) <$> as
subst (Fk f a ) t = Fk f $ subst a t
subst (Att f a ) t = Att f $ subst a t
subst (Gen g ) _ = Gen g
subst (Sk g ) _ = Sk g


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

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)
closeGround col (me, mt) = (me', mt'')
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
mt' = Prelude.foldr (\(_, (en,ty)) m -> if lookup2 en me' then Map.insert ty True m else m) mt $ Map.toList $ catts col
me' = Prelude.foldr (\(_, (en,_)) m -> if lookup2 en me then Map.insert en True m else m) me $ Map.toList $ cfks col
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
mt' = Prelude.foldr (\(_, (en, ty)) m -> if lookup2 en me' then Map.insert ty True m else m) mt $ Map.toList $ catts col
me' = Prelude.foldr (\(_, (en, _)) m -> if lookup2 en me then Map.insert en True m else m) me $ Map.toList $ cfks col

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)
iterGround col r = if r == r' then r else iterGround col r'
Expand All @@ -379,12 +382,12 @@ typeOf'
typeOf' _ ctx (Var v) = note ("Unbound variable: " ++ show v) $ Map.lookup v ctx
typeOf' col _ (Gen g) = case Map.lookup g $ cgens col of
Nothing -> Left $ "Unknown generator: " ++ show g
Just t -> pure $ Right t
Just t -> Right $ Right t
typeOf' col _ (Sk s) = case Map.lookup s $ csks col of
Nothing -> Left $ "Unknown labelled null: " ++ show s
Just t -> pure $ Left t
Just t -> Right $ Left t
typeOf' col ctx (xx@(Fk f a)) = case Map.lookup f $ cfks col of
Nothing -> Left $ "Unknown foreign key: " ++ show f
Nothing -> Left $ "Unknown foreign key: " ++ show f
Just (s, t) -> do s' <- typeOf' col ctx a
if (Right s) == s' then pure $ Right t else Left $ "Expected argument to have entity " ++
show s ++ " but given " ++ show s' ++ " in " ++ (show xx)
Expand All @@ -397,7 +400,7 @@ typeOf' col ctx (xx@(Sym f a)) = case Map.lookup f $ csyms col of
Nothing -> Left $ "Unknown function symbol: " ++ show f
Just (s, t) -> do s' <- mapM (typeOf' col ctx) a
if length s' == length s
then if (fmap Left s) == s'
then if (Left <$> s) == s'
then pure $ Left t
else Left $ "Expected arguments to have types " ++
show s ++ " but given " ++ show s' ++ " in " ++ (show $ xx)
Expand All @@ -409,19 +412,20 @@ typeOfEq'
=> Collage var ty sym en fk att gen sk
-> (Ctx var (ty + en), EQ var ty sym en fk att gen sk)
-> Err (ty + en)
typeOfEq' col (ctx, EQ (lhs, rhs)) = do lhs' <- typeOf' col ctx lhs
rhs' <- typeOf' col ctx rhs
if lhs' == rhs'
then pure lhs'
else Left $ "Equation lhs has type " ++ show lhs' ++ " but rhs has type " ++ show rhs'
typeOfEq' col (ctx, EQ (lhs, rhs)) = do
lhs' <- typeOf' col ctx lhs
rhs' <- typeOf' col ctx rhs
if lhs' == rhs'
then Right $ lhs'
else Left $ "Equation lhs has type " ++ show lhs' ++ " but rhs has type " ++ show rhs'

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)
=> Collage var ty sym en fk att gen sk
-> Err ()
checkDoms col = do
_ <- mapM f $ Map.elems $ csyms col
_ <- mapM g $ Map.elems $ cfks col
_ <- mapM h $ Map.elems $ catts col
_ <- mapM f $ Map.elems $ csyms col
_ <- mapM g $ Map.elems $ cfks col
_ <- mapM h $ Map.elems $ catts col
_ <- mapM isEn $ Map.elems $ cgens col
_ <- mapM isTy $ Map.elems $ csks col
pure ()
Expand All @@ -443,10 +447,10 @@ typeOfCol
:: (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)
=> Collage var ty sym en fk att gen sk
-> Err ()
typeOfCol col = do checkDoms col
_ <- mapM (typeOfEq' col) $ Set.toList $ ceqs col
pure ()

typeOfCol col = do
checkDoms col
mapM_ (typeOfEq' col) $ Set.toList $ ceqs col
pure ()

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

upTerm
:: Term var Void Void en fk Void gen Void -> Term var ty sym en fk att gen sk
upTerm
(Var v) = Var v
upTerm
(Fk f a) = Fk f $ upTerm a
upTerm
(Gen g) = Gen g
upTerm
(Sym f _) = absurd f
upTerm
(Sk f) = absurd f
upTerm
(Att f _) = absurd f
:: Term var Void Void en fk Void gen Void
-> Term var ty sym en fk att gen sk
upTerm t = case t of
Var v -> Var v
Fk f a -> Fk f $ upTerm a
Gen g -> Gen g
Sym f _ -> absurd f
Sk f -> absurd f
Att f _ -> absurd f

--Set is not Traversable! Lame
Loading

0 comments on commit 3788609

Please sign in to comment.