Squashed commit of the following:

commit 9bbd879 Merge: 5afbdd8 4599950 Author: hanjoosten <[email protected]> Date: Mon Jun 10 23:40:51 2024 +0200 Merge branch 'feature/meaning-populate-text' into main-of-ampersand-4 commit 4599950 Author: hanjoosten <[email protected]> Date: Mon Jun 10 21:38:46 2024 +0200 Fix population of Meaning commit 87e93de Author: hanjoosten <[email protected]> Date: Tue Jun 4 10:58:20 2024 +0200 Population still yealds violations commit 5afbdd8 Author: hanjoosten <[email protected]> Date: Sat Jun 1 23:46:29 2024 +0200 minor things to ease comming migration commit 9b67e89 Author: hanjoosten <[email protected]> Date: Sat Jun 1 16:25:33 2024 +0200 Minor enhancement of Setup.hs commit 7f42788 Author: hanjoosten <[email protected]> Date: Sat Jun 1 10:21:08 2024 +0200 Minor thing for windows commit 533cc2e Author: hanjoosten <[email protected]> Date: Sat Jun 1 10:18:19 2024 +0200 Fix Dockerfile commit badddcd Author: hanjoosten <[email protected]> Date: Sat Jun 1 10:11:33 2024 +0200 Small fix for Windows commit cbc8add Author: hanjoosten <[email protected]> Date: Sat Jun 1 09:19:39 2024 +0200 Also read ' UTC' after datetime if present commit c90ed6d Author: hanjoosten <[email protected]> Date: Sat Jun 1 09:12:37 2024 +0200 Revert "Retrieve fix for DateTime parser" This reverts commit 290ef6c. commit 290ef6c Author: hanjoosten <[email protected]> Date: Fri May 31 15:37:54 2024 +0200 Retrieve fix for DateTime parser
AmpersandTarski · Jun 13, 2024 · de22bec · de22bec
1 parent c145aad
commit de22bec
Show file tree

Hide file tree

Showing 10 changed files with 70 additions and 185 deletions.
diff --git a/AmpersandData/FormalAmpersand/Documentation.adl b/AmpersandData/FormalAmpersand/Documentation.adl
@@ -8,6 +8,7 @@ PATTERN Documentation
     CONCEPT Meaning ""
     -- CLASSIFY Meaning ISA Markup See issue https://github.com/AmpersandTarski/Ampersand/issues/1484
     -- CLASSIFY Markup ISA Meaning
+    RELATION markup[Meaning*Markup][UNI,TOT]
     CONCEPT MarkupText ""
     CONCEPT Markup ""
 

diff --git a/Dockerfile b/Dockerfile
@@ -1,5 +1,5 @@
 # The purpose of this docker file is to produce a latest Ampersand-compiler in the form of a docker image.
-FROM haskell:8.10.7 AS buildstage
+FROM haskell:9.6.4 AS buildstage
 
 RUN mkdir /opt/ampersand
 WORKDIR /opt/ampersand

diff --git a/Setup.hs b/Setup.hs
@@ -6,7 +6,7 @@
 -- Note that in order for this Setup.hs to be used by cabal, the build-type should be Custom.
 module Main where
 
---import qualified Codec.Compression.GZip as GZip  --TODO replace by Codec.Archive.Zip from package zip-archive. This reduces the amount of packages. (We now use two for zipping/unzipping)
+-- import qualified Codec.Compression.GZip as GZip  --TODO replace by Codec.Archive.Zip from package zip-archive. This reduces the amount of packages. (We now use two for zipping/unzipping)
 import Codec.Archive.Zip
 import Distribution.PackageDescription
 import Distribution.Pretty (prettyShow)
@@ -56,7 +56,8 @@ generateBuildInfoModule cabalVersionStr = do
   content <-
     buildInfoModule cabalVersionStr
       <$> getGitInfoStr
-      <*> ( T.pack . formatTime defaultTimeLocale "%d-%b-%y %H:%M:%S %Z"
+      <*> ( T.pack
+              . formatTime defaultTimeLocale "%d-%b-%y %H:%M:%S %Z"
               <$> (getCurrentTime >>= utcToLocalZonedTime)
           )
   writeFileUtf8 (pathFromModuleName buildInfoModuleName) content
@@ -76,7 +77,7 @@ generateBuildInfoModule cabalVersionStr = do
           "    , gitInfoStr",
           "    , buildTimeStr",
           "    ) where",
-          "import Ampersand.Basics.Prelude",
+          "import RIO.Text (Text)",
           "",
           "{-" <> "# NOINLINE cabalVersionStr #-}", -- disable inlining to prevent recompilation of dependent modules on each build
           "-- | The version of Ampersand as it is stated in the package.yaml file.",
@@ -190,8 +191,8 @@ generateStaticFileModule = do
         reader = readFileUtf8 sfModulePath
         errorHandler err = do
           -- old generated module exists, but we can't read the file or read the contents
-          putStrLn $
-            unlines
+          putStrLn
+            $ unlines
               [ "",
                 "Warning: Cannot read previously generated " <> sfModulePath <> ":",
                 show (err :: SomeException),
@@ -227,11 +228,12 @@ generateStaticFileModule = do
             stripbase fp = case L.stripPrefix (base ++ "/") fp of
               Just stripped -> stripped
               Nothing ->
-                error . L.intercalate "\n" $
-                  [ "ERROR: Reading static files failed:",
-                    "  base: " <> base,
-                    "  fp  : " <> fp
-                  ]
+                error
+                  . L.intercalate "\n"
+                  $ [ "ERROR: Reading static files failed:",
+                      "  base: " <> base,
+                      "  fp  : " <> fp
+                    ]
         base = case fkind of
           PandocTemplates -> "outputTemplates"
           FormalAmpersand -> "AmpersandData/FormalAmpersand"

diff --git a/src/Ampersand/Basics/Languages.hs b/src/Ampersand/Basics/Languages.hs
@@ -49,7 +49,7 @@ plural Dutch str =
           | "ij" `T.isSuffixOf` str = str <> "en"
           | "io" `T.isSuffixOf` str = str <> "'s"
           | klinker last = str <> "s"
-          | (T.take 2 . T.drop 1 . T.reverse) str `elem` ["aa", "oo", "ee", "uu"] = (T.reverse . T.drop 2 . T.reverse) str <> mede (T.drop (T.length str -1) str) <> "en"
+          | (T.take 2 . T.drop 1 . T.reverse) str `elem` ["aa", "oo", "ee", "uu"] = (T.reverse . T.drop 2 . T.reverse) str <> mede (T.drop (T.length str - 1) str) <> "en"
           | otherwise = str <> "en"
         last = case T.uncons . T.reverse $ tl of
           Nothing -> h

diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs
@@ -692,14 +692,15 @@ instance Object ObjectDef where
         Just si@Box {} -> concatMap (fieldsRecursive . objE) (filter isObjExp . siObjs $ si)
         Just InterfaceRef {} -> []
 
+isObjExp :: BoxItem -> Bool
+isObjExp BxExpr {} = True
+isObjExp BxTxt {} = False
+
 data BoxItem
   = BxExpr {objE :: ObjectDef}
   | BxTxt {objT :: BoxTxt}
   deriving (Eq, Ord, Show)
 
-isObjExp :: BoxItem -> Bool
-isObjExp BxExpr {} = True
-isObjExp BxTxt {} = False
 
 instance Unique BoxItem where
   showUnique = tshow

diff --git a/src/Ampersand/Daemon/Terminal.hs b/src/Ampersand/Daemon/Terminal.hs
@@ -18,13 +18,13 @@ import Graphics.Win32.GDI.Types
 import System.Win32.Types
 
 
-wM_SETICON, wM_GETICON :: WindowMessage
-wM_SETICON = 0x0080
+wM_GETICON :: WindowMessage
+-- wM_SETICON = 0x0080
 wM_GETICON = 0x007F
 
-iCON_BIG, iCON_SMALL :: WPARAM
-iCON_BIG = 1
-iCON_SMALL = 0
+-- iCON_BIG, iCON_SMALL :: WPARAM
+-- iCON_BIG = 1
+-- iCON_SMALL = 0
 
 #ifdef x86_64_HOST_ARCH
 #define CALLCONV ccall

diff --git a/src/Ampersand/FSpec/Crud.hs b/src/Ampersand/FSpec/Crud.hs
@@ -38,9 +38,10 @@ mkCrudInfo allConceptsPrim decls allIfcs =
 
     transSurjClosureMap :: Map.Map A_Concept [A_Concept]
     transSurjClosureMap =
-      transClosureMap' . Map.fromListWith L.union $
-        (map (mkMapItem . flp) . filter isSur . map EDcD $ Set.elems decls)
-          <> (map mkMapItem . filter isTot . map EDcD $ Set.elems decls)
+      transClosureMap'
+        . Map.fromListWith L.union
+        $ (map (mkMapItem . flp) . filter isSur . map EDcD $ Set.elems decls)
+        <> (map mkMapItem . filter isTot . map EDcD $ Set.elems decls)
       where
         -- TODO: use transClosureMap instead of transClosureMap', it's faster, and this is transClosureMap's last occurrence
 
@@ -96,20 +97,20 @@ getAllInterfaceExprs allIfcs ifc = getExprs $ ifcObj ifc
   where
     getExprs :: ObjectDef -> [Expression]
     getExprs objExpr =
-      objExpression objExpr :
-      case objmsub objExpr of
-        Nothing -> []
-        Just si -> case si of
-          InterfaceRef {siIsLink = True} -> []
-          InterfaceRef {siIsLink = False} ->
-            case filter (\rIfc -> name rIfc == siIfcId si) allIfcs of -- Follow interface ref
-              [] -> fatal ("Referenced interface " <> siIfcId si <> " missing")
-              (_ : _ : _) -> fatal ("Multiple relations of referenced interface " <> siIfcId si)
-              [i] -> getAllInterfaceExprs allIfcs i
-          Box {} -> concatMap getExprs' (siObjs si)
-          where
-            getExprs' (BxExpr e) = getExprs e
-            getExprs' (BxTxt _) = []
+      objExpression objExpr
+        : case objmsub objExpr of
+          Nothing -> []
+          Just si -> case si of
+            InterfaceRef {siIsLink = True} -> []
+            InterfaceRef {siIsLink = False} ->
+              case filter (\rIfc -> name rIfc == siIfcId si) allIfcs of -- Follow interface ref
+                [] -> fatal ("Referenced interface " <> siIfcId si <> " missing")
+                (_ : _ : _) -> fatal ("Multiple relations of referenced interface " <> siIfcId si)
+                [i] -> getAllInterfaceExprs allIfcs i
+            Box {} -> concatMap getExprs' (siObjs si)
+            where
+              getExprs' (BxExpr e) = getExprs e
+              getExprs' (BxTxt _) = []
 
 getCrudObjsPerConcept ::
   [(Interface, [(A_Concept, Bool, Bool, Bool, Bool)])] ->

diff --git a/src/Ampersand/FSpec/Instances.hs b/src/Ampersand/FSpec/Instances.hs
@@ -35,7 +35,7 @@ instance Instances A_Concept where
   instances = concs . originalContext
 
 instance Instances AConceptDef where
-  instances = Set.fromList . ctxcds . originalContext
+  instances = conceptDefInstances
 
 instance Instances BoxItem where
   instances =
@@ -103,9 +103,7 @@ instance Instances ViewDef where
   instances = Set.fromList . viewDefs . originalContext
 
 instance Instances Meaning where
-  instances fSpec =
-    (Set.fromList . concatMap meanings . Set.toList . relationInstances $ fSpec)
-      `Set.union` (Set.fromList . concatMap meanings . Set.toList . ruleInstances $ fSpec)
+  instances = meaningInstances
 
 instance Instances (PairView Expression) where
   instances = pairViewInstances
@@ -141,6 +139,7 @@ meaningInstances :: FSpec -> Set.Set Meaning
 meaningInstances fSpec =
   (Set.fromList . concatMap meanings . Set.toList . relationInstances $ fSpec)
     `Set.union` (Set.fromList . concatMap meanings . Set.toList . ruleInstances $ fSpec)
+    `Set.union` (Set.fromList . concatMap meanings . Set.toList . conceptDefInstances $ fSpec)
 
 pairViewInstances :: FSpec -> Set.Set (PairView Expression)
 pairViewInstances = Set.fromList . mapMaybe rrviol . Set.toList . ruleInstances
@@ -153,3 +152,6 @@ relationInstances = relsDefdIn . originalContext
 
 ruleInstances :: FSpec -> Set.Set Rule
 ruleInstances = allRules . originalContext
+
+conceptDefInstances :: FSpec -> Set.Set AConceptDef
+conceptDefInstances = Set.fromList . ctxcds . originalContext
diff --git a/src/Ampersand/FSpec/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs
@@ -499,14 +499,13 @@ transformersFormalAmpersand fSpec =
           | (rol, rul) <- fRoleRuls fSpec
         ]
       ),
-      -- ( "markup",
-      --   "Meaning",
-      --   "Markup",
-      --
-      --   [ (dirtyId mean, dirtyId . ameaMrk $ mean)
-      --     | mean :: Meaning <- instanceList fSpec
-      --   ]
-      -- ),
+      ( "markup",
+        "Meaning",
+        "Markup",
+        [ (dirtyId mean, dirtyId . ameaMrk $ mean)
+          | mean :: Meaning <- instanceList fSpec
+        ]
+      ),
       -- ( "markup",
       --   "Purpose",
       --   "Markup",
@@ -567,14 +566,6 @@ transformersFormalAmpersand fSpec =
           | ifc :: Interface <- instanceList fSpec
         ]
       ),
-      -- ( "name",
-      --   "ObjectDef",
-      --   "ObjectName",
-      --
-      --   [ (dirtyId obj, (PopAlphaNumeric . name) obj)
-      --     | obj :: ObjectDef <- instanceList fSpec
-      --   ]
-      -- ),
       ( "name",
         "Pattern",
         "PatternName",
@@ -731,40 +722,6 @@ transformersFormalAmpersand fSpec =
             purp <- purposes fSpec vw
         ]
       ),
-      -- -- ( "qConjuncts",
-      -- --   "Quad",
-      -- --   "Conjunct",
-      -- --
-      -- --   [ (dirtyId quad, dirtyId conj)
-      -- --     | quad <- vquads fSpec,
-      -- --       conj <- NE.toList (qConjuncts quad)
-      -- --   ] --TODO
-      -- -- ),
-      -- ( "qDcl",
-      --   "Quad",
-      --   "Relation",
-      --
-      --   [ (dirtyId quad, dirtyId (qDcl quad))
-      --     | quad <- vquads fSpec
-      --   ] --TODO
-      -- ),
-      -- ( "qRule",
-      --   "Quad",
-      --   "Rule",
-      --
-      --   [ (dirtyId quad, dirtyId (qRule quad))
-      --     | quad <- vquads fSpec
-      --   ] --TODO
-      -- ),
-      -- ( "rc_orgRules",
-      --   "Conjunct",
-      --   "Rule",
-      --
-      --   [ (dirtyId conj, dirtyId rul)
-      --     | conj :: Conjunct <- instanceList fSpec,
-      --       rul <- NE.toList $ rc_orgRules conj
-      --   ]
-      -- ),
       ( "second",
         "BinaryTerm",
         "Term",
@@ -789,24 +746,6 @@ transformersFormalAmpersand fSpec =
             (pvs, nr) <- zip (NE.toList . ppv_segs $ pv) [0 ..]
         ]
       ),
-      -- ( "sessAtom",
-      --   "SESSION",
-      --   "Atom",
-      --
-      --   [] -- This goes too deep. Keep it empty.
-      -- ),
-      -- ( "sessIfc",
-      --   "SESSION",
-      --   "Interface",
-      --
-      --   [] --TODO
-      -- ),
-      -- ( "sessionRole",
-      --   "SESSION",
-      --   "Role",
-      --
-      --   [] --TODO
-      -- ),
       ( "showADL",
         "Term",
         "ShowADL",
@@ -955,63 +894,13 @@ transformersFormalAmpersand fSpec =
             Just x <- [userTgt expr]
         ]
       ),
-      -- ( "vdats",
-      --   "View",
-      --   "ViewSegment",
-      --
-      --   [ (dirtyId vd, PopAlphaNumeric . tshow $ vs)
-      --     | vd :: ViewDef <- instanceList fSpec,
-      --       vs <- vdats vd
-      --   ]
-      -- ),
-      -- ( "vdcpt",
-      --   "View",
-      --   "Concept",
-      --
-      --   [ (dirtyId vd, PopAlphaNumeric . tshow . vdcpt $ vd)
-      --     | vd :: ViewDef <- instanceList fSpec,
-      --       vdIsDefault vd
-      --   ]
-      -- ),
-      -- ( "vdhtml",
-      --   "View",
-      --   "Concept",
-      --
-      --   [ (dirtyId vd, PopAlphaNumeric . tshow $ html)
-      --     | vd :: ViewDef <- instanceList fSpec,
-      --       Just html <- [vdhtml vd]
-      --   ]
-      -- ),
-      -- ( "vdIsDefault",
-      --   "View",
-      --   "Concept",
-      --
-      --   [ (dirtyId vd, PopAlphaNumeric . tshow . vdcpt $ vd)
-      --     | vd :: ViewDef <- instanceList fSpec
-      --   ]
-      -- ),
-      -- ( "vdpos",
-      --   "View",
-      --   "Origin",
-      --
-      --   [ (dirtyId vd, popatom)
-      --     | vd :: ViewDef <- instanceList fSpec,
-      --       Just popatom <- [originToPopAtom vd]
-      --   ]
-      -- ),
       ( "versionInfo",
         "Context",
         "AmpersandVersion",
         [ (dirtyId ctx, PopAlphaNumeric (longVersion appVersion))
           | ctx :: A_Context <- instanceList fSpec
         ]
       ),
-      --      ( "viewBy",
-      --        "Concept",
-      --        "Concept",
-      --
-      --        [] --TODO
-      --      ),
       ( "violatable",
         "Interface",
         "Rule",
@@ -1024,11 +913,6 @@ dirtyIdWithoutType :: (Unique a) => a -> PopAtom
 dirtyIdWithoutType = DirtyId . idWithoutType
 
 -- | The following transformers provide the metamodel needed to run a prototype.
---   Note: The information in transformersPrototypeContext is fully contained in FormalAmpersand.
---   You might do this by dropping all prefixes "PF_" and "pf_" and doing
---   the following transformation:
---     label[Role*PF_Label]                -> name[Role*RoleName]
---   Then you will see that the transformers defined here are a subset of the FormalAmpersand transformers.
 transformersPrototypeContext :: FSpec -> [Transformer]
 transformersPrototypeContext fSpec =
   map