{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Database.Design.Ampersand.FSpec.ShowMeatGrinder
  (makeMetaPopulationFile,MetaType(..))
where

import Data.List
import Data.Char
import Data.Ord
import Data.Hashable (hash) -- a not good enouqh function, but used for the time being. 
import Data.Typeable
import Database.Design.Ampersand.FSpec.FSpec
import Database.Design.Ampersand.FSpec.FSpecAux
import Database.Design.Ampersand.FSpec.Motivations
import Database.Design.Ampersand.FSpec.SQL
import Database.Design.Ampersand.FSpec.ToFSpec.NormalForms (conjNF)
import Database.Design.Ampersand.Basics
import Database.Design.Ampersand.Misc
import Database.Design.Ampersand.FSpec.ShowADL
import Database.Design.Ampersand.Core.AbstractSyntaxTree
import Database.Design.Ampersand.Classes.ConceptStructure

--import Data.Hashable
import Data.Maybe

fatal :: Int -> String -> a
fatal = fatalMsg "ShowMeatGrinder"

data MetaType = Generics | AST deriving (Show)

makeMetaPopulationFile :: MetaType -> FSpec -> (FilePath,String)
makeMetaPopulationFile mType fSpec
  = ("MetaPopulationFile"++show mType++".adl", content popKind mType fSpec)
    where popKind = case mType of
                      Generics -> generics fSpec
                      AST      -> metaPops fSpec 

content :: (FSpec -> [Pop]) -> MetaType -> FSpec -> String
content popKind mType fSpec = unlines
   ([ "{- Do not edit manually. This code has been generated!!!"
    , "    Generated with "++ampersandVersionStr
    , "    Generated at "++show (genTime (getOpts fSpec))
    , " "
    , "The populations defined in this file are the populations from the user's"
    , "model named '"++name fSpec++"'."
    , ""
    , "The order in which these populations are defined correspond with the order "
    , "in which Ampersand is defined in itself. Currently (Feb. 2015), this is hard-"
    , "coded. This means, that whenever Formal Ampersand changes, it might have "
    , "impact on the generator of this file. "
    , ""
    , "-}"
    , ""
    , "CONTEXT "++show mType++" IN ENGLISH -- (the language is chosen arbitrary, for it is mandatory but irrelevant."]
    ++ (concat.intersperse  []) (map (lines . showADL ) (popKind fSpec))
    ++
    [ ""
    , "ENDCONTEXT"
    ])
instance GenericPopulations FSpec where
 generics _ fSpec =
   filter (not.nullContent)
    (
    [ Pop "versionInfo" "Context"  "AmpersandVersion"
           [(uri fSpec, ampersandVersionStr)]
    , Pop "contextName" "Context" "ContextName"
           [(uri fSpec, name fSpec)]
    , Pop "dbName" "Context" "DatabaseName"
           [(uri fSpec, dbName (getOpts fSpec))]
    ]
  ++[ Comment " ", Comment $ "[Relations]--: (count="++(show.length.allDecls) fSpec++")"]
  ++   concatMap (generics fSpec) (allDecls fSpec)
  ++[ Comment " ", Comment $ "[Concepts]--: (count="++(show.length) [c | c <- allConcepts fSpec, c /= ONE]++")"]
  ++   concatMap (generics fSpec) [c | c <- allConcepts fSpec, c /= ONE]
  ++[ Comment " ", Comment $ "[TableColumnInfo]--: (count="++(show.length) allSqlPlugs++")"]
  ++   concatMap (generics fSpec) allSqlPlugs
  ++[ Comment " ", Comment $ "[Rules]--: (count="++(show.length.fallRules) fSpec++")"]
  ++   concatMap (generics fSpec) (fallRules fSpec)
  ++[ Comment " ", Comment $ "[Conjuncts]--: (count="++(show.length.vconjs) fSpec++")"]
  ++   concatMap (generics fSpec) (vconjs fSpec)
  ++[ Comment " ", Comment $ "[Roles]--: (count="++(show.length.fRoles) fSpec++")"]
  ++   concatMap (generics fSpec) (fRoles fSpec)
    )
  where
    allSqlPlugs = [plug | InternalPlug plug <- plugInfos fSpec]

instance MetaPopulations FSpec where
 metaPops _ fSpec =
   filter (not.nullContent)
    (
    [Comment  " ", Comment $ "PATTERN Context: ('"++name fSpec++"')"]
  ++[ Pop "name"   "Context" "ContextName"
           [(uri fSpec,name fSpec)]]
  ++[ Comment " ", Comment $ "PATTERN Patterns: (count="++(show.length.vpatterns) fSpec++")"]
  ++   concatMap (metaPops fSpec) ((sortBy (comparing name).vpatterns)    fSpec)
  ++[ Comment " ", Comment $ "PATTERN Specialization: (count="++(show.length.vgens) fSpec++")"]
  ++   concatMap (metaPops fSpec) (vgens          fSpec)
  ++[ Comment " ", Comment $ "PATTERN Concept: (count="++(show.length.allConcepts) fSpec++")"]
  ++   concatMap (metaPops fSpec) ((sortBy (comparing name).allConcepts)    fSpec)
  ++[ Comment " ", Comment $ "PATTERN Atoms: (count="++(show.length) (allAtoms fSpec)++")"]
  ++   concatMap (metaPops fSpec) (allAtoms fSpec)
--  ++[ Comment " ", Comment $ "PATTERN Sign: (count="++(show.length.allSigns) fSpec++")"]
--  ++   concatMap (metaPops fSpec) (allSigns fSpec)
  ++[ Comment " ", Comment $ "PATTERN Declaration: (count="++(show.length.allDecls) fSpec++")"]
  ++   concatMap (metaPops fSpec) (allDecls  fSpec)
  ++[ Comment " ", Comment $ "PATTERN Expression: (count="++(show.length.allExprs) fSpec++")"]
  ++   concatMap (metaPops fSpec) (allExprs  fSpec)
  ++[ Comment " ", Comment $ "PATTERN Rules: (count="++(show.length.fallRules) fSpec++")"]
  ++   concatMap (metaPops fSpec) ((sortBy (comparing name).fallRules)    fSpec)
  ++[ Comment " ", Comment $ "PATTERN Plugs: (count="++(show.length.plugInfos) fSpec++")"]
  ++   concatMap (metaPops fSpec) ((sortBy (comparing name).plugInfos)    fSpec)
  ++[ Comment " ", Comment $ "[InitialPopulation]--: (count="++(show.length.initialPops) fSpec++")"]
  ++   concatMap (metaPops fSpec) (allLinks fSpec)
  )
   where

instance MetaPopulations Pattern where
 metaPops fSpec pat =
   [ Comment " "
   , Comment $ " Pattern `"++name pat++"` "
   , Pop "patterns" "Context" "Pattern"
          [(uri fSpec,uri pat)]
   , Pop "name"    "Pattern" "PatternName"
          [(uri pat, name pat)]
   , Pop "rules"   "Pattern" "Rule"
          [(uri pat,uri x) | x <- ptrls pat]
   , Pop "declarations"   "Pattern" "Declaration"
          [(uri pat,uri x) | x <- ptdcs pat]
   , Pop "purpose"   "Pattern" "Purpose"
          [(uri pat,uri x) | x <- ptxps pat]
   ]
instance MetaPopulations A_Gen where
 metaPops fSpec gen =
  [ Pop "gens" "Context" "Gen"
          [(uri fSpec,uri gen)]
  , Pop "genspc"  "Gen" "PlainConcept"
          [(uri gen,uri(genspc gen))]
  , Pop "gengen"  "Gen" "PlainConcept"
          [(uri gen,uri c) | c<- case gen of
                                   Isa{} -> [gengen gen]
                                   IsE{} -> genrhs gen
          ]
  ]

instance GenericPopulations A_Concept where
 generics fSpec cpt =
   case cpt of
     PlainConcept{} ->
      [ Comment " "
      , Comment $ " Concept `"++name cpt++"` "
      , Pop "allConcepts" "Context" "Concept"
             [(uri fSpec,uri cpt)]
      , Pop "name" "Concept" "ConceptName"
             [(uri cpt, name cpt)]
      , Pop "affectedInvConjunctIds" "Concept" "ConjunctID"
             [(uri cpt, uri conj) | conj <- filterFrontEndInvConjuncts affConjs]
      , Pop "affectedSigConjunctIds" "Concept" "ConjunctID"
             [(uri cpt, uri conj) | conj <- filterFrontEndSigConjuncts affConjs]
      , Pop "conceptTableFields" "Concept" "TableColumn"
             [(uri cpt, uri fld) | fld <- tablesAndFields]
      ]
     ONE -> [
            ]
  where
   affConjs = fromMaybe [] (lookup cpt $ allConjsPerConcept fSpec)
   tablesAndFields = nub . concatMap (lookupCpt fSpec) $ cpt : largerConcepts (vgens fSpec) cpt
instance MetaPopulations A_Concept where
 metaPops fSpec cpt =
   case cpt of
     PlainConcept{} ->
      [ Comment " "
      , Comment $ " Concept `"++name cpt++"` "
      , Pop "concs" "Context" "PlainConcept"
           [(uri fSpec,uri cpt)]
      , Pop "name" "PlainConcept" "ConceptName"
             [(uri cpt, name cpt)]
      , Pop "cptdf" "PlainConcept" "ConceptDefinition"
             [(uri cpt,showADL cdef) | cdef <- conceptDefs  fSpec, name cdef == name cpt]
      , Pop "cptpurpose" "PlainConcept" "Purpose"
             [(uri cpt,showADL x) | lang <- allLangs, x <- fromMaybe [] (purposeOf fSpec lang cpt) ]
      ]
     ONE -> [
            ]
instance GenericPopulations PlugSQL where
  generics fSpec plug =
      [ Comment " "
      , Comment $ "Plug: '"++name plug++"'"
      , Pop "tableInfo" "Context" "DBTable"
               [(uri fSpec, uri plug)]
      ] ++ concatMap (generics fSpec) [(plug,fld) | fld <- plugFields plug]

instance GenericPopulations (PlugSQL,SqlField) where
  generics _ (plug,fld) =
      [ Pop "columninfo" "DBTable" "TableColumn"
                 [(uri plug, uri (plug,fld)) ]
      , Pop "concept" "TableColumn" "Concept"
                 [(uri (plug,fld), uri.target.fldexpr $ fld)]
      , Pop "unique" "TableColumn" "BOOLEAN"
                 [(uri (plug,fld), uri.flduniq $ fld)]
      , Pop "null" "TableColumn" "BOOLEAN"
                 [(uri (plug,fld), uri.fldnull $ fld)]
      ]
     
instance GenericPopulations Role where
  generics fSpec rol =
      [ Comment $ "Role: '"++name rol++"'"
      , Pop "allRoles" "Context" "Role"
                 [(uri fSpec, uri rol) ]
      , Pop "name" "Role" "RoleName"
                 [(uri rol, name rol) ]
      , Pop "maintains" "Role" "Rule"
                 [(uri rol, uri rul) | (rol',rul) <-  fRoleRuls fSpec, rol==rol' ]
      ]

instance MetaPopulations Atom where
 metaPops _ atm =
   [ Pop "key" "Atom" "AtomID" 
          [(uri atm, uri atm)]
   , Pop "atomvalue"  "Atom" "AtomValue"
          [(uri atm,(show.atmVal) atm)]
   ]
--instance MetaPopulations Sign where
-- metaPops _ sgn =
--      [ Pop "src" "Sign" "Concept"
--             [(uri sgn, uri (source sgn))]
--      , Pop "trg" "Sign" "Concept"
--             [(uri sgn, uri (target sgn))]
--      ]

instance GenericPopulations Declaration where
 generics fSpec dcl =
   case dcl of 
     Sgn{} ->
      [ Comment " "
      , Comment $ " Relation '"++name dcl++showSign (sign dcl)++"'"
      , Pop "allRelations" "Context" "Relation"
             [(uri fSpec, uri dcl)]
      , Pop "name" "Relation" "RelationName"
             [(uri dcl,name dcl)]
      , Pop "srcConcept" "Relation" "Concept"
             [(uri dcl,uri (source dcl))]
      , Pop "tgtConcept" "Relation" "Concept"
             [(uri dcl,uri (target dcl))]
      , Pop "table" "Relation" "DBTable"
             [(uri dcl,uri table)]
      , Pop "srcCol" "Relation" "DBTableColumn"
             [(uri dcl,uri (table,srcCol))]
      , Pop "tgtCol" "Relation" "DBTableColumn"
             [(uri dcl,uri (table,tgtCol))]
      , Pop "affectedInvConjunctIds" "Relation" "ConjunctID"
             [(uri dcl,uri conj) | conj <- filterFrontEndInvConjuncts affConjs ]
      , Pop "affectedSigConjunctIds" "Relation" "ConjunctID"
             [(uri dcl,uri conj) | conj <- filterFrontEndSigConjuncts affConjs ]
      ]
     Isn{} -> fatal 157 "Isn is not implemented yet"
     Vs{}  -> fatal 158 "Vs is not implemented yet"
   where
     (table,srcCol,tgtCol) = getDeclarationTableInfo fSpec dcl
     affConjs = fromMaybe [] (lookup dcl $ allConjsPerDecl fSpec)
instance MetaPopulations Declaration where
 metaPops fSpec dcl =
   case dcl of
     Sgn{} ->
      [ Comment " "
      , Comment $ " Declaration `"++name dcl++" ["++(name.source.decsgn) dcl++" * "++(name.target.decsgn) dcl++"]"++"` "
      , Pop "allDeclarations" "Context" "Declaration"
             [(uri fSpec,uri dcl)] 
      , Pop "name" "Declaration" "DeclarationName"
             [(uri dcl, name dcl)]
--      , Pop "sign" "Declaration" "Sign"
--             [(uri dcl,uri (sign dcl))]
      , Pop "source" "Relation" "Concept"
             [(uri dcl,uri (source dcl))]
      , Pop "target" "Relation" "Concept"
             [(uri dcl,uri (target dcl))]
      , Pop "decprL" "Declaration" "String"
             [(uri dcl,decprL dcl)]
      , Pop "decprM" "Declaration" "String"
             [(uri dcl,decprM dcl)]
      , Pop "decprR" "Declaration" "String"
             [(uri dcl,decprR dcl)]
      , Pop "decmean" "Declaration" "Meaning"
             [(uri dcl, show(decMean dcl))]
      , Pop "decpurpose" "Declaration" "Purpose"
             [(uri dcl, showADL x) | x <- explanations dcl]
      ]
     Isn{} -> 
      [ Comment " "
      , Comment $ " Declaration `I["++name (source dcl)++"]`"
--      , Pop "sign" "Declaration" "Sign"
--             [(uri dcl,uri (sign dcl))]
      , Pop "source" "Relation" "Concept"
             [(uri dcl,uri (source dcl))]
      , Pop "target" "Relation" "Concept"
             [(uri dcl,uri (target dcl))]
      ]
     Vs{}  -> fatal 158 "Vs is not implemented yet"

instance MetaPopulations A_Pair where
 metaPops _ pair =
      [ Pop "in" "Pair" "Relation"
             [(uri pair, uri (lnkDcl pair))]
      , Pop "l" "Pair" "Atom"
             [(uri pair, uri(lnkLeft pair))]
      , Pop "r" "Pair" "Atom"
             [(uri pair, uri(lnkRight pair))]
      ]

instance MetaPopulations Expression where
 metaPops _ e =
      [ Pop "exprvalue" "ExpressionID" "Expression"
             [(uri e, showADL e)]
      ]

instance GenericPopulations Rule where
 generics fSpec rul =
      [ Comment " "
      , Comment $ " Rule `"++name rul++"` "
      , Pop "allRules" "Context" "Rule"
             [(uri fSpec, uri rul)]
      , Pop "name"  "Rule" "RuleID"
             [(uri rul,name rul)]
      , Pop "ruleAdl"  "Rule" "Adl"
             [(uri rul,(showADL.rrexp) rul)]
      , Pop "origin"  "Rule" "Origin"
             [(uri rul,(show.origin) rul)]
      , Pop "meaning"  "Rule" "Meaning"
             [(uri rul,aMarkup2String m) | m <- (maybeToList . meaning (fsLang fSpec)) rul ]
      , Pop "message"  "Rule" "Message"
             [(uri rul,aMarkup2String m) | m <- rrmsg rul, amLang m == fsLang fSpec ]
      , Pop "srcConcept"  "Rule" "Concept"
             [(uri rul,(uri.source.rrexp) rul)]
      , Pop "tgtConcept"  "Rule" "Concept"
             [(uri rul,(uri.target.rrexp) rul)]
      , Pop "conjunctIds"  "Rule" "ConjunctID"
             [(uri rul,uri conj) | (rule,conjs)<-allConjsPerRule fSpec, rule==rul,conj <- conjs]
      ]++case rrviol rul of
        Nothing -> []
        Just pve ->
         [ Pop "pairView"  "Rule" "PairView"
              [(uri rul, uri pve)]
         ]++generics fSpec pve
      
      
instance GenericPopulations (PairView Expression) where
 generics fSpec pve = 
      [ Comment " "
      ]++concatMap makeSegment (zip [0..] (ppv_segs pve))
  where
    makeSegment :: (Int,PairViewSegment Expression) -> [Pop]
    makeSegment (i,pvs) =
      [ Pop "segment" "PairView" "PairViewSegment"
             [(uri pve,uri pvs)]
      , Pop "sequenceNr" "PairViewSegment" "Int"
             [(uri pvs,show i)]
      , Pop "segmentType" "PairViewSegment" "PairViewSegmentType"
             [(uri pvs, case pvs of 
                         PairViewText{} -> "Text"
                         PairViewExp{}  -> "Exp")
            ]
      ]++
      case pvs of
        PairViewText{} -> 
          [Pop "text" "PairViewSegment" "String"
               [(uri pvs, pvsStr pvs)] 
          ]
        PairViewExp{} -> 
          [Pop "srcOrTgt" "PairViewSegment" "SourceOrTarget"
               [(uri pvs, show (pvsSoT pvs))] 
          ,Pop "expTgt" "PairViewSegment" "Concept"
               [(uri pvs, uri (case pvsSoT pvs of
                                Src -> source (pvsExp pvs)
                                Tgt -> target (pvsExp pvs)
                              ))] 
          ,Pop "expSQL" "PairViewSegment" "MySQLQuery"
               [(uri pvs, prettySQLQuery fSpec 0 (pvsExp pvs))] 
          ]
         
      
instance MetaPopulations Rule where
 metaPops _ rul =
      [ Comment " "
      , Comment $ " Rule `"++name rul++"` "
      , Pop "name"  "Rule" "RuleName"
             [(uri rul,name rul)]
      , Pop "rrexp"  "Rule" "ExpressionID"
             [(uri rul,uri (rrexp rul))]
      , Pop "rrmean"  "Rule" "Meaning"
             [(uri rul,show(rrmean rul))]
      , Pop "rrpurpose"  "Rule" "Purpose"
             [(uri rul,showADL x) | x <- explanations rul]
      , -- The next population is from the adl pattern 'Plugs':
        Pop "sign" "Rule" "Sign"
             [(uri rul,uri (sign rul))]
      , Pop "declaredthrough" "PropertyRule" "Property"
             [(uri rul,show prp) | Just(prp,_) <- [rrdcl rul]]
      , Pop "decprps" "Declaration" "PropertyRule"
             [(uri dcl, uri rul) | Just(_,dcl) <- [rrdcl rul]]
      ]



instance MetaPopulations PlugInfo where
 metaPops _ plug = 
      [ Comment $ " Plug `"++name plug++"` "
      , Pop "maintains" "Plug" "Rule" [{-STILL TODO. -}] --HJO, 20150205: Waar halen we deze info vandaan??
      , Pop "in" "PlainConcept" "Plug"                 
             [(uri cpt,uri plug)| cpt <- concs plug]  
      , Pop "in" "Declaration" "Plug"
             [(uri dcl,uri plug)| dcl <- relsMentionedIn plug]
      ]      

instance MetaPopulations a => MetaPopulations [a] where
 metaPops fSpec = concatMap $ metaPops fSpec
 
instance GenericPopulations Conjunct where
 generics fSpec conj =
  [ Comment $ "Conjunct: '"++rc_id conj++"'."
  , Pop "allConjuncts" "Context" "Conjunct" 
         [(uri fSpec, uri conj)]
  , Pop "signalRuleNames" "Conjunct" "Rule" 
         [(uri conj,uri r) | r <- rc_orgRules conj, isFrontEndSignal r]
  , Pop "invariantRuleNames" "Conjunct" "Rule" 
         [(uri conj,uri r) | r <- rc_orgRules conj, isFrontEndInvariant  r]
  , Pop "violationsSQL" "Conjunct" "MySQLQuery" 
         [(uri conj , prettySQLQuery fSpec 0 (conjNF (getOpts fSpec) (notCpl (rc_conjunct conj)))
          )]
  ] 


-----------------------------------------------------
data Pop = Pop { popName ::String
               , popSource :: String
               , popTarget :: String
               , popPairs :: [(String,String)]
               }
         | Comment { comment :: String  -- Not-so-nice way to get comments in a list of populations. Since it is local to this module, it is not so bad, I guess...
                   }
instance ShowADL Pop where
 showADL pop =
  case pop of
      Pop{} -> "POPULATION "++ popName pop++
                  " ["++popSource pop++" * "++popTarget pop++"] CONTAINS"
              ++
              if null (popPairs pop)
              then "[]"
              else "\n"++indentA++"[ "++intercalate ("\n"++indentA++"; ") showContent++indentA++"]"
      Comment{} -> intercalate "\n" (map prepend (lines (comment pop)))
    where indentA = "   "
          showContent = map showPaire (popPairs pop)
          showPaire (s,t) = "( "++show s++" , "++show t++" )"
          prepend str = "-- " ++ str

class Unique a => AdlId a where
 uri :: a -> String
 uri = camelCase . uniqueShow False
-- All 'things' that are relevant in the meta-environment (RAP),
-- must be an instance of AdlId:
instance AdlId A_Concept
instance AdlId A_Gen
instance AdlId Atom
instance AdlId ConceptDef
instance AdlId Declaration
instance AdlId Expression
instance AdlId FSpec
instance AdlId A_Pair
instance AdlId Pattern
instance AdlId PlugInfo
instance AdlId PlugSQL
instance AdlId (PlugSQL,SqlField)
instance AdlId Purpose
instance AdlId Rule
instance AdlId Role
instance AdlId Sign
instance AdlId Conjunct
instance AdlId (PairView Expression)
  where uri x = show (typeOf x)++show (hash x)
instance AdlId (PairViewSegment Expression)
  where uri x = show (typeOf x)++show (hash (show (hash x) ++ show (origin x)))
instance AdlId Bool where
 uri = showUnique
instance AdlId a => AdlId [a] where
--instance AdlId (Declaration,Paire)



-- | remove spaces and make camelCase
camelCase :: String -> String
camelCase str = concatMap capitalize (words str)
  where
    capitalize [] = []
    capitalize (s:ss) = toUpper s : ss

nullContent :: Pop -> Bool
nullContent (Pop _ _ _ []) = True
nullContent _ = False
    
class MetaPopulations a where
 metaPops :: FSpec -> a -> [Pop]
class GenericPopulations a where
 generics :: FSpec -> a -> [Pop]   


--------- Below here are some functions copied from Generate.hs TODO: Clean up.
-- Because the signal/invariant condition appears both in generateConjuncts and generateInterface, we use
-- two abstractions to guarantee the same implementation.
isFrontEndInvariant :: Rule -> Bool
isFrontEndInvariant r = not (isSignal r) && not (ruleIsInvariantUniOrInj r)

isFrontEndSignal :: Rule -> Bool
isFrontEndSignal r = isSignal r

-- NOTE that results from filterFrontEndInvConjuncts and filterFrontEndSigConjuncts may overlap (conjunct appearing in both invariants and signals)
-- and that because of extra condition in isFrontEndInvariant (not (ruleIsInvariantUniOrInj r)), some parameter conjuncts may not be returned
-- as either inv or sig conjuncts (i.e. conjuncts that appear only in uni or inj rules) 
filterFrontEndInvConjuncts :: [Conjunct] -> [Conjunct]
filterFrontEndInvConjuncts conjs = filter (\c -> any isFrontEndInvariant $ rc_orgRules c) conjs

filterFrontEndSigConjuncts :: [Conjunct] -> [Conjunct]
filterFrontEndSigConjuncts conjs = filter (\c -> any isFrontEndSignal $ rc_orgRules c) conjs