Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Merge pivot before cyclic imports force big file changes #128

Closed
wants to merge 6 commits into from
Closed

Merge pivot before cyclic imports force big file changes #128

Changes from 1 commit
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
9bd0d38
more on pivot
wisnesky Dec 3, 2018
f241122
pivot is essentially done but finishing it causes cyclic imports
wisnesky Dec 3, 2018
875628b
.
wisnesky Dec 3, 2018
863dace
.
wisnesky Dec 3, 2018
012f6c7
code formatting and styling #38
marcosh Dec 11, 2018
192c8e7
Merge pull request #129 from statebox/38/code-formatting-and-styling
wisnesky Dec 11, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Next Next commit
more on pivot
  • Loading branch information
@wisnesky
wisnesky committed Dec 3, 2018
commit 9bd0d38a4036aebcf09d7f5b8cd98d3b9c7246f2
65 changes: 43 additions & 22 deletions src/Language/Instance.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -589,42 +589,63 @@ emptyInstance ts'' = Instance ts''
(const Set.empty) (const undefined) (const undefined)
Set.empty)

pivot
:: (ShowOrdTypeableN '[var, ty, sym, en, fk, att, gen, sk, x, y])
=> Instance var ty sym en fk att gen sk x y
-> (Schema var ty sym x (x, fk) (x, att)
, Instance var ty sym x (x, fk) (x, att) x sk x y
, Mapping var ty sym x (x, fk) (x, att) en fk att)
pivot (Instance sch (Presentation _ sks _) _ (Algebra _ ens _ fk _ tys nnf _ teqs)) = (sch', inst, mapp)
pivot :: forall var ty sym en fk att gen sk x y
. (ShowOrdTypeableN '[var, ty, sym, en, fk, att, gen, sk, x, y])
=> Instance var ty sym en fk att gen sk x y
-> (Schema var ty sym (x, en) (x, fk) (x, att)
, Instance var ty sym (x, en) (x, fk) (x, att) (x, en) y (x, en) y
, Mapping var ty sym (x, en) (x, fk) (x, att) en fk att)
pivot (Instance sch (Presentation _ sks _) idp (Algebra _ ens gens'' fk fn tys nnf rep2'' teqs)) = (sch', inst, mapp)
where
sch'_ens = Set.fromList $ concat [ Set.toList (ens en ) | en <- Set.toList (Schema.ens sch) ]
sch'_fks = Map.fromList [ ((x, fk0 ), (x, fk fk0 x)) | en <- Set.toList (Schema.ens sch), x <- Set.toList (ens en), (fk0, _ ) <- fksFrom' sch en ]
sch'_atts = Map.fromList [ ((x, att0), (x, ty' )) | en <- Set.toList (Schema.ens sch), x <- Set.toList (ens en), (att0, ty') <- attsFrom' sch en ]
sch'_ens = Set.fromList [ (x, en) | en <- Set.toList (Schema.ens sch), x <- Set.toList (ens en)]
sch'_fks = Map.fromList [ ((x, fk0 ), ((x, en), (fk fk0 x, en'))) | en <- Set.toList (Schema.ens sch), x <- Set.toList (ens en), (fk0, en') <- fksFrom' sch en ]
sch'_atts = Map.fromList [ ((x, att0), ((x, en), ty' )) | en <- Set.toList (Schema.ens sch), x <- Set.toList (ens en), (att0, ty') <- attsFrom' sch en ]
sch'_peqs = Set.empty
sch'_oeqs = Set.empty
dp' = undefined
ens' = Set.singleton
dp' :: EQ Void ty sym (x, en) (x, fk) (x, att) (x, en) y -> Bool
dp' (EQ (l, r)) = idp $ EQ (instToInst l, instToInst r)
ens' = Set.singleton
epost marked this conversation as resolved.
Show resolved Hide resolved
gen' = id
fk' (x, f) x' | x == x' = fk f x
| otherwise = error "pivot anomaly, please report"
fk' (x, f) (x', en) | x == x' = (fk f x', snd $ Schema.sch_fks sch ! f)
| otherwise = error "anomaly, please report"
rep' = Gen
nnf' (Left sk) = nnf (Left sk)
nnf' (Right (x, (x', att))) | x == x' = nnf $ Right (x, att)
| otherwise = error "pivot anomaly 2, please report"
rep2' = undefined
gens' = Map.fromList [ (x, x) | en <- Set.toList (Schema.ens sch), x <- Set.toList (ens en) ]
sks' = sks
nnf' (Left sk) = Sk sk
nnf' (Right ((x, en), (x', att))) | x == x' = nnf $ Right (x', att)
| otherwise = error "anomaly, please report"
rep2' = Sk
gens' = Map.fromList [ ((x, en), (x, en)) | en <- Set.toList (Schema.ens sch), x <- Set.toList (ens en) ]
sks' = Map.fromList [ ( y, ty) | ty <- Set.toList (Typeside.tys $ typeside sch), y <- Set.toList (tys ty) ]
eqs' = undefined
es' = teqs
tys' = tys
em = Map.fromList [ (x, en ) | en <- Set.toList (Schema.ens sch), x <- Set.toList (ens en) ]
em = Map.fromList [ ((x, en) , en) | en <- Set.toList (Schema.ens sch), x <- Set.toList (ens en) ]
fm = Map.fromList [ ((x, fk ) , Fk fk $ Var ()) | (x, fk ) <- Map.keys sch'_fks ]
am = Map.fromList [ ((x, att) , Att att $ Var ()) | (x, att) <- Map.keys sch'_atts ]
dp2 _ (EQ (l, r)) = l == r -- todo: stopping for now, this definition is wrong and AQL java should change too

dp2 :: (x, en) -> EQ () ty sym (x, en) (x, fk) (x, att) Void Void -> Bool
dp2 (x, en) (EQ (l, r)) = idp $ EQ (schToInst' x l, schToInst' x r)

sch' = Schema (typeside sch) sch'_ens sch'_fks sch'_atts sch'_peqs sch'_oeqs dp2
inst = Instance sch' (Presentation gens' sks' eqs') dp' $ Algebra sch' ens' gen' fk' rep' tys' nnf' rep2' es'
mapp = Mapping sch' sch em fm am

schToInst' :: x -> Term () ty sym (x, en) (x, fk) (x, att) Void Void -> Term Void ty sym en fk att gen sk
schToInst' x z = case z of
Sym f as -> Sym f $ fmap (schToInst' x) as
epost marked this conversation as resolved.
Show resolved Hide resolved
Att (x', f) a -> Att f $ schToInst' x a
Sk x0 -> absurd x0
Var () -> upp $ fn x
Fk (x', f) a -> Fk f $ schToInst' x a
Gen x0 -> absurd x0
epost marked this conversation as resolved.
Show resolved Hide resolved

instToInst :: Term Void ty sym (x, en) (x, fk) (x, att) (x, en) y -> Term Void ty sym en fk att gen sk
instToInst z = case z of
Sym f as -> Sym f $ fmap instToInst as
epost marked this conversation as resolved.
Show resolved Hide resolved
Att (x', f) a -> Att f $ instToInst a
Sk y -> rep2'' y
Var x -> absurd x
Fk (x', f) a -> Fk f $ instToInst a
Gen (x, _) -> upp $ fn x

-- coproducts, etc

Expand Down