{-# LANGUAGE FlexibleInstances #-}
module Database.Design.Ampersand.Core.ToMeta 
  (toMeta)
where
import Database.Design.Ampersand.Misc
import Database.Design.Ampersand.Core.ParseTree

-- | When dealing with meta-stuff for Ampersand, (Like makeGenerics, makeRAP), 
--   the names of Concepts should be different than 'normal', user-defined Concepts. 
--   This function modifies everything in the context to reflect that.  
toMeta :: MakeMeta a => Options -> (a -> a)
toMeta opts = 
  if metaTablesHaveUnderscore opts then makeMeta (string2Meta opts) else id

string2Meta :: Options -> String -> String
string2Meta opts str 
              = if metaTablesHaveUnderscore opts 
                then show ("__"++unquoted++"__")
                else str
  where
    unquoted
     | length str < 2 = str
     | head str == '"' && last str == '"' = reverse . tail . reverse . tail $ str
     | otherwise = str 

class MakeMeta a where
  makeMeta :: (String -> String) -> a -> a

instance MakeMeta a => MakeMeta (Maybe a) where
  makeMeta _ Nothing = Nothing
  makeMeta f (Just a) = Just (makeMeta f a) 
instance MakeMeta a => MakeMeta [a] where
  makeMeta _ [] = []
  makeMeta f xs = map (makeMeta f) xs
    
instance MakeMeta P_Context where
  makeMeta f ctx
   = PCtx{ ctx_nm    =            (ctx_nm ctx)  
         , ctx_pos   = makeMeta f (ctx_pos ctx)
         , ctx_lang  = makeMeta f (ctx_lang ctx)
         , ctx_markup= makeMeta f (ctx_markup ctx)
         , ctx_thms  =            (ctx_thms ctx)
         , ctx_pats  = makeMeta f (ctx_pats ctx)
         , ctx_PPrcs = makeMeta f (ctx_PPrcs ctx)
         , ctx_rs    = makeMeta f (ctx_rs ctx)
         , ctx_ds    = makeMeta f (ctx_ds ctx)
         , ctx_cs    = makeMeta f (ctx_cs ctx)
         , ctx_ks    = makeMeta f (ctx_ks ctx)
         , ctx_rrules= makeMeta f (ctx_rrules ctx)
         , ctx_rrels = makeMeta f (ctx_rrels ctx)
         , ctx_vs    = makeMeta f (ctx_vs ctx)
         , ctx_gs    = makeMeta f (ctx_gs ctx)
         , ctx_ifcs  = makeMeta f (ctx_ifcs ctx)
         , ctx_ps    = makeMeta f (ctx_ps ctx)
         , ctx_pops  = makeMeta f (ctx_pops ctx)
         , ctx_sql   = makeMeta f (ctx_sql ctx)
         , ctx_php   = makeMeta f (ctx_php ctx)
         , ctx_metas = makeMeta f (ctx_metas ctx)
         } 

instance MakeMeta P_Pattern where
  makeMeta f p
   = P_Pat { pt_nm  =            (pt_nm p)
           , pt_pos = makeMeta f (pt_pos p)
           , pt_end = makeMeta f (pt_end p)
           , pt_rls = makeMeta f (pt_rls p)
           , pt_gns = makeMeta f (pt_gns p)
           , pt_dcs = makeMeta f (pt_dcs p)
           , pt_RRuls = makeMeta f (pt_RRuls p)
           , pt_RRels = makeMeta f (pt_RRels p)
           , pt_cds = makeMeta f (pt_cds p)
           , pt_ids = makeMeta f (pt_ids p)
           , pt_vds = makeMeta f (pt_vds p)
           , pt_xps = makeMeta f (pt_xps p)
           , pt_pop = makeMeta f (pt_pop p)
           }

instance MakeMeta ConceptDef where
  makeMeta f cd
   = Cd  { cdpos  = makeMeta f (cdpos cd)
         , cdcpt  =          f (cdcpt cd)
         , cdplug =            (cdplug cd)
         , cddef  =            (cddef cd)
         , cdtyp  =            (cdtyp cd)
         , cdref  =            (cdref cd)
         , cdfrom =            (cdfrom cd)
         }

instance MakeMeta P_Declaration where
  makeMeta f d
   = P_Sgn { dec_nm   =          f (dec_nm d)
           , dec_sign = makeMeta f (dec_sign d)
           , dec_prps = makeMeta f (dec_prps d)
           , dec_prL  =            (dec_prL d)
           , dec_prM  =            (dec_prM d)
           , dec_prR  =            (dec_prR d)
           , dec_Mean = makeMeta f (dec_Mean d)
           , dec_popu = makeMeta f (dec_popu d)
           , dec_fpos = makeMeta f (dec_fpos d)
           , dec_plug =            (dec_plug d)
           }

instance MakeMeta P_Sign where
  makeMeta f sgn
   = P_Sign { pSrc = makeMeta f (pSrc sgn)
            , pTgt = makeMeta f (pTgt sgn)
            }

instance MakeMeta P_Concept where
  makeMeta f cpt 
    = case cpt of
        PCpt{} -> PCpt{p_cptnm = f(p_cptnm cpt)}
        P_Singleton -> cpt
        
instance MakeMeta a => MakeMeta (P_Rule a) where
  makeMeta f rul
   = P_Ru { rr_nm   =            (rr_nm rul)
          , rr_exp  = makeMeta f (rr_exp rul)
          , rr_fps  = makeMeta f (rr_fps rul)
          , rr_mean = makeMeta f (rr_mean rul)
          , rr_msg  = makeMeta f (rr_msg rul)
          , rr_viol = makeMeta f (rr_viol rul)
          }

instance MakeMeta P_RoleRule where
  makeMeta f rr
   = Maintain
          { mRoles =            (mRoles rr)
          , mRules =            (mRules rr)
          , mPos   = makeMeta f (mPos rr)
          }
instance MakeMeta P_RoleRelation where
  makeMeta f rr
   = P_RR { rr_Roles =            (rr_Roles rr)
          , rr_Rels  = makeMeta f (rr_Rels rr)
          , rr_Pos   = makeMeta f (rr_Pos rr)
          }

instance MakeMeta P_IdentDef where
  makeMeta f ident
   = P_Id { ix_pos = makeMeta f (ix_pos ident) 
          , ix_lbl =          f (ix_lbl ident) -- TODO: HJO20150209: Not sure if it is wise to 'f' the label. Check with Michiel.
          , ix_cpt = makeMeta f (ix_cpt ident)
          , ix_ats = makeMeta f (ix_ats ident)
          }
instance MakeMeta P_IdentSegment where
  makeMeta f sgmt
   = P_IdentExp
          { ks_obj = makeMeta f (ks_obj sgmt)
          }
instance MakeMeta a => MakeMeta (P_ViewD a) where
  makeMeta f vd
   = P_Vd { vd_pos = makeMeta f (vd_pos vd) 
          , vd_lbl =            (vd_lbl vd) -- No need to meta these labels (only used as template variable names)
          , vd_cpt = makeMeta f (vd_cpt vd)
          , vd_isDefault =      (vd_isDefault vd)
          , vd_html =           (vd_html vd) -- No need to meta the html template filename or inline html code
          , vd_ats = makeMeta f (vd_ats vd)
          }

instance MakeMeta a => MakeMeta (P_ViewSegmt a) where
  makeMeta f vs
   = case vs of 
      P_ViewExp{}  -> P_ViewExp { vs_obj = makeMeta f (vs_obj vs)
                                }
      P_ViewText{} -> vs
      P_ViewHtml{} -> vs

instance MakeMeta P_Gen where
  makeMeta f gen
   = case gen of 
      P_Cy{} -> P_Cy { gen_spc = makeMeta f (gen_spc gen)
                     , gen_rhs = makeMeta f (gen_rhs gen)
                     , gen_fp  = makeMeta f (gen_fp gen)
                     }
      PGen{} -> PGen { gen_spc = makeMeta f (gen_spc gen)
                     , gen_gen = makeMeta f (gen_gen gen)
                     , gen_fp  = makeMeta f (gen_fp gen)
                     }
instance MakeMeta P_Interface where
  makeMeta f ifc
   = P_Ifc { ifc_Name   =            (ifc_Name ifc)
           , ifc_Class  =            (ifc_Class ifc)
           , ifc_Params = makeMeta f (ifc_Params ifc)
           , ifc_Args   =            (ifc_Args ifc)
           , ifc_Roles  =            (ifc_Roles ifc)
           , ifc_Obj    = makeMeta f (ifc_Obj ifc)
           , ifc_Pos    = makeMeta f (ifc_Pos ifc)
           , ifc_Prp    =            (ifc_Prp ifc)
           }
instance MakeMeta PPurpose where
  makeMeta f prp
   = PRef2 { pexPos    = makeMeta f (pexPos prp)
           , pexObj    = makeMeta f (pexObj prp)
           , pexMarkup = makeMeta f (pexMarkup prp)
           , pexRefIDs =            (pexRefIDs prp)
           }

instance MakeMeta P_Markup where
  makeMeta f m
   = P_Markup 
          { mLang   = makeMeta f (mLang m)
          , mFormat = makeMeta f (mFormat m)
          , mString =            (mString m)
          }
instance MakeMeta PRef2Obj where
  makeMeta f ref
   = case ref of
      PRef2ConceptDef s  -> PRef2ConceptDef (f s)
      PRef2Declaration t -> PRef2Declaration (makeMeta f t)
      PRef2Rule _        -> ref 
      PRef2IdentityDef _ -> ref 
      PRef2ViewDef _     -> ref 
      PRef2Pattern _     -> ref 
      PRef2Interface _   -> ref 
      PRef2Context _     -> ref 
      PRef2Fspc _        -> ref

instance MakeMeta PMeaning where
  makeMeta f (PMeaning m) = PMeaning (makeMeta f m)
instance MakeMeta PMessage where
  makeMeta f (PMessage m) = PMessage (makeMeta f m)
instance MakeMeta P_Population where
  makeMeta f pop 
   = case pop of
      P_RelPopu{} -> P_RelPopu { p_rnme  =          f (p_rnme pop)
                               , p_orig  = makeMeta f (p_orig pop)
                               , p_popps = makeMeta f (p_popps pop)
                               }
      P_TRelPop{} -> P_TRelPop { p_rnme  =          f (p_rnme pop)
                               , p_type  = makeMeta f (p_type pop)
                               , p_orig  = makeMeta f (p_orig pop)
                               , p_popps = makeMeta f (p_popps pop)
                               }
      P_CptPopu{} -> P_CptPopu { p_cnme  =          f (p_rnme pop)
                               , p_orig  = makeMeta f (p_orig pop)
                               , p_popas =            (p_popas pop)
                               }

instance MakeMeta Meta where
  makeMeta f m
   = Meta { mtPos  = makeMeta f (mtPos m)
          , mtObj  =            (mtObj m)
          , mtName =            (mtName m)
          , mtVal  =            (mtVal m)
          }
instance MakeMeta a => MakeMeta (P_ObjDef a) where
  makeMeta f obj
   = P_Obj { obj_nm   =          f (obj_nm obj)
           , obj_pos  = makeMeta f (obj_pos obj)
           , obj_ctx  = makeMeta f (obj_ctx obj)
           , obj_mView =           (obj_mView obj)
           , obj_msub = makeMeta f (obj_msub obj)
           , obj_strs =            (obj_strs obj)
           }

instance MakeMeta a => MakeMeta (P_SubIfc a) where
  makeMeta f sub
   = case sub of
      P_Box{}          -> P_Box         { si_ori   = makeMeta f (si_ori sub)
                                        , si_class =            (si_class sub)
                                        , si_box   = makeMeta f (si_box sub)
                                        }
      P_InterfaceRef{} -> P_InterfaceRef{ si_ori   = makeMeta f (si_ori sub)
                                        , si_str   =            (si_str sub)
                                        }

instance MakeMeta a => MakeMeta (PairView a) where
  makeMeta f pv
    = PairView {ppv_segs = makeMeta f (ppv_segs pv)}
instance MakeMeta a => MakeMeta (PairViewSegment a) where
  makeMeta f sgmt
    = case sgmt of
       PairViewText{} -> sgmt
       PairViewExp{}  -> sgmt{pvsExp = makeMeta f (pvsExp sgmt)}

instance MakeMeta a => MakeMeta (Term a) where
  makeMeta f t
   = case t of
       Prim a     -> Prim (makeMeta f a)
       PEqu o a b -> PEqu o (makeMeta f a) (makeMeta f b)
       PImp o a b -> PImp o (makeMeta f a) (makeMeta f b)
       PIsc o a b -> PIsc o (makeMeta f a) (makeMeta f b)
       PUni o a b -> PUni o (makeMeta f a) (makeMeta f b)
       PDif o a b -> PDif o (makeMeta f a) (makeMeta f b)
       PLrs o a b -> PLrs o (makeMeta f a) (makeMeta f b)
       PRrs o a b -> PRrs o (makeMeta f a) (makeMeta f b)
       PDia o a b -> PDia o (makeMeta f a) (makeMeta f b)
       PCps o a b -> PCps o (makeMeta f a) (makeMeta f b)
       PRad o a b -> PRad o (makeMeta f a) (makeMeta f b)
       PPrd o a b -> PPrd o (makeMeta f a) (makeMeta f b)
       PKl0 o a   -> PKl0 o (makeMeta f a)
       PKl1 o a   -> PKl1 o (makeMeta f a)
       PFlp o a   -> PFlp o (makeMeta f a)
       PCpl o a   -> PCpl o (makeMeta f a)
       PBrk o a   -> PBrk o (makeMeta f a)


instance MakeMeta TermPrim where
  makeMeta f t
   = case t of
      PI    _         -> t 
      Pid   o c       -> Pid o (makeMeta f c)
      Patm  o a c     -> Patm o a (makeMeta f c)
      PVee  _         -> t
      Pfull o src tgt -> Pfull o (makeMeta f src)(makeMeta f tgt)
      PNamedR nr      -> PNamedR (makeMeta f nr)

instance MakeMeta P_NamedRel where
  makeMeta f (PNamedRel o nm      sgn)
            = PNamedRel o (f nm) (makeMeta f sgn)
   
instance MakeMeta Paire where
  makeMeta _ = id
instance MakeMeta Origin where
  makeMeta _ = id
instance MakeMeta Lang where
  makeMeta _ = id
instance MakeMeta PandocFormat where
  makeMeta _ = id
instance MakeMeta Prop where
  makeMeta _ = id