ConceptStructure.hs

{-# LANGUAGE FlexibleInstances #-}
module Database.Design.Ampersand.Classes.ConceptStructure (ConceptStructure(..)) where      

import Database.Design.Ampersand.Core.AbstractSyntaxTree
import Database.Design.Ampersand.Basics
import Data.List
import Data.Maybe
import Database.Design.Ampersand.ADL1.Expression(primitives,isMp1,foldrMapExpression)
import Database.Design.Ampersand.Classes.ViewPoint
import Prelude hiding (Ordering(..))

fatal :: Int -> String -> a
fatal = fatalMsg "Classes.ConceptStructure"

{- TODO: Interface parameters (of type Declaration) are returned as Expressions by expressionsIn, to preserve the meaning of relsMentionedIn
   (implemented using primsMentionedIn, which calls expressionsIn). A more correct way to do this would be to not use expressionsIn, but
   define relsMentionedIn directly.
   
   Another improvement would be to factorize the prim constructors from the Expression data type, so expressionsIn won't need to be partial
   anymore.
-}

class ConceptStructure a where
  concs ::    a -> [A_Concept]       -- ^ the set of all concepts used in data structure a
  relsUsedIn :: a -> [Declaration]        -- ^ the set of all declaratons used within data structure a. `used within` means that there is a relation that refers to that declaration.
  relsUsedIn a = [ d | d@Sgn{}<-relsMentionedIn a]++[Isn c | c<-concs a]
  relsMentionedIn :: a -> [Declaration]        -- ^ the set of all declaratons used within data structure a. `used within` means that there is a relation that refers to that declaration.
  relsMentionedIn = nub . map prim2rel . primsMentionedIn
  primsMentionedIn :: a -> [Expression]
  primsMentionedIn = nub . concatMap primitives . expressionsIn
  expressionsIn :: a -> [Expression] -- ^The set of all expressions within data structure a
  
  -- | mp1Pops draws the population from singleton expressions.
  mp1Pops :: a -> [Population]
  mp1Pops struc
   = [ PCptPopu{ popcpt = cpt (head cl)
               , popas = map atm cl } 
     | cl<-eqCl cpt ((filter isMp1.primsMentionedIn) struc)]
     where cpt (EMp1 _ c) = c
           cpt _          = fatal 31 "cpt error"
           atm (EMp1 a _) = a
           atm _          = fatal 31 "atm error"
           
prim2rel :: Expression -> Declaration
prim2rel e
 = case e of
    EDcD d@Sgn{} -> d
    EDcD{}       -> fatal 23 "invalid declaration in EDcD{}"
    EDcI c       -> Isn c
    EDcV sgn     -> Vs sgn
    EMp1 _ c     -> Isn c
    _            -> fatal 40 $ "only primitive expressions should be found here.\nHere we see: " ++ show e

instance (ConceptStructure a,ConceptStructure b) => ConceptStructure (a, b)  where
  concs    (a,b) = concs a `uni` concs b
  expressionsIn (a,b) = expressionsIn a `uni` expressionsIn b

instance ConceptStructure a => ConceptStructure (Maybe a) where
  concs    ma = maybe [] concs ma
  expressionsIn ma = maybe [] expressionsIn ma

instance ConceptStructure a => ConceptStructure [a] where
  concs     = nub . concatMap concs
  expressionsIn = foldr ((uni) . expressionsIn) []

instance ConceptStructure A_Context where
  concs ctx = foldr uni []
              [ (concs.ctxpats) ctx
              , (concs.ctxrs) ctx
              , (concs.ctxds) ctx
              , (concs.ctxpopus) ctx
              , (concs.ctxcds) ctx
              , (concs.ctxks) ctx
              , (concs.ctxvs) ctx
              , (concs.ctxgs) ctx
              , (concs.ctxifcs) ctx
              , (concs.ctxps) ctx
              , (concs.ctxsql) ctx
              , (concs.ctxphp) ctx
              ]
  expressionsIn ctx = foldr uni []
                      [ (expressionsIn.ctxpats) ctx
                      , (expressionsIn.ctxifcs) ctx
                      , (expressionsIn.ctxrs) ctx
                      , (expressionsIn.ctxks) ctx
                      , (expressionsIn.ctxvs) ctx
                      , (expressionsIn.ctxsql) ctx
                      , (expressionsIn.ctxphp) ctx
                      , (expressionsIn.multrules) ctx
                      , (expressionsIn.identityRules) ctx
                      ]

instance ConceptStructure IdentityDef where
  concs       identity   = [idCpt identity] `uni` concs [objDef | IdentityExp objDef <- identityAts identity]
  expressionsIn identity = expressionsIn             [objDef | IdentityExp objDef <- identityAts identity]

instance ConceptStructure ViewDef where
  concs       vd = [vdcpt vd] `uni` concs [objDef | ViewExp objDef <- vdats vd]
  expressionsIn vd = expressionsIn        [objDef | ViewExp objDef <- vdats vd]

instance ConceptStructure Expression where
  concs (EDcI c    ) = [c]
  concs (EEps i sgn) = nub (i:concs sgn)
  concs (EDcV   sgn) = concs sgn
  concs (EMp1 _ c  ) = [c]
  concs e            = foldrMapExpression uni concs [] e
  expressionsIn e = [e]

instance ConceptStructure A_Concept where
  concs         c = [c]
  expressionsIn _ = []

instance ConceptStructure ConceptDef where
  concs        cd = [PlainConcept { cptnm = name cd
                                  }
                    ]
  expressionsIn _ = []

instance ConceptStructure Sign where
  concs (Sign s t) = nub [s,t]
  expressionsIn _  = []

instance ConceptStructure ObjectDef where
  concs     obj = [target (objctx obj)] `uni` concs (objmsub obj)
  expressionsIn obj = foldr (uni) []
                     [ (expressionsIn.objctx) obj
                     , (expressionsIn.objmsub) obj
                     ]

-- Note that these functions are not recursive in the case of InterfaceRefs (which is of course obvious from their types)
instance ConceptStructure SubInterface where
  concs (Box _ _ objs)           = concs objs
  concs (InterfaceRef _)         = []
  expressionsIn (Box _ _ objs)   = expressionsIn objs
  expressionsIn (InterfaceRef _) = []

instance ConceptStructure Pattern where
  concs pat = foldr uni []
              [ (concs.ptrls) pat
              , (concs.ptgns) pat
              , (concs.ptdcs) pat
              , (concs.ptups) pat
              , (concs.ptids) pat
              , (concs.ptxps) pat
              ]
  expressionsIn p = foldr (uni) []
                     [ (expressionsIn.ptrls) p
                     , (expressionsIn.ptids) p
                     , (expressionsIn.ptvds) p
                     ]

instance ConceptStructure Interface where
  concs         ifc = concs (ifcObj ifc)
  expressionsIn ifc = foldr (uni) []
                     [ (expressionsIn.ifcObj) ifc
                     , map EDcD $ ifcParams ifc -- Return param declarations as expressions
                     ]

instance ConceptStructure Declaration where
  concs         d = concs (sign d)
  expressionsIn _ = fatal 148 "expressionsIn not allowed on Declaration"

instance ConceptStructure Rule where
  concs r   = concs (rrexp r) `uni` concs (rrviol r)
  expressionsIn r = foldr (uni) []
                   [ (expressionsIn.rrexp ) r
                   , (expressionsIn.rrviol) r
                   ]

instance ConceptStructure (PairView Expression) where
  concs         (PairView ps) = concs         ps
  expressionsIn (PairView ps) = expressionsIn ps

instance ConceptStructure Population where
  concs pop@PRelPopu{} = concs (popdcl pop)
  concs pop@PCptPopu{} = concs (popcpt pop)
  expressionsIn _    = []

instance ConceptStructure Purpose where
  concs pop@Expl{} = concs (explObj pop)
  expressionsIn _ = []

instance ConceptStructure ExplObj where
  concs (ExplConceptDef cd) = concs cd
  concs (ExplDeclaration d) = concs d
  concs (ExplRule _)        = [{-beware of loops...-}]
  concs (ExplIdentityDef _) = [{-beware of loops...-}]
  concs (ExplViewDef _)     = [{-beware of loops...-}]
  concs (ExplPattern _)     = [{-beware of loops...-}]
  concs (ExplInterface _)   = [{-beware of loops...-}]
  concs (ExplContext _)     = [{-beware of loops...-}]
  
  expressionsIn _ = []

instance ConceptStructure (PairViewSegment Expression) where
  concs pvs = case pvs of
      PairViewText{} -> []
      PairViewExp{}  -> concs (pvsExp pvs)
  expressionsIn pvs = case pvs of
      PairViewText{} -> []
      PairViewExp{}  -> expressionsIn (pvsExp pvs)

instance ConceptStructure A_Gen where
  concs g@Isa{}  = nub [gengen g,genspc g]
  concs g@IsE{}  = nub (genspc g: genrhs g)
  expressionsIn _ = fatal 160 "expressionsIn not allowed on A_Gen"