Fix issue #488

src/Database/Design/Ampersand/FSpec/FSpec.hs

@@ -22,7 +22,7 @@ module Database.Design.Ampersand.FSpec.FSpec
           , lookupCpt, getConceptTableFor
           , RelStore(..)
           , metaValues
-          , SqlAttribute(..)
+          , SqlAttribute(..),isPrimaryKey,isForeignKey
           , Typology(..)
           , Interface(..)
           , Object(..)
@@ -316,7 +316,7 @@ data RelStore
      , rsSrcAtt    :: SqlAttribute
      , rsTrgAtt    :: SqlAttribute
      } deriving (Show, Typeable)
-data SqlAttributeUsage = TableKey Bool A_Concept  -- The SQL-attribute is the (primary) key of the table. (The boolean tells whether or not it is primary)
+data SqlAttributeUsage = PrimaryKey A_Concept
                        | ForeignKey A_Concept  -- The SQL-attribute is a reference (containing the primary key value of) a TblSQL
                        | PlainAttr             -- None of the above
                        deriving (Eq, Show)
@@ -340,6 +340,15 @@ instance ConceptStructure SqlAttribute where
   concs     f = [target e' |let e'=attExpr f,isSur e']
   expressionsIn   f = expressionsIn   (attExpr f)
 
+isPrimaryKey :: SqlAttribute -> Bool
+isPrimaryKey att = case attUse att of
+                    PrimaryKey _ -> True
+                    _ -> False
+isForeignKey :: SqlAttribute -> Bool
+isForeignKey att = case attUse att of
+                    ForeignKey _ -> True
+                    _ -> False
+
 showSQL :: TType -> String
 showSQL tt =
   case tt of 

src/Database/Design/Ampersand/FSpec/ShowHS.hs

@@ -163,9 +163,9 @@ instance ShowHS SqlAttribute where
                indentB = indentA++"            " -- adding the width of ", attExpr = "
 
 instance ShowHS SqlAttributeUsage where
- showHS _ _ (TableKey isPrimary aCpt) = "TableKey "  ++show isPrimary++" "++showHSName aCpt
- showHS _ _ (ForeignKey aCpt)         = "ForeignKey "++showHSName aCpt
- showHS _ _ PlainAttr                 = "PlainAttr "
+ showHS _ _ (PrimaryKey aCpt) = "PrimaryKey "++showHSName aCpt
+ showHS _ _ (ForeignKey aCpt) = "ForeignKey "++showHSName aCpt
+ showHS _ _ PlainAttr         = "PlainAttr "
 
 instance ShowHS TType where
  showHS _ indent tt = indent ++ show tt

src/Database/Design/Ampersand/FSpec/ToFSpec/ADL2Plug.hs

@@ -89,7 +89,7 @@ makeGeneratedSqlPlugs opts context calcProps = conceptTables ++ linkTables
                               , attType = repr cpt
                               , attUse  = if cpt == tableKey 
                                              && repr cpt == Object -- For scalars, we do not want a primary key. This is a workaround fix for issue #341
-                                          then TableKey True cpt  
+                                          then PrimaryKey cpt  
                                           else PlainAttr
                               , attNull   = not . isTot $ expr
                               , attDBNull = cpt /= tableKey 

src/Database/Design/Ampersand/Output/ToPandoc/ChapterDataAnalysis.hs

@@ -304,35 +304,22 @@ chpDataAnalysis fSpec = (theBlocks, thePictures)
       showAttributes atts = bulletList (map showAttribute atts)
         where
           showAttribute att =
---FIXME 20140525: Onderstaande code vervangen door afl te leiden van `attUse`. Daar zit deze info al in verwerkt!
-             let isPrimaryKey = case attExpr att of
-                                  e@EDcI{} -> e==attExpr (head atts) -- The first attribute represents the most general concept
-                                  _        -> False
-                 mForeignKey  = case attExpr att of
-                                  EIsc (EDcI c,_) -> Just c
-                                  _               -> Nothing
-             in para (  (strong.text.attName) att
+                para (  (strong.text.attName) att
                       <> linebreak
-                      <> (if isPrimaryKey
-                          then case fsLang fSpec of
-                                Dutch   -> "Dit attribuut is de primaire sleutel. "
-                                English -> "This attribute is the primary key. "
-                          else
-                          case mForeignKey of
-                           Just c ->  case fsLang fSpec of
-                                         Dutch   -> "Dit attribuut verwijst naar een voorkomen in de tabel "
-                                         English -> "This attribute is a foreign key to "
-                                     <> (text.name) c
-                           Nothing -- (no foreign key...)
-                             -> --if isBool
-                                --then
-                                --else
-                                  (case fsLang fSpec of
-                                     Dutch   -> "Dit attribuut implementeert "
-                                     English -> "This attribute implements "
-                                  <> primExpr2pandocMath (fsLang fSpec) (attExpr att)
-                                  <> "."
-                                  )
+                      <> (case attUse att of
+                            PrimaryKey _ -> case fsLang fSpec of
+                                              Dutch   -> "Dit attribuut is de primaire sleutel. "
+                                              English -> "This attribute is the primary key. "
+                            ForeignKey c -> case fsLang fSpec of
+                                              Dutch   -> "Dit attribuut verwijst naar een voorkomen in de tabel "
+                                              English -> "This attribute is a foreign key to "
+                                               <> (text.name) c
+                            PlainAttr  -> ( case fsLang fSpec of
+                                              Dutch   -> "Dit attribuut implementeert "
+                                              English -> "This attribute implements "
+                                          <> primExpr2pandocMath (fsLang fSpec) (attExpr att)
+                                          <> "."
+                                          )
                          )
                       <> linebreak
                       <> (code.show.attType) att

src/Database/Design/Ampersand/Prototype/Generate.hs

@@ -58,9 +58,8 @@ generateDBstructQueries fSpec withComment
           <>[" ) ENGINE="<>dbEngine]
          ):
          [ ["CREATE INDEX "<>show (tsName ts<>"_"<>name fld)<>" ON "<>show (tsName ts)<>" ("<>show (name fld)<>")"]
-         | fld <- case tsflds ts of
-                    _:xs -> xs
-                    _ -> fatal 55 $ "A table with no fields found! ("<>show (tsName ts)<>")"
+         | fld <- tsflds ts
+         , not (isPrimaryKey fld)
          , suitableAsKey (attType  fld)
          ]
         fld2sql :: SqlAttribute -> String
@@ -108,9 +107,9 @@ plug2TableSpec plug
                  (BinSQL{}, _)   -> []
                  (TblSQL{}, primFld) ->
                       case attUse primFld of
-                         TableKey isPrim _ -> ["PRIMARY " <> "KEY (" <> (show . attName) primFld <> ")" | isPrim]
-                         ForeignKey c  -> fatal 195 ("ForeignKey "<>name c<>"not expected here!")
-                         PlainAttr     -> []
+                         PrimaryKey _ -> ["PRIMARY KEY (`" <> (show . attName) primFld <> "`)" ]
+                         ForeignKey c -> fatal 195 ("ForeignKey "<>name c<>"not expected here!")
+                         PlainAttr    -> []
      , tsEngn = dbEngine
      }
 

src/Database/Design/Ampersand/Prototype/PHP.hs

@@ -80,9 +80,7 @@ plug2TableSpec plug
            (BinSQL{}, _)   -> []
            (_,    primAtt) ->
                 case attUse primAtt of
-                   TableKey isPrim _ -> [ (if isPrim then "PRIMARY " else "")
-                                          <> "KEY (`"<>Text.pack (attName primAtt)<>"`)"
-                                        ]
+                   PrimaryKey _ -> [ "PRIMARY KEY (`"<>Text.pack (attName primAtt)<>"`)"]
                    ForeignKey c  -> fatal 195 ("ForeignKey "<>name c<>"not expected here!")
                    PlainAttr     -> []
    , "InnoDB DEFAULT CHARACTER SET UTF8 DEFAULT COLLATE UTF8_BIN")