{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE FlexibleInstances #-}
module DatabaseDesign.Ampersand.Classes.ConceptStructure          (ConceptStructure(..), prim2rel)
where
   import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree       
   import DatabaseDesign.Ampersand.Core.ParseTree (ConceptDef(..))
   import DatabaseDesign.Ampersand.Basics
   import Data.List
   import Data.Maybe
   import DatabaseDesign.Ampersand.ADL1.Expression
   import Prelude hiding (Ordering(..))
   fatal :: Int -> String -> a
   fatal = fatalMsg "Classes.ConceptStructure"

   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 
    mp1Exprs :: a -> [Expression]     -- ^ the set of all EMp1 expressions within data structure a (needed to get the atoms of these relations into the populationtable)
    mp1Exprs = filter isMp1.primsMentionedIn
    -- | mp1Pops draws the population from singleton expressions.
    mp1Pops :: a -> [Population]
    mp1Pops struc
     = [ PCptPopu{ popcpt = cpt (head cl), popas = map atm cl } | cl<-eqCl cpt (mp1Exprs 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.ctxprocs) 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.ctxprocs) ctx
                        , (expressionsIn.ctxifcs) ctx
                        , (expressionsIn.ctxrs) ctx
                        , (expressionsIn.ctxks) ctx
                        , (expressionsIn.ctxvs) ctx
                        , (expressionsIn.ctxsql) ctx
                        , (expressionsIn.ctxphp) 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 (cdcpt 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 Process where
    concs prc = foldr uni []
                [ (concs.prcRules) prc
                , (concs.prcGens) prc
                , (concs.prcDcls) prc
                , (concs.prcUps) prc
                , (concs.prcIds) prc
                , (concs.prcVds) prc
                , (concs.prcXps) prc
                ]
    expressionsIn p = foldr (uni) []
                       [ (expressionsIn.prcRules) p
                       , (expressionsIn.prcIds) p
                       , (expressionsIn.prcVds) p
                       ]

   instance ConceptStructure Interface where
    concs         ifc = concs (ifcObj ifc)
    expressionsIn ifc = foldr (uni) []
                       [ (expressionsIn.ifcObj) ifc
                       , (expressionsIn.ifcParams) ifc
                       ]

   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 (ExplProcess _)     = [{-beware of loops...-}]
    concs (ExplInterface _)   = [{-beware of loops...-}]
    concs (ExplContext _)     = [{-beware of loops...-}]
    
    expressionsIn _ = []

   instance ConceptStructure (PairViewSegment Expression) where
    concs       (PairViewText _)  = []
    concs       (PairViewExp _ x) = concs x
    expressionsIn    (PairViewText _)  = []
    expressionsIn    (PairViewExp _ x) = expressionsIn x
     
   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"