Skip to content

Commit

Permalink
Clean up code in and around Instance.Presentation. #148
Browse files Browse the repository at this point in the history
  • Loading branch information
@epost
epost committed Aug 21, 2019
1 parent 5b02e16 commit ee41cb2
Show file tree
Hide file tree
Showing 3 changed files with 37 additions and 43 deletions.
31 changes: 16 additions & 15 deletions src/Language/CQL.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -42,23 +42,24 @@ module Language.CQL where
import Control.Concurrent
import Control.DeepSeq
import Control.Exception
import Data.List (nub)
import qualified Data.Map.Strict as Map
import Data.List (nub)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Typeable
import Language.CQL.Common as C
import Language.CQL.Common as C
import Language.CQL.Graph
import Language.CQL.Instance as I
import Language.CQL.Mapping as M
import Language.CQL.Instance as I
import Language.CQL.Instance.Presentation as IP
import Language.CQL.Mapping as M
import Language.CQL.Options
import Language.CQL.Parser.Program (parseProgram)
import Language.CQL.Program as P
import Language.CQL.Query as Q
import Language.CQL.Schema as S
import Language.CQL.Term as Term
import Language.CQL.Transform as Tr
import Language.CQL.Typeside as T
import Prelude hiding (EQ, exp)
import Language.CQL.Parser.Program (parseProgram)
import Language.CQL.Program as P
import Language.CQL.Query as Q
import Language.CQL.Schema as S
import Language.CQL.Term as Term
import Language.CQL.Transform as Tr
import Language.CQL.Typeside as T
import Prelude hiding (EQ, exp)
import System.IO.Unsafe

-- | Times out a computation after @i@ microseconds.
Expand Down Expand Up @@ -382,8 +383,8 @@ evalTransform p env (TransformId s) = do
(InstanceEx i) <- evalInstance p env s
pure $ TransformEx $ Transform i i (h i) (g i)
where
h i = foldr (\(gen,_) m -> Map.insert gen (Gen gen) m) Map.empty $ Map.toList $ I.gens $ pres i
g i = foldr (\(sk ,_) m -> Map.insert sk (Sk sk) m) Map.empty $ Map.toList $ I.sks $ pres i
h i = foldr (\(gen,_) m -> Map.insert gen (Gen gen) m) Map.empty $ Map.toList $ IP.gens $ pres i
g i = foldr (\(sk ,_) m -> Map.insert sk (Sk sk) m) Map.empty $ Map.toList $ IP.sks $ pres i

evalTransform p env (TransformComp f g) = do
(TransformEx (f' :: Transform var ty sym en fk att gen sk x y gen' sk' x' y' )) <- evalTransform p env f
Expand Down
8 changes: 0 additions & 8 deletions src/Language/CQL/Instance.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -760,14 +760,6 @@ instance (TyMap Show '[var, ty, sym, en, fk, att, gen, sk, x, y], Eq en, Eq fk,
, section "algebra" $ show alg
]

instance TyMap Show '[var, ty, sym, en, fk, att, gen, sk]
=> Show (Presentation var ty sym en fk att gen sk) where
show (Presentation ens' _ eqs') =
unlines
[ section "generators" $ intercalate "\n" $ sepTup " : " <$> Map.toList ens'
, section "equations" $ intercalate "\n" $ Set.map show eqs'
]

instance (TyMap Show '[var, ty, sym, en, fk, att, gen, sk, x, y], Eq en, Eq fk, Eq att)
=> Show (Algebra var ty sym en fk att gen sk x y) where
show alg@(Algebra sch _ _ _ _ ty' _ _ teqs') =
Expand Down
41 changes: 21 additions & 20 deletions src/Language/CQL/Transform.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,22 +40,23 @@ along with this program. If not, see <https://www.gnu.org/licenses/>.
module Language.CQL.Transform where

import Control.DeepSeq
import Data.Map (Map, mapWithKey)
import qualified Data.Map.Strict as Map
import Data.Map (Map, mapWithKey)
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Set as Set
import Data.Typeable
import Data.Void
import Language.CQL.Common
import Language.CQL.Instance as I
import Language.CQL.Mapping as M hiding (toMorphism)
import Language.CQL.Morphism (Morphism(..), translate, translate')
import Language.CQL.Morphism as Morphism (typeOf)
import Language.CQL.Instance as I
import Language.CQL.Instance.Presentation as IP
import Language.CQL.Mapping as M hiding (toMorphism)
import Language.CQL.Morphism (Morphism(..), translate, translate')
import Language.CQL.Morphism as Morphism (typeOf)
import Language.CQL.Options
import Language.CQL.Query
import Language.CQL.Schema as S
import Language.CQL.Schema as S
import Language.CQL.Term
import Prelude hiding (EQ)
import Prelude hiding (EQ)


-- | Map from one 'Instance' to another of the same 'Schema'.
Expand Down Expand Up @@ -222,8 +223,8 @@ evalDeltaSigmaUnit
evalDeltaSigmaUnit m i o = do
j <- evalSigmaInst m i o
k <- evalDeltaInst m j o
pure $ Transform i k (mapWithKey (f j) $ I.gens $ pres i)
(mapWithKey (g j) $ I.sks $ pres i)
pure $ Transform i k (mapWithKey (f j) $ IP.gens $ pres i)
(mapWithKey (g j) $ IP.sks $ pres i)
where
f j gen en' = Gen (en', nf (algebra j) $ Gen gen)
g j sk _ = upp $ nf'' (algebra j) $ Sk sk
Expand All @@ -237,7 +238,7 @@ evalDeltaSigmaCoUnit
evalDeltaSigmaCoUnit m i o = do
j <- evalDeltaInst m i o
k <- evalSigmaInst m j o
return $ Transform k i (Map.fromList $ fmap (f j) $ Map.toList $ I.gens $ pres k) $ (Map.fromList $ fmap (g j) $ Map.toList $ I.sks $ pres k)
return $ Transform k i (Map.fromList $ fmap (f j) $ Map.toList $ IP.gens $ pres k) $ (Map.fromList $ fmap (g j) $ Map.toList $ IP.sks $ pres k)
where
f _ ((en', x), _) = ((en', x), repr (algebra i) x )
g _ (sk , _) = (sk , repr' (algebra i) sk)
Expand All @@ -253,8 +254,8 @@ evalDeltaTrans m h o = do
j <- evalDeltaInst m (dstT h) o
pure $ Transform i j (gens' i) (sks' i)
where
gens' i = mapWithKey (\(_,x) en' -> Gen (en', nf (algebra $ dstT h) $ translate' (toMorphism h) $ repr (algebra $ srcT h) x)) $ I.gens $ pres i
sks' i = mapWithKey (\y _ -> upp $ nf'' (algebra $ dstT h) $ translate (toMorphism h) $ repr' (algebra $ srcT h) y) $ I.sks $ pres i
gens' i = mapWithKey (\(_,x) en' -> Gen (en', nf (algebra $ dstT h) $ translate' (toMorphism h) $ repr (algebra $ srcT h) x)) $ IP.gens $ pres i
sks' i = mapWithKey (\y _ -> upp $ nf'' (algebra $ dstT h) $ translate (toMorphism h) $ repr' (algebra $ srcT h) y) $ IP.sks $ pres i

---------------------------------------------------------------------------------------------------------
-- Raw literals
Expand Down Expand Up @@ -304,12 +305,12 @@ evalTransformRaw' src' dst' (TransExpRaw' _ _ sec _ _) is = do
addImportGens x = foldr (Map.union . tGens) x is
addImportSks y = foldr (Map.union . tSks) y is

gens'' = I.gens $ pres src'
sks'' = I.sks $ pres src'
gens' = I.gens $ pres dst'
sks' = I.sks $ pres dst'
gens0 = filter (\(x,_) -> x `member'` gens'') sec
sks0 = filter (\(x,_) -> x `member'` sks'' ) sec
gens'' = IP.gens $ pres src'
sks'' = IP.sks $ pres src'
gens' = IP.gens $ pres dst'
sks' = IP.sks $ pres dst'
gens0 = filter (\(x,_) -> x `member'` gens'') sec
sks0 = filter (\(x,_) -> x `member'` sks'' ) sec

evalGens [] = pure Map.empty
evalGens ((gen, t):ts) = do
Expand Down

0 comments on commit ee41cb2

Please sign in to comment.