From 290ef6c2ce432a3d5233ad590e0985cecfd6fc61 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Fri, 31 May 2024 15:37:54 +0200 Subject: [PATCH 01/11] Retrieve fix for DateTime parser --- src/Ampersand/Input/ADL1/Lexer.hs | 99 +------------------------------ 1 file changed, 1 insertion(+), 98 deletions(-) diff --git a/src/Ampersand/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index 057bbd012..b0d1dfc2b 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -315,104 +315,7 @@ lexMarkup = lexMarkup' "" ----------------------------------------------------------- -- Returns tuple with the parsed lexeme, the UTCTime, the amount of read characters and the rest of the text getDateTime :: String -> Maybe (Either LexerErrorInfo (Lexeme, UTCTime, Int, String)) -getDateTime cs = - case getDate cs of - Nothing -> Nothing - Just (_, day, ld, rd) -> - case getTime rd of - Nothing -> case rd of - 'T' : _ -> Just . Left $ ProblematicISO8601DateTime - _ -> getDateTime' cs -- Here we try the ohter notation of time - Just (timeOfDay, tzoneOffset, lt, rt) -> - let ucttime = addUTCTime tzoneOffset (UTCTime day timeOfDay) - in Just - . Right - $ ( LexDateTime ucttime, - ucttime, - ld + lt, - rt - ) - -getTime :: String -> Maybe (DiffTime, NominalDiffTime, Int, String) -getTime cs = - case cs of - 'T' : h1 : h2 : ':' : m1 : m2 : rest -> - if all isDigit [h1, h2, m1, m2] - then - let hours = case getNumber [h1, h2] of - (_, Left val, _, _) -> val - _ -> fatal "Impossible, for h1 and h2 are digits" - minutes = case getNumber [m1, m2] of - (_, Left val, _, _) -> val - _ -> fatal "Impossible, for m1 and m2 are digits" - (seconds, ls, rs) = getSeconds rest - in case getTZD rs of - Nothing -> Nothing - Just (offset, lo, ro) -> - if hours < 24 && minutes < 60 && seconds < 60 - then - Just - ( fromRational - . toRational - $ ( fromIntegral hours - * 60 - + fromIntegral minutes - ) - * 60 - + seconds, - offset, - 1 + 5 + ls + lo, - ro - ) - else Nothing - else Nothing - _ -> Nothing - -getSeconds :: String -> (Float, Int, String) -getSeconds cs = - case cs of - (':' : s1 : s2 : rest) -> - if all isDigit [s1, s2] - then - let (fraction, lf, rf) = getFraction (s1 : s2 : rest) - in (fraction, 1 + lf, rf) - else (0, 0, cs) - _ -> (0, 0, cs) - -getFraction :: String -> (Float, Int, String) -getFraction cs = - case readFloat cs of - [(a, str)] -> (a, length cs - length str, str) -- TODO: Make more efficient. - _ -> (0, 0, cs) - -getTZD :: String -> Maybe (NominalDiffTime, Int, String) -getTZD cs = - case cs of - 'Z' : rest -> Just (0, 1, rest) - '+' : h1 : h2 : ':' : m1 : m2 : rest -> mkOffset [h1, h2] [m1, m2] rest (+) - '-' : h1 : h2 : ':' : m1 : m2 : rest -> mkOffset [h1, h2] [m1, m2] rest (-) - _ -> Nothing - where - mkOffset :: String -> String -> String -> (Int -> Int -> Int) -> Maybe (NominalDiffTime, Int, String) - mkOffset hs ms rest op = - let hours = case getNumber hs of - (_, Left val, _, _) -> val - _ -> fatal "Impossible, for h1 and h2 are digits" - minutes = case getNumber ms of - (_, Left val, _, _) -> val - _ -> fatal "Impossible, for m1 and m2 are digits" - total = hours * 60 + minutes - in if hours <= 24 && minutes < 60 - then - Just - ( fromRational . toRational $ 0 `op` total, - 6, - rest - ) - else Nothing - -getDateTime' :: String -> Maybe (Either LexerErrorInfo (Lexeme, UTCTime, Int, String)) -getDateTime' cs = case readUniversalTime cs of +getDateTime cs = case readUniversalTime cs of Nothing -> Nothing Just (time, rest) -> Just . Right $ (LexDateTime time, time, length cs - length rest, rest) where From c90ed6d8f1c73e9e15fa0ecc4965853ced434f6c Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 1 Jun 2024 09:12:37 +0200 Subject: [PATCH 02/11] Revert "Retrieve fix for DateTime parser" This reverts commit 290ef6c2ce432a3d5233ad590e0985cecfd6fc61. --- src/Ampersand/Input/ADL1/Lexer.hs | 99 ++++++++++++++++++++++++++++++- 1 file changed, 98 insertions(+), 1 deletion(-) diff --git a/src/Ampersand/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index b0d1dfc2b..057bbd012 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -315,7 +315,104 @@ lexMarkup = lexMarkup' "" ----------------------------------------------------------- -- Returns tuple with the parsed lexeme, the UTCTime, the amount of read characters and the rest of the text getDateTime :: String -> Maybe (Either LexerErrorInfo (Lexeme, UTCTime, Int, String)) -getDateTime cs = case readUniversalTime cs of +getDateTime cs = + case getDate cs of + Nothing -> Nothing + Just (_, day, ld, rd) -> + case getTime rd of + Nothing -> case rd of + 'T' : _ -> Just . Left $ ProblematicISO8601DateTime + _ -> getDateTime' cs -- Here we try the ohter notation of time + Just (timeOfDay, tzoneOffset, lt, rt) -> + let ucttime = addUTCTime tzoneOffset (UTCTime day timeOfDay) + in Just + . Right + $ ( LexDateTime ucttime, + ucttime, + ld + lt, + rt + ) + +getTime :: String -> Maybe (DiffTime, NominalDiffTime, Int, String) +getTime cs = + case cs of + 'T' : h1 : h2 : ':' : m1 : m2 : rest -> + if all isDigit [h1, h2, m1, m2] + then + let hours = case getNumber [h1, h2] of + (_, Left val, _, _) -> val + _ -> fatal "Impossible, for h1 and h2 are digits" + minutes = case getNumber [m1, m2] of + (_, Left val, _, _) -> val + _ -> fatal "Impossible, for m1 and m2 are digits" + (seconds, ls, rs) = getSeconds rest + in case getTZD rs of + Nothing -> Nothing + Just (offset, lo, ro) -> + if hours < 24 && minutes < 60 && seconds < 60 + then + Just + ( fromRational + . toRational + $ ( fromIntegral hours + * 60 + + fromIntegral minutes + ) + * 60 + + seconds, + offset, + 1 + 5 + ls + lo, + ro + ) + else Nothing + else Nothing + _ -> Nothing + +getSeconds :: String -> (Float, Int, String) +getSeconds cs = + case cs of + (':' : s1 : s2 : rest) -> + if all isDigit [s1, s2] + then + let (fraction, lf, rf) = getFraction (s1 : s2 : rest) + in (fraction, 1 + lf, rf) + else (0, 0, cs) + _ -> (0, 0, cs) + +getFraction :: String -> (Float, Int, String) +getFraction cs = + case readFloat cs of + [(a, str)] -> (a, length cs - length str, str) -- TODO: Make more efficient. + _ -> (0, 0, cs) + +getTZD :: String -> Maybe (NominalDiffTime, Int, String) +getTZD cs = + case cs of + 'Z' : rest -> Just (0, 1, rest) + '+' : h1 : h2 : ':' : m1 : m2 : rest -> mkOffset [h1, h2] [m1, m2] rest (+) + '-' : h1 : h2 : ':' : m1 : m2 : rest -> mkOffset [h1, h2] [m1, m2] rest (-) + _ -> Nothing + where + mkOffset :: String -> String -> String -> (Int -> Int -> Int) -> Maybe (NominalDiffTime, Int, String) + mkOffset hs ms rest op = + let hours = case getNumber hs of + (_, Left val, _, _) -> val + _ -> fatal "Impossible, for h1 and h2 are digits" + minutes = case getNumber ms of + (_, Left val, _, _) -> val + _ -> fatal "Impossible, for m1 and m2 are digits" + total = hours * 60 + minutes + in if hours <= 24 && minutes < 60 + then + Just + ( fromRational . toRational $ 0 `op` total, + 6, + rest + ) + else Nothing + +getDateTime' :: String -> Maybe (Either LexerErrorInfo (Lexeme, UTCTime, Int, String)) +getDateTime' cs = case readUniversalTime cs of Nothing -> Nothing Just (time, rest) -> Just . Right $ (LexDateTime time, time, length cs - length rest, rest) where From cbc8addb58818a6a27369ae3039f39a7b1ab097a Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 1 Jun 2024 09:19:39 +0200 Subject: [PATCH 03/11] Also read ' UTC' after datetime if present --- src/Ampersand/Basics/Languages.hs | 2 +- src/Ampersand/Input/ADL1/Lexer.hs | 36 +++++++++++++------------------ 2 files changed, 16 insertions(+), 22 deletions(-) diff --git a/src/Ampersand/Basics/Languages.hs b/src/Ampersand/Basics/Languages.hs index ae7377d60..c2e6f970a 100644 --- 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/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index 057bbd012..e689641c9 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -318,20 +318,13 @@ getDateTime :: String -> Maybe (Either LexerErrorInfo (Lexeme, UTCTime, Int, Str getDateTime cs = case getDate cs of Nothing -> Nothing - Just (_, day, ld, rd) -> - case getTime rd of - Nothing -> case rd of - 'T' : _ -> Just . Left $ ProblematicISO8601DateTime - _ -> getDateTime' cs -- Here we try the ohter notation of time - Just (timeOfDay, tzoneOffset, lt, rt) -> - let ucttime = addUTCTime tzoneOffset (UTCTime day timeOfDay) - in Just - . Right - $ ( LexDateTime ucttime, - ucttime, - ld + lt, - rt - ) + Just (_, day, ld, rd) -> case getTime rd of + Nothing -> case rd of + 'T' : _ -> Just . Left $ ProblematicISO8601DateTime + _ -> getDateTime' cs -- Here we try the ohter notation of time + Just (timeOfDay, tzoneOffset, lt, rt) -> + let ucttime = addUTCTime tzoneOffset (UTCTime day timeOfDay) + in Just . Right $ (LexDateTime ucttime, ucttime, ld + lt, rt) getTime :: String -> Maybe (DiffTime, NominalDiffTime, Int, String) getTime cs = @@ -386,12 +379,11 @@ getFraction cs = _ -> (0, 0, cs) getTZD :: String -> Maybe (NominalDiffTime, Int, String) -getTZD cs = - case cs of - 'Z' : rest -> Just (0, 1, rest) - '+' : h1 : h2 : ':' : m1 : m2 : rest -> mkOffset [h1, h2] [m1, m2] rest (+) - '-' : h1 : h2 : ':' : m1 : m2 : rest -> mkOffset [h1, h2] [m1, m2] rest (-) - _ -> Nothing +getTZD cs = case cs of + 'Z' : rest -> Just (0, 1, rest) + '+' : h1 : h2 : ':' : m1 : m2 : rest -> mkOffset [h1, h2] [m1, m2] rest (+) + '-' : h1 : h2 : ':' : m1 : m2 : rest -> mkOffset [h1, h2] [m1, m2] rest (-) + _ -> Nothing where mkOffset :: String -> String -> String -> (Int -> Int -> Int) -> Maybe (NominalDiffTime, Int, String) mkOffset hs ms rest op = @@ -421,7 +413,9 @@ getDateTime' cs = case readUniversalTime cs of best :: [(UTCTime, String)] -> Maybe (UTCTime, String) best candidates = case reverse . L.sortBy myOrdering $ candidates of [] -> Nothing - (h : _) -> Just h + ((tim, rst) : _) -> case rst of + ' ' : 'U' : 'T' : 'C' : x -> Just (tim, x) + _ -> Just (tim, rst) myOrdering :: (Show a) => (a, b) -> (a, b) -> Ordering myOrdering (x, _) (y, _) = compare (length . show $ x) (length . show $ y) From badddcdc8cfb90e9cd375039ba91859b6deb2f53 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 1 Jun 2024 10:11:33 +0200 Subject: [PATCH 04/11] Small fix for Windows --- src/Ampersand/Daemon/Terminal.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Ampersand/Daemon/Terminal.hs b/src/Ampersand/Daemon/Terminal.hs index b28e9e501..43c5d3619 100644 --- 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 = 0x007F +-- wM_SETICON, 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 From 533cc2ed760cde3360c3b4acd4f09c603a7ee95c Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 1 Jun 2024 10:18:19 +0200 Subject: [PATCH 05/11] Fix Dockerfile --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 1469f6dc5..2210fa5de 100644 --- 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 From 7f42788b4925b7ba05142a200c38fd82318610ad Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 1 Jun 2024 10:21:08 +0200 Subject: [PATCH 06/11] Minor thing for windows --- src/Ampersand/Daemon/Terminal.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Ampersand/Daemon/Terminal.hs b/src/Ampersand/Daemon/Terminal.hs index 43c5d3619..2a7882544 100644 --- a/src/Ampersand/Daemon/Terminal.hs +++ b/src/Ampersand/Daemon/Terminal.hs @@ -18,9 +18,9 @@ import Graphics.Win32.GDI.Types import System.Win32.Types --- wM_SETICON, wM_GETICON :: WindowMessage +wM_GETICON :: WindowMessage -- wM_SETICON = 0x0080 --- wM_GETICON = 0x007F +wM_GETICON = 0x007F -- iCON_BIG, iCON_SMALL :: WPARAM -- iCON_BIG = 1 From 9b67e898610bad933713aaf11eb81cde2e8247ac Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 1 Jun 2024 16:25:33 +0200 Subject: [PATCH 07/11] Minor enhancement of Setup.hs --- Setup.hs | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/Setup.hs b/Setup.hs index a630acfe0..c87286bba 100644 --- 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" From 5afbdd834cf608c56d5ed09e9b7e0bf871642404 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Sat, 1 Jun 2024 23:46:29 +0200 Subject: [PATCH 08/11] minor things to ease comming migration --- src/Ampersand/Core/AbstractSyntaxTree.hs | 7 +- src/Ampersand/FSpec/Crud.hs | 35 +++---- src/Ampersand/FSpec/Transformers.hs | 115 ----------------------- 3 files changed, 22 insertions(+), 135 deletions(-) diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs index 81c5d6f5d..e59dd3761 100644 --- 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/FSpec/Crud.hs b/src/Ampersand/FSpec/Crud.hs index 799ca90bf..af826a98e 100644 --- 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/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs index 91079af75..135418d23 100644 --- a/src/Ampersand/FSpec/Transformers.hs +++ b/src/Ampersand/FSpec/Transformers.hs @@ -567,14 +567,6 @@ transformersFormalAmpersand fSpec = | ifc :: Interface <- instanceList fSpec ] ), - -- ( "name", - -- "ObjectDef", - -- "ObjectName", - -- - -- [ (dirtyId obj, (PopAlphaNumeric . name) obj) - -- | obj :: ObjectDef <- instanceList fSpec - -- ] - -- ), ( "name", "Pattern", "PatternName", @@ -731,40 +723,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 +747,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,50 +895,6 @@ 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", @@ -1006,12 +902,6 @@ transformersFormalAmpersand fSpec = | ctx :: A_Context <- instanceList fSpec ] ), - -- ( "viewBy", - -- "Concept", - -- "Concept", - -- - -- [] --TODO - -- ), ( "violatable", "Interface", "Rule", @@ -1024,11 +914,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 From 87e93de65e919cc2ce3675ea147b3c3bbf173a0b Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Tue, 4 Jun 2024 10:58:20 +0200 Subject: [PATCH 09/11] Population still yealds violations --- AmpersandData/FormalAmpersand/Documentation.adl | 1 + src/Ampersand/FSpec/Transformers.hs | 15 +++++++-------- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/AmpersandData/FormalAmpersand/Documentation.adl b/AmpersandData/FormalAmpersand/Documentation.adl index 26f71a4c2..dc5e444a4 100644 --- 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/src/Ampersand/FSpec/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs index 135418d23..0b8d7b4f5 100644 --- 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", From 4599950cbd69670b761c66fb55a5e3a3c682bef1 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Mon, 10 Jun 2024 21:38:46 +0200 Subject: [PATCH 10/11] Fix population of Meaning --- src/Ampersand/FSpec/Instances.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Ampersand/FSpec/Instances.hs b/src/Ampersand/FSpec/Instances.hs index faa344671..4b06660be 100644 --- 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 \ No newline at end of file From a77057e3ea33fda486cf08fb687fd4fe544f2053 Mon Sep 17 00:00:00 2001 From: hanjoosten Date: Tue, 18 Jun 2024 10:56:55 +0200 Subject: [PATCH 11/11] Add ShowAdl for PairView --- AmpersandData/FormalAmpersand/Generics.adl | 2 +- src/Ampersand/Core/A2P_Converters.hs | 1 + src/Ampersand/Core/ShowAStruct.hs | 7 +++++++ src/Ampersand/FSpec/Transformers.hs | 7 +++++++ 4 files changed, 16 insertions(+), 1 deletion(-) diff --git a/AmpersandData/FormalAmpersand/Generics.adl b/AmpersandData/FormalAmpersand/Generics.adl index 8ecd3b00d..e0386965c 100644 --- a/AmpersandData/FormalAmpersand/Generics.adl +++ b/AmpersandData/FormalAmpersand/Generics.adl @@ -30,7 +30,7 @@ RELATION srcOrTgt[PairViewSegment*SourceOrTarget] [UNI] -- 'Src' or 'Tgt'. -- IF -- Unneccessary for the Atlas: RELATION expSQL[PairViewSegment*MySQLQuery] [UNI] -- IFF SegmentType == 'Exp' RELATION pvsExp[PairViewSegment*Term] [UNI] - +RELATION showADL[PairView*ShowADL] [UNI,TOT] -- Temporary relation to enable first attempt to make the atlas editable. --[Conjuncts]-- RELATION allConjuncts[Context*Conjunct] [INJ] diff --git a/src/Ampersand/Core/A2P_Converters.hs b/src/Ampersand/Core/A2P_Converters.hs index 2a11efe23..9399aba1e 100644 --- a/src/Ampersand/Core/A2P_Converters.hs +++ b/src/Ampersand/Core/A2P_Converters.hs @@ -18,6 +18,7 @@ module Ampersand.Core.A2P_Converters aPattern2pPattern, aRoleRule2pRoleRule, aInterface2pInterface, + aPairView2pPairView, ) where diff --git a/src/Ampersand/Core/ShowAStruct.hs b/src/Ampersand/Core/ShowAStruct.hs index b4ba7bc80..299b1b5e5 100644 --- a/src/Ampersand/Core/ShowAStruct.hs +++ b/src/Ampersand/Core/ShowAStruct.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + module Ampersand.Core.ShowAStruct (AStruct (..)) where import Ampersand.Basics @@ -23,6 +27,9 @@ instance AStruct AClassify where instance AStruct Rule where showA = showP . aRule2pRule +instance AStruct (PairView Expression) where + showA = showP . aPairView2pPairView + instance AStruct Relation where showA = showP . aRelation2pRelation diff --git a/src/Ampersand/FSpec/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs index 0b8d7b4f5..77e92676b 100644 --- a/src/Ampersand/FSpec/Transformers.hs +++ b/src/Ampersand/FSpec/Transformers.hs @@ -1711,6 +1711,13 @@ tmpNewTransformerDefsFA fSpec = | rel :: Relation <- instanceList fSpec, mean <- decMean rel ] + ), + ( "showADL", + "PairView", + "ShowADL", + [ (dirtyId pv, PopAlphaNumeric (showA pv)) + | pv :: PairView Expression <- instanceList fSpec + ] ) ]