Introduce specific types like NamePart

src/Ampersand/ADL1/P2A_Converters.hs

@@ -1061,7 +1061,7 @@ pCtx2aCtx
                 bindedRel = EDcD rel
                 mkRule command fExpr =
                   Rule
-                    { rrnm = mkName RelationName (toText1Unsafe ("Compute" <> tshow (hash lbl')) NE.:| []),
+                    { rrnm = mkName RelationName (toNamePartUnsafe ("Compute" <> tshow (hash lbl')) NE.:| []),
                       rrlbl = Just (Label lbl'),
                       formalExpression = fExpr,
                       rrfps = pos',

src/Ampersand/ADL1/Rule.hs

@@ -47,7 +47,7 @@ rulefromProp prp rel =
           (nameSpaceOf rel)
           . mkName
             RuleName
-          $ (toText1Unsafe (tshow prp <> "_" <> tshow rel) NE.:| []),
+          $ (toNamePartUnsafe (tshow prp <> "_" <> tshow rel) NE.:| []),
       rrlbl = Just . Label $ tshow prp <> " rule for relation " <> tshow rel,
       formalExpression = rExpr,
       rrfps = PropertyRule relIdentifier (origin rel),

src/Ampersand/Basics/Name.hs

@@ -4,38 +4,54 @@
 module Ampersand.Basics.Name
   ( Named (..),
     Name,
+    NamePart,
     NameSpace,
     NameType (..),
     Label (..),
     Labeled (..),
+    Rename (..),
     mkName,
     nameOfONE,
     nameOfExecEngineRole,
     withNameSpace,
     prependToPlainName,
     urlEncodedName,
     splitOnDots,
+    namePartToText,
+    namePartToText1,
+    toNamePartUnsafe,
+    toNamePartUnsafe1,
+    checkProperId,
   )
 where
 
+import Ampersand.Basics.Auxiliaries (eqCl)
 import Ampersand.Basics.Prelude
-import Ampersand.Basics.String (text1ToText, toText1Unsafe, urlEncode)
+import Ampersand.Basics.String (isSafeIdChar, text1ToText, toText1Unsafe, urlEncode)
 import Ampersand.Basics.Version (fatal)
 import qualified Data.GraphViz.Printing as GVP
 import Data.Hashable
+import qualified Data.Text1 as T1
 import qualified RIO.List as L
 import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import qualified RIO.Text.Lazy as TL
 
-type NameSpace = [Text1]
+type NameSpace = [NamePart]
+
+-- A namepart is a single word, that starts with an alphanumeric character
+-- and may contain of alphanumeric characters and digits only.
+newtype NamePart = NamePart Text1 deriving (Data)
+
+instance Show NamePart where
+  show (NamePart t1) = show t1
 
 data Name = Name
   { -- | A name in a namespace can be seen as a nonempty list of words.
     --   currently, we only deal with 'absolute' names.
     --   the separator that is inbetween the nameWords can be depending on the specific environment.
     --   in an .adl file, we will assume a dot `.` as separator.
-    nameWords :: !(NonEmpty Text1),
+    nameWords :: !(NonEmpty NamePart),
     nameType :: !NameType
   }
   deriving (Data)
@@ -52,7 +68,7 @@ instance Show Name where
       . mconcat
       . L.intersperse "."
       . toList
-      . fmap text1ToText
+      . fmap namePartToText
       . nameWords
 
 instance Hashable Name where
@@ -64,7 +80,32 @@ instance Named Name where
 instance GVP.PrintDot Name where
   unqtDot = GVP.text . TL.fromStrict . text1ToText . tName
 
-mkName :: NameType -> NonEmpty Text1 -> Name
+-- | toNamePartUnsafe will convert a Text to a NamePart. The Text must be a proper ID. (See checkProperId)
+toNamePartUnsafe :: Text -> NamePart
+toNamePartUnsafe txt = case T.uncons txt of
+  Nothing -> fatal "toText1Unsafe must not be used unless you are certain that it is safe!"
+  Just (h, tl) -> toNamePartUnsafe1 $ Text1 h tl
+
+-- | toNamePartUnsafe1 will convert a Text1 to a NamePart. The Text1 must be a proper ID. (See checkProperId)
+toNamePartUnsafe1 :: Text1 -> NamePart
+toNamePartUnsafe1 = NamePart . checkProperId
+
+-- | This function checks
+checkProperId :: Text1 -> Text1
+checkProperId t@(Text1 h tl) =
+  if isProper
+    then t
+    else fatal $ "Not a proper Id: " <> text1ToText t
+  where
+    isProper = and (isSafeIdChar True h : (isSafeIdChar False <$> T.unpack tl))
+
+namePartToText :: NamePart -> Text
+namePartToText (NamePart x) = text1ToText x
+
+namePartToText1 :: NamePart -> Text1
+namePartToText1 (NamePart x) = x
+
+mkName :: NameType -> NonEmpty NamePart -> Name
 mkName typ xs =
   Name
     { nameWords = xs,
@@ -74,14 +115,14 @@ mkName typ xs =
 nameOfExecEngineRole :: Name
 nameOfExecEngineRole =
   Name
-    { nameWords = Text1 'E' "xecEngine" :| [],
+    { nameWords = NamePart (Text1 'E' "xecEngine") :| [],
       nameType = RoleName
     }
 
 nameOfONE :: Name
 nameOfONE =
   Name
-    { nameWords = Text1 'O' "NE" :| [],
+    { nameWords = NamePart (Text1 'O' "NE") :| [],
       nameType = ConceptName
     }
 
@@ -129,15 +170,15 @@ class Named a where
   name :: a -> Name
   tName :: a -> Text1
   tName = toText1Unsafe . tshow . name
-  nameSpaceOf :: a -> [Text1]
+  nameSpaceOf :: a -> [NamePart]
   nameSpaceOf = NE.init . nameWords . name
-  plainNameOf1 :: a -> Text1
+  plainNameOf1 :: a -> NamePart
   plainNameOf1 = NE.last . nameWords . name
   plainNameOf :: a -> Text
   plainNameOf nm = T.cons h tl
     where
-      Text1 h tl = plainNameOf1 nm
-  updatedName :: Text1 -> a -> Name
+      NamePart (Text1 h tl) = plainNameOf1 nm
+  updatedName :: NamePart -> a -> Name
   updatedName txt1 x = Name ws' typ
     where
       Name ws typ = name x
@@ -157,16 +198,36 @@ instance Show Label where
   show (Label x) = "LABEL " <> T.unpack x
 
 prependToPlainName :: Text -> Name -> Name
-prependToPlainName prefix nm =
-  nm {nameWords = NE.reverse $ toText1Unsafe (prefix <> text1ToText h) NE.:| tl}
+prependToPlainName t nm =
+  nm {nameWords = NE.reverse $ prepend t h NE.:| tl}
   where
     h NE.:| tl = NE.reverse . nameWords $ nm
 
+prepend :: Text -> NamePart -> NamePart
+prepend t (NamePart txt) = NamePart (t T1..<> txt)
+
+postpend :: Text -> NamePart -> NamePart
+postpend t (NamePart txt) = NamePart (txt T1.<>. t)
+
 urlEncodedName :: Name -> Text1
 urlEncodedName = toText1Unsafe . urlEncode . text1ToText . tName
 
 -- Should be in RIO.NonEmpty:
 prependList :: [a] -> NonEmpty a -> NonEmpty a
 prependList ls ne = case ls of
   [] -> ne
-  (x : xs) -> x :| xs <> toList ne
+  (x : xs) -> x :| xs <> toList ne
+
+class Named a => Rename a where
+  rename :: a -> NamePart -> a
+
+  -- | the function mkUniqueNames ensures case-insensitive unique names like sql plug names
+  mkUniqueNames :: [Name] -> [a] -> [a]
+  mkUniqueNames taken xs =
+    [ p
+      | cl <- eqCl (T.toLower . text1ToText . tName) xs,
+        p <- -- each equivalence class cl contains (identified a) with the same map toLower (name p)
+          if name (NE.head cl) `elem` taken || length cl > 1
+            then [rename p (postpend (tshow i) (plainNameOf1 p)) | (p, i) <- zip (NE.toList cl) [(1 :: Int) ..]]
+            else NE.toList cl
+    ]

src/Ampersand/Basics/Unique.hs

@@ -12,9 +12,9 @@ module Ampersand.Basics.Unique
   )
 where
 
+import Ampersand.Basics.Name (checkProperId)
 import Ampersand.Basics.Prelude
-import Ampersand.Basics.String (isSafeIdChar, text1ToText, toText1Unsafe)
-import Ampersand.Basics.Version (fatal)
+import Ampersand.Basics.String (text1ToText, toText1Unsafe)
 import Data.Hashable
 import Data.Typeable
 import qualified RIO.Set as Set
@@ -60,15 +60,6 @@ class (Typeable e, Eq e) => Unique e where
   addType :: e -> Text1 -> Text1
   addType x string = toText1Unsafe $ tshow (typeOf x) <> "_" <> text1ToText string
 
--- | This function
-checkProperId :: Text1 -> Text1
-checkProperId t@(Text1 h tl) =
-  if isProper
-    then t
-    else fatal $ "Not a proper Id: " <> text1ToText t
-  where
-    isProper = and (isSafeIdChar True h : (isSafeIdChar False <$> T.unpack tl))
-
 uniqueButNotTooLong :: Text1 -> Text1
 uniqueButNotTooLong txt =
   let (prfx, rest) = T.splitAt safeLength (text1ToText txt)

src/Ampersand/Classes/ViewPoint.hs

@@ -79,7 +79,7 @@ ruleFromIdentity identity =
               (nameSpaceOf identity)
               . mkName
                 RuleName
-              $ (toText1Unsafe ("identity_" <> tshow identity) NE.:| []),
+              $ (toNamePartUnsafe ("identity_" <> tshow identity) NE.:| []),
           rrlbl = Just . Label $ "Identity rule for " <> tshow identity,
           formalExpression = term,
           rrfps = origin identity, -- position in source file

src/Ampersand/Core/AbstractSyntaxTree.hs

@@ -1373,8 +1373,8 @@ data Type
 instance Named Type where
   name t = case t of
     UserConcept nm -> nm
-    BuiltIn tt -> mkName ConceptName . fmap toText1Unsafe $ ("AmpersandBuiltIn" NE.:| [tshow tt])
-    RepresentSeparator -> mkName ConceptName . fmap toText1Unsafe $ "AmpersandBuiltIn" NE.:| ["RepresentSeparator"]
+    BuiltIn tt -> mkName ConceptName . fmap toNamePartUnsafe $ ("AmpersandBuiltIn" NE.:| [tshow tt])
+    RepresentSeparator -> mkName ConceptName . fmap toNamePartUnsafe $ "AmpersandBuiltIn" NE.:| ["RepresentSeparator"]
 
 instance Show Type where
   show a = T.unpack $ case a of

src/Ampersand/FSpec/FSpec.hs

@@ -323,6 +323,9 @@ data PlugSQL
 instance Named PlugSQL where
   name = sqlname
 
+instance Rename PlugSQL where
+  rename p txt1 = p {sqlname = updatedName txt1 p}
+
 instance Eq PlugSQL where
   a == b = compare a b == EQ
 

src/Ampersand/FSpec/ShowMeatGrinder.hs

@@ -53,7 +53,7 @@ metaModel mmLabel =
     modelName =
       withNameSpace nameSpace
         . mkName ContextName
-        $ (toText1Unsafe ("MetaModel_" <> tshow mmLabel) NE.:| [])
+        $ (toNamePartUnsafe ("MetaModel_" <> tshow mmLabel) NE.:| [])
     transformers = case mmLabel of
       FormalAmpersand -> transformersFormalAmpersand . emptyFSpec $ modelName
       PrototypeContext -> transformersPrototypeContext . emptyFSpec $ modelName
@@ -67,7 +67,7 @@ metaModel mmLabel =
 grind :: NameSpace -> (FSpec -> [Transformer]) -> FSpec -> P_Context
 grind ns fun userFspec =
   PCtx
-    { ctx_nm = withNameSpace ns . mkName ContextName $ (toText1Unsafe "Grinded_" <> tName userFspec) NE.:| [],
+    { ctx_nm = prependToPlainName "Grinded_" $ withNameSpace ns . mkName ContextName $ plainNameOf1 userFspec NE.:| [],
       ctx_lbl = Nothing,
       ctx_pos = [],
       ctx_lang = Nothing,

src/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs

@@ -16,7 +16,6 @@ import Ampersand.FSpec.ToFSpec.Calc
 import Ampersand.FSpec.ToFSpec.NormalForms
 import Ampersand.FSpec.ToFSpec.Populated
 import Ampersand.Misc.HasClasses
-import qualified Data.Text1 as T1
 import qualified RIO.List as L
 import qualified RIO.NonEmpty as NE
 import qualified RIO.NonEmpty.Partial as PARTIAL
@@ -299,13 +298,13 @@ makeFSpec env context =
     allplugs = genPlugs -- all generated plugs
     genPlugs =
       [ InternalPlug (rename p (plainNameOf1 p))
-        | p <- uniqueNames [] (qlfname <$> makeGeneratedSqlPlugs env context)
+        | p <- mkUniqueNames [] (qlfname <$> makeGeneratedSqlPlugs env context)
       ]
       where
         qlfname :: PlugSQL -> PlugSQL
         qlfname x = case T.uncons . view namespaceL $ env of
           Nothing -> x
-          Just (c, tl) -> x {sqlname = withNameSpace [Text1 c tl] $ name x}
+          Just (c, tl) -> x {sqlname = withNameSpace [toNamePartUnsafe (T.cons c tl)] $ name x}
     --TODO151210 -> Plug A is overbodig, want A zit al in plug r
     --CONTEXT Temp
     --PATTERN Temp
@@ -492,12 +491,12 @@ makeFSpec env context =
               nm' 0 =
                 mkName ConceptName
                   . NE.reverse
-                  $ (toText1Unsafe . plural (ctxlang context) . plainNameOf $ c)
+                  $ (toNamePartUnsafe . plural (ctxlang context) . plainNameOf $ c)
                     NE.:| reverse (nameSpaceOf (name c))
               nm' i =
                 mkName ConceptName
                   . NE.reverse
-                  $ (toText1Unsafe . plural (ctxlang context) $ plainNameOf c <> tshow i)
+                  $ (toNamePartUnsafe . plural (ctxlang context) $ plainNameOf c <> tshow i)
                     NE.:| reverse (nameSpaceOf (name c))
               nm = case [nm' i | i <- [0 ..], nm' i `notElem` map name (ctxifcs context)] of
                 [] -> fatal "impossible"
@@ -528,21 +527,6 @@ makeifcConjuncts params allConjs =
       -- and the uni/inj invariant rules need to be filtered out at a later stage (in Generate.hs).
   ]
 
-class Named a => Rename a where
-  rename :: a -> Text1 -> a
-
-  -- | the function uniqueNames ensures case-insensitive unique names like sql plug names
-  uniqueNames :: [Name] -> [a] -> [a]
-  uniqueNames taken xs =
-    [ p | cl <- eqCl (T.toLower . text1ToText . tName) xs, p <- -- each equivalence class cl contains (identified a) with the same map toLower (name p)
-                                                             if name (NE.head cl) `elem` taken || length cl > 1
-                                                               then [rename p (plainNameOf1 p T1.<>. tshow i) | (p, i) <- zip (NE.toList cl) [(1 :: Int) ..]]
-                                                               else NE.toList cl
-    ]
-
-instance Rename PlugSQL where
-  rename p txt1 = p {sqlname = updatedName txt1 p}
-
 tblcontents :: ContextInfo -> [Population] -> PlugSQL -> [[Maybe AAtomValue]]
 tblcontents ci ps plug =
   case plug of

src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs

@@ -12,6 +12,7 @@ import Ampersand.Classes
 import Ampersand.FSpec.FSpec
 import Ampersand.FSpec.ToFSpec.Populated (sortSpecific2Generic)
 import Ampersand.Misc.HasClasses
+import RIO.Char (toUpper)
 import qualified RIO.NonEmpty as NE
 import qualified RIO.Set as Set
 import qualified RIO.Text as T
@@ -66,27 +67,34 @@ makeGeneratedSqlPlugs env context = conceptTables <> linkTables
                 ([], h : tl) -> f (insert (Right h) names) ([], tl)
                 (h : tl, _) -> f (insert (Left h) names) (tl, ds)
             insert :: Either A_Concept Relation -> [(Either A_Concept Relation, SqlColumName)] -> [(Either A_Concept Relation, SqlColumName)]
-            insert item mp = (item, mkNewSqlColumName item $ map snd mp) : mp
+            insert item mp = (item, mkNewSqlColumName itemName $ map snd mp) : mp
+              where
+                itemName = case item of
+                  Right rel -> name rel
+                  Left cpt -> name cpt
             -- Find the next free SqlColumName
-            mkNewSqlColumName :: Either A_Concept Relation -> [SqlColumName] -> SqlColumName
+            mkNewSqlColumName :: Name -> [SqlColumName] -> SqlColumName
             mkNewSqlColumName nm forbiddens = firstFree 0
               where
                 firstFree :: Integer -> SqlColumName
                 firstFree i =
                   if toSqlColName i `elem` forbiddens
                     then firstFree (i + 1)
                     else toSqlColName i
+                toSqlColName :: Integer -> SqlColumName
                 toSqlColName i =
-                  text1ToSqlColumName
-                    . toText1Unsafe
-                    . T.intercalate "__"
-                    . map text1ToText
-                    $ either nameSpaceOf nameSpaceOf nm <> [addPostfix (either plainNameOf1 plainNameOf1 nm) (if i == 0 then Nothing else Just (toText1Unsafe ("_" <> tshow i)))]
-                addPostfix :: Text1 -> Maybe Text1 -> Text1
-                addPostfix x pst = case pst of
-                  Nothing -> x
-                  Just y -> x <> y
-
+                  text1ToSqlColumName . toText1Unsafe . T.pack $
+                    firstpart (nameSpaceOf nm)
+                      <> lastpart (plainNameOf1 nm)
+                      <> (if i > 0 then show i else mempty)
+                  where
+                    firstpart =
+                      concatMap
+                        ( \ns -> case show ns of
+                            "" -> fatal "inpossible to have an empty nameSpace."
+                            h : _ -> toUpper h : "__"
+                        )
+                    lastpart = show
         tableKey = tyroot typ
         conceptLookuptable :: [(A_Concept, SqlAttribute)]
         conceptLookuptable = [(cpt, cptAttrib cpt) | cpt <- cpts]