Issue 1275

.github/workflows/ci2.yml

@@ -6,103 +6,116 @@ on:
       - "**" # Only trigger on branches (i.e. not tags, ..)
 
 jobs:
+  hlint:
+    name: Check for code sanity with hlint
+    runs-on: ubuntu-latest
+    steps:
+      - name: Checkout project contents 📡
+        uses: actions/checkout@v2
+      - name: Setup hlint
+        uses: rwe/actions-hlint-setup@v1
+      - name: Run hlint
+        uses: rwe/actions-hlint-run@v2
+
   build-and-test-docker:
     name: Build with Docker
     runs-on: ubuntu-latest
     env:
       DOCKER_AMPERSAND_IMAGE: ampersandtarski/ampersand
     steps:
-    - name: Checkout code
-      uses: actions/checkout@v2
+      - name: Checkout code
+        uses: actions/checkout@v2
 
-    - name: Prepare for docker
-      run: |
-        echo Running on branch ${GITHUB_REF##*/}
-        docker version
+      - name: Prepare for docker
+        run: |
+          echo Running on branch ${GITHUB_REF##*/}
+          docker version
 
-    - name: Build final image
-      run: docker build . --tag ${DOCKER_AMPERSAND_IMAGE}:latest --build-arg GIT_SHA=${{ github.sha }} --build-arg GIT_Branch=${{ github.ref }}
+      - name: Build final image
+        run: docker build . --tag ${DOCKER_AMPERSAND_IMAGE}:latest --build-arg GIT_SHA=${{ github.sha }} --build-arg GIT_Branch=${{ github.ref }}
 
-    # For main branch push latest to DockerHub
-    - name: Login to DockerHub
-      if: github.ref == 'refs/heads/main'
-      uses: docker/login-action@v1
-      with:
-        username: ${{ secrets.DOCKER_HUB_USERNAME }}
-        password: ${{ secrets.DOCKER_HUB_PASSWORD }}
-    - name: Push latest
-      if: github.ref == 'refs/heads/main'
-      run: docker push ${DOCKER_AMPERSAND_IMAGE}:latest
+      # For main branch push latest to DockerHub
+      - name: Login to DockerHub
+        if: github.ref == 'refs/heads/main'
+        uses: docker/login-action@v1
+        with:
+          username: ${{ secrets.DOCKER_HUB_USERNAME }}
+          password: ${{ secrets.DOCKER_HUB_PASSWORD }}
+      - name: Push latest
+        if: github.ref == 'refs/heads/main'
+        run: docker push ${DOCKER_AMPERSAND_IMAGE}:latest
 
   build-and-test-ubuntu:
     name: Build and test on ubuntu-latest 🏗 🧪
     runs-on: ubuntu-latest
     steps:
-      - 
-        name: Checkout project contents 📡
+      - name: Checkout project contents 📡
         uses: actions/checkout@v2
-      - 
-        name: Use cache when available 📦
+      - name: Use cache when available 📦
         uses: freckle/stack-cache-action@main
-      - 
-        name: Build and test 🏗 🧪
-        uses: freckle/stack-action@main # stack-action does all these steps: dependencies, build, test.
+      - name: Set up Mariadb 🧰
+        uses: shogo82148/actions-setup-mysql@v1
         with:
-          stack-arguments: '--copy-bins --flag ampersand:buildAll'
-          weeder: true  # TODO: Re-enable. See https://github.com/AmpersandTarski/Ampersand/issues/1225
-          hlint: true
+          mysql-version: "mariadb-10.6"
+      - name: Build and test 🏗 🧪
+        uses: freckle/stack-action@v3 # stack-action does all these steps: dependencies, build, test.
+        with:
+          stack-arguments: "--copy-bins --flag ampersand:buildAll"
+      - name: Check weeds🌿🌿🌿
+        uses: freckle/stack-action@v1
+        with:
+          weeder: true
 
   build-and-test-macOS:
     name: Build and test on macOS  🏗 🧪
     runs-on: macos-latest
     steps:
-      - 
-        name: Checkout project contents 📡
+      - name: Checkout project contents 📡
         uses: actions/checkout@v2
-      - 
-        name: Use cache when available 📦
+      - name: Use cache when available 📦
         uses: freckle/stack-cache-action@main
-      - 
-        name: Build and test  🏗 🧪
-        uses: freckle/stack-action@main
+      - name: Set up Mariadb 🧰
+        uses: shogo82148/actions-setup-mysql@v1
+        with:
+          mysql-version: "mariadb-10.6"
+      - name: Build and test  🏗 🧪
+        uses: freckle/stack-action@v3
         with:
-          stack-arguments: '--copy-bins --flag ampersand:buildAll'
-          weeder: false
-          hlint: true
+          stack-arguments: "--copy-bins --flag ampersand:buildAll"
+      - name: Check weeds🌿🌿🌿
+        uses: freckle/stack-action@v1
+        with:
+          weeder: true
 
   build-and-test-windows:
     name: Build and test on Windows 🏗 🧪
     runs-on: windows-latest
     steps:
-      - 
-        name: Checkout project contents 📡
+      - name: Checkout project contents 📡
         uses: actions/checkout@v2
-      - 
-        name: Use cache (manually) 📦 # See https://github.com/freckle/stack-cache-action/issues/5
+      - name: Use cache (manually) 📦 # See https://github.com/freckle/stack-cache-action/issues/5
         uses: actions/cache@v2.1.3
         # TODO: Cache might be done better, see for inspiration:  https://github.com/godu/advent-of-code-2020/blob/46796832f59d185457a8edf8de043a54a451d688/.github/workflows/ci.yml
         with:
-          path: | 
+          path: |
             ~/.ghc
             ~/.stack
             ~/.stack-work
           key: ${{ runner.os }}-stack
-      - 
-        name: Set up MySQL 🧰
+      - name: Set up Mariadb 🧰
         uses: shogo82148/actions-setup-mysql@v1
         with:
-          mysql-version: '8.0'
-      - 
-        name: Setup PHP 🧰
+          mysql-version: "mariadb-10.6"
+      - name: Setup PHP 🧰
         uses: shivammathur/setup-php@v2
         with:
-          php-version: '8.0'
+          php-version: "8.0"
           extensions: mysqli
-      - 
-        name: Build and test 🏗 🧪
-        uses: freckle/stack-action@main
+      - name: Build and test 🏗 🧪
+        uses: freckle/stack-action@v3
         with:
-          stack-arguments: '--copy-bins --flag ampersand:buildAll'
-          weeder: false
-          hlint: false
-
+          stack-arguments: "--copy-bins --flag ampersand:buildAll"
+      - name: Check weeds🌿🌿🌿
+        uses: freckle/stack-action@v1
+        with:
+          weeder: true

ReleaseNotes.md

@@ -2,6 +2,7 @@
 
 ## Unreleased changes
 * [Issue #1267](https://github.com/AmpersandTarski/Ampersand/issues/1267) Automatically add ReleaseNotes to release artefacts
+* [Issue #1275](https://github.com/AmpersandTarski/Ampersand/issues/1275) Fix duplicate pattern bug
 
 ## v4.6.2 (2 December 2021)
 

ampersand.cabal

@@ -157,6 +157,7 @@ extra-source-files:
     testing/Travis/testcases/Check/ShouldFail/Issue1063.adl
     testing/Travis/testcases/Check/ShouldFail/testinfo.yaml
     testing/Travis/testcases/Check/testinfo.yaml
+    testing/Travis/testcases/FuncSpec/Issue1275.adl
     testing/Travis/testcases/FuncSpec/Mandatering/Mandatering.adl
     testing/Travis/testcases/FuncSpec/Mandatering/ToevoegenMandaat.adl
     testing/Travis/testcases/FuncSpec/testinfo.yaml

src/Ampersand/ADL1/PrettyPrinters.hs

@@ -7,7 +7,7 @@ module Ampersand.ADL1.PrettyPrinters (Pretty (..), prettyPrint) where
 import Ampersand.Basics hiding (view, (<$>))
 import Ampersand.Core.ParseTree
 import Ampersand.Input.ADL1.Lexer (keywords)
-import RIO.Char (toUpper)
+import RIO.Char (isLetter, toUpper)
 import qualified RIO.NonEmpty as NE
 import qualified RIO.Set as Set
 import qualified RIO.Text as T
@@ -57,7 +57,7 @@ isId xs =
     Nothing -> False
     Just (h, _) -> T.all isIdChar xs && isFirstIdChar h && xs `notElem` map T.pack keywords
       where
-        isFirstIdChar x = elem x $ "_" ++ ['a' .. 'z'] ++ ['A' .. 'Z']
+        isFirstIdChar x = x == '_' || isLetter x
         isIdChar x = isFirstIdChar x || elem x ['0' .. '9']
 
 isUpperId :: Text -> Bool

src/Ampersand/FSpec/SQL.hs

@@ -892,7 +892,6 @@ nonSpecialSelectExpr fSpec expr =
           traceComment
             ["case ECpl (EDcV _)"]
             emptySet
-        EDcI ONE -> fatal "EDcI ONE must not be seen at this place."
         EDcI c ->
           traceComment
             ["case: ECpl (EDcI c)"]

src/Ampersand/FSpec/ShowHS.hs

@@ -7,6 +7,7 @@ import Ampersand.ADL1
 import Ampersand.Basics
 import Ampersand.Core.ShowAStruct (AStruct (..)) -- for traceability, we generate comments in the Haskell code.
 import Ampersand.FSpec.FSpec
+import Ampersand.FSpec.Instances (Instances (instanceList))
 import Ampersand.Misc.HasClasses
 import Data.Hashable
 import RIO.Char (isAlphaNum)
@@ -353,10 +354,10 @@ instance ShowHS FSpec where
                  <> T.concat [indent <> " " <> showHSName p <> indent <> "  = " <> showHS env (indent <> "    ") p | InternalPlug p <- L.sortBy (compare `on` name) (plugInfos fSpec)]
                  <> "\n"
          )
-      <> ( if null (vpatterns fSpec)
+      <> ( if null (instanceList fSpec :: [Pattern])
              then ""
              else
-               "\n -- *** Patterns (total: " <> (tshow . length . vpatterns) fSpec <> " patterns) ***: "
+               "\n -- *** Patterns (total: " <> (tshow . length $ (instanceList fSpec :: [Pattern])) <> " patterns) ***: "
                  <> T.concat [indent <> " " <> showHSName x <> indent <> "  = " <> showHS env (indent <> "    ") x | x <- vpatterns fSpec]
                  <> "\n"
          )

src/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs

@@ -72,7 +72,7 @@ makeFSpec env context =
       allConcepts = fSpecAllConcepts,
       cptTType = representationOf contextinfo,
       fsisa = L.nub . concatMap genericAndSpecifics . gens $ context,
-      vpatterns = patterns context,
+      vpatterns = mergeByName . patterns $ context,
       vgens = gens context,
       vIndices = identities context,
       vviews = viewDefs context,
@@ -114,6 +114,29 @@ makeFSpec env context =
       isSignal = fIsSignal
     }
   where
+    mergeByName :: [Pattern] -> [Pattern]
+    mergeByName [] = []
+    mergeByName (h : tl) = h' : otherNamedPats
+      where
+        (sameNamePats, otherNamedPats) = L.partition (\pat -> name h == name pat) tl
+        h' = foldr merge h sameNamePats
+        merge p1 p2 =
+          A_Pat
+            { ptnm = name p1,
+              ptpos = ptpos p1,
+              ptend = ptend p1,
+              ptrls = ptrls p1 <> ptrls p2,
+              ptgns = ptgns p1 <> ptgns p2,
+              ptdcs = ptdcs p1 <> ptdcs p2,
+              ptrrs = ptrrs p1 <> ptrrs p2,
+              ptcds = ptcds p1 <> ptcds p2,
+              ptrps = ptrps p1 <> ptrps p2,
+              ptups = ptups p1 <> ptups p2,
+              ptids = ptids p1 <> ptids p2,
+              ptvds = ptvds p1 <> ptvds p2,
+              ptxps = ptxps p1 <> ptxps p2,
+              ptenfs = ptenfs p1 <> ptenfs p2
+            }
     fIsSignal :: Rule -> Bool
     fIsSignal = not . null . maintainersOf
 

src/Ampersand/Output/ToPandoc/ChapterConceptualAnalysis.hs

@@ -49,7 +49,7 @@ chpConceptualAnalysis env lev fSpec =
       )
         <> purposes2Blocks env (purposesOf fSpec outputLang' fSpec) -- This explains the purpose of this context.
     pictures =
-      map pictOfPat (vpatterns fSpec)
+      map pictOfPat (instanceList fSpec)
         <> map pictOfConcept (Set.elems $ concs fSpec)
         <> map pictOfRule (Set.elems $ vrules fSpec)
     -----------------------------------------------------

src/Ampersand/Output/ToPandoc/ChapterDiagnosis.hs

@@ -53,7 +53,7 @@ chpDiagnosis env fSpec
     outputLang' = outputLang env fSpec
     roleomissions :: Blocks
     roleomissions
-      | null (vpatterns fSpec) = mempty
+      | null (instanceList fSpec :: [Pattern]) = mempty
       | (null . fRoleRuls) fSpec && (not . null . vrules) fSpec =
         plain
           ( (emph . str . upCap . name) fSpec
@@ -380,7 +380,7 @@ chpDiagnosis env fSpec
               d `notElem` (bindedRelationsIn . vrules) fSpec
           ]
         pats =
-          [ pat | pat <- vpatterns fSpec, (not . null) (relsDefdIn pat Set.\\ bindedRelationsIn pat)
+          [ pat | pat <- instanceList fSpec, (not . null) (relsDefdIn pat Set.\\ bindedRelationsIn pat)
           ]
         pictsWithUnusedRels = [makePicture env fSpec (PTDeclaredInPat pat) | pat <- pats]
 
@@ -479,7 +479,7 @@ chpDiagnosis env fSpec
               ]
           )
           -- Content rows
-          ( map mkTableRowPat (vpatterns fSpec)
+          ( map mkTableRowPat (instanceList fSpec :: [Pattern])
               <> [mkTableRow (l (NL "Gehele context", EN "Entire context")) (Set.filter decusr $ vrels fSpec) (vrules fSpec)]
           )
       where
@@ -536,7 +536,7 @@ chpDiagnosis env fSpec
                 | (rol, rul) <- fRoleRuls fSpec
               ]
       where
-        multProcs = length (vpatterns fSpec) > 1
+        multProcs = length (instanceList fSpec :: [Pattern]) > 1
 
     wipReport :: Blocks
     wipReport =

src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs

@@ -336,10 +336,10 @@ orderingByTheme env fSpec =
         dclsOfTheme = fmap dcl2dclCont nrelations,
         cptsOfTheme = fmap cpt2cptCont nconcepts
       }
-    | (pat, i, nrules, nrelations, nconcepts) <- L.zip5 (vpatterns fSpec) [0 ..] (NE.init nruless) (NE.init nrelationss) (NE.init nconceptss)
+    | (pat, i, nrules, nrelations, nconcepts) <- L.zip5 (instanceList fSpec) [0 ..] (NE.init nruless) (NE.init nrelationss) (NE.init nconceptss)
   ]
     <> [ Thm
-           { themeNr = length (vpatterns fSpec),
+           { themeNr = length (instanceList fSpec :: [Pattern]),
              patOfTheme = Nothing,
              rulesOfTheme = fmap rul2rulCont (NE.last nruless),
              dclsOfTheme = fmap dcl2dclCont (NE.last nrelationss),
@@ -360,7 +360,7 @@ orderingByTheme env fSpec =
     conceptss :: [[AConceptDef]]
     relationss :: [Relations]
     (ruless, conceptss, relationss) =
-      L.unzip3 [(ptrls pat, ptcds pat, ptdcs pat) | pat <- vpatterns fSpec]
+      L.unzip3 [(ptrls pat, ptcds pat, ptdcs pat) | pat <- instanceList fSpec]
     numbering :: Int -> [[a]] -> [[Numbered a]]
     numbering n (xs : xss) = [Nr i x | (x, i) <- zip xs [n ..]] : numbering (n + length xs) xss
     numbering _ _ = []