|
| 1 | +{- |
| 2 | +SPDX-License-Identifier: AGPL-3.0-only |
| 3 | +
|
| 4 | +This file is part of `statebox/cql`, the categorical query language. |
| 5 | +
|
| 6 | +Copyright (C) 2019 Stichting Statebox <https://statebox.nl> |
| 7 | +
|
| 8 | +This program is free software: you can redistribute it and/or modify |
| 9 | +it under the terms of the GNU Affero General Public License as published by |
| 10 | +the Free Software Foundation, either version 3 of the License, or |
| 11 | +(at your option) any later version. |
| 12 | +
|
| 13 | +This program is distributed in the hope that it will be useful, |
| 14 | +but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 15 | +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 16 | +GNU Affero General Public License for more details. |
| 17 | +
|
| 18 | +You should have received a copy of the GNU Affero General Public License |
| 19 | +along with this program. If not, see <https://www.gnu.org/licenses/>. |
| 20 | +-} |
| 21 | +{-# LANGUAGE AllowAmbiguousTypes #-} |
| 22 | +{-# LANGUAGE DataKinds #-} |
| 23 | +{-# LANGUAGE DuplicateRecordFields #-} |
| 24 | +{-# LANGUAGE ExplicitForAll #-} |
| 25 | +{-# LANGUAGE FlexibleContexts #-} |
| 26 | +{-# LANGUAGE FlexibleInstances #-} |
| 27 | +{-# LANGUAGE GADTs #-} |
| 28 | +{-# LANGUAGE KindSignatures #-} |
| 29 | +{-# LANGUAGE LiberalTypeSynonyms #-} |
| 30 | +{-# LANGUAGE MultiParamTypeClasses #-} |
| 31 | +{-# LANGUAGE RankNTypes #-} |
| 32 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 33 | +{-# LANGUAGE StandaloneDeriving #-} |
| 34 | +{-# LANGUAGE TupleSections #-} |
| 35 | +{-# LANGUAGE TypeOperators #-} |
| 36 | +{-# LANGUAGE TypeSynonymInstances #-} |
| 37 | +{-# LANGUAGE UndecidableInstances #-} |
| 38 | + |
| 39 | +module Language.CQL.Instance.Presentation where |
| 40 | + |
| 41 | +import Control.DeepSeq (deepseq, NFData(..)) |
| 42 | +import Data.Map.Strict (Map) |
| 43 | +import qualified Data.Map.Strict as Map |
| 44 | +import Data.Maybe () |
| 45 | +import Data.Set (Set) |
| 46 | +import qualified Data.Set as Set |
| 47 | +import Data.Void |
| 48 | +import Language.CQL.Collage (Collage(..), typeOfCol) |
| 49 | +import Language.CQL.Common (Err, MultiTyMap, TyMap, type (+), section, sepTup, intercalate) |
| 50 | +import Language.CQL.Schema (Schema, schToCol) |
| 51 | +import Language.CQL.Term as Term |
| 52 | +import Prelude hiding (EQ) |
| 53 | + |
| 54 | +-- | A presentation of an @Instance@. |
| 55 | +data Presentation var ty sym en fk att gen sk |
| 56 | + = Presentation |
| 57 | + { gens :: Map gen en |
| 58 | + , sks :: Map sk ty |
| 59 | + , eqs :: Set (EQ Void ty sym en fk att gen sk) |
| 60 | + } |
| 61 | + |
| 62 | +instance TyMap Show '[var, ty, sym, en, fk, att, gen, sk] |
| 63 | + => Show (Presentation var ty sym en fk att gen sk) where |
| 64 | + show (Presentation ens' _ eqs') = |
| 65 | + unlines |
| 66 | + [ section "generators" $ intercalate "\n" $ sepTup " : " <$> Map.toList ens' |
| 67 | + , section "equations" $ intercalate "\n" $ Set.map show eqs' |
| 68 | + ] |
| 69 | + |
| 70 | +instance (NFData ty, NFData sym, NFData en, NFData fk, NFData att, NFData gen, NFData sk) |
| 71 | + => NFData (Presentation var ty sym en fk att gen sk) where |
| 72 | + rnf (Presentation g s e) = deepseq g $ deepseq s $ rnf e |
| 73 | + |
| 74 | +-- | Checks that an instance presentation is a well-formed theory. |
| 75 | +typecheckPresentation |
| 76 | + :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk]) |
| 77 | + => Schema var ty sym en fk att |
| 78 | + -> Presentation var ty sym en fk att gen sk |
| 79 | + -> Err () |
| 80 | +typecheckPresentation sch p = typeOfCol $ presToCol sch p |
| 81 | + |
| 82 | +--created as an alias because of name clashes |
| 83 | +eqs0 |
| 84 | + :: Presentation var ty sym en fk att gen sk |
| 85 | + -> Set (EQ Void ty sym en fk att gen sk) |
| 86 | +eqs0 (Presentation _ _ x) = x |
| 87 | + |
| 88 | +-- | Converts a presentation to a collage. |
| 89 | +presToCol |
| 90 | + :: (MultiTyMap '[Show, Ord, NFData] '[var, ty, sym, en, fk, att, gen, sk]) |
| 91 | + => Schema var ty sym en fk att |
| 92 | + -> Presentation var ty sym en fk att gen sk |
| 93 | + -> Collage (()+var) ty sym en fk att gen sk |
| 94 | +presToCol sch (Presentation gens' sks' eqs') = |
| 95 | + Collage (Set.union e1 e2) (ctys schcol) |
| 96 | + (cens schcol) (csyms schcol) (cfks schcol) (catts schcol) gens' sks' |
| 97 | + where |
| 98 | + schcol = schToCol sch |
| 99 | + e1 = Set.map (\( EQ (l,r)) -> (Map.empty, EQ (upp l, upp r))) eqs' |
| 100 | + e2 = Set.map (\(g, EQ (l,r)) -> (g, EQ (upp l, upp r))) $ ceqs schcol |
0 commit comments