From 22e9c3b7f4e25b13c785a2b5d32b899dfd8146b3 Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Fri, 10 Aug 2018 11:08:15 +0200 Subject: [PATCH 001/131] Remove case expression that reduces to identity. --- src/Ampersand/Input/ADL1/Lexer.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Ampersand/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index e572fb7f52..6c517a16f8 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -89,9 +89,7 @@ lexer :: [Options] -- ^ The command line options -> FilePath -- ^ The file name, used for error messages -> String -- ^ The content of the file -> Either LexerError ([Token], [LexerWarning]) -- ^ Either an error or a list of tokens and warnings -lexer opt file input = case runLexerMonad opt file (mainLexer (initPos file) input) of - Left err -> Left err - Right (ts, ws) -> Right (ts, ws) +lexer opt file input = runLexerMonad opt file (mainLexer (initPos file) input) ----------------------------------------------------------- -- Help functions From 0ff8f805cdf1d1a1e4b75dfc577d6506504408f8 Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Wed, 22 Aug 2018 11:20:00 +0200 Subject: [PATCH 002/131] Make haddock work with quick hack Haddock currently fails to run, failing on "haddock library 1.4.5" which is included by the current version of pandock. As far as my googling tells me, this would be fixed once we can upgrade to "haddock library 1.6.0". I've been told the hold-back is "pandock-crossref". A better fix would be to only exclude the problematic package from haddock, but I could not figure out if that is possible. --- stack.yaml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/stack.yaml b/stack.yaml index c5b0a15e07..d2f7425be9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -27,6 +27,9 @@ flags: {} # Extra package databases containing global packages extra-package-dbs: [] +build: + haddock-deps: false + # Control whether we use the GHC we find on the path # system-ghc: true From 0015e7363b712b46145429f27a6c145d0cc03006 Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Fri, 24 Aug 2018 11:35:04 +0200 Subject: [PATCH 003/131] Create basic framework for pre-processor. The parser is changed to read flags from an include (Read as an optional bracketed list). These options are propagated to a ParseCandidate, where previous options are merged in. (Currently merge just concatenates list. Will need to deal with turning off options later). Before we run the actual parser on a file, we run the preprocessor with the given options. Alternatively for performance, we could have the lexer do the pre-processing. --- ampersand.cabal | 1 + src/Ampersand/Input/ADL1/Parser.hs | 3 ++- src/Ampersand/Input/Parsing.hs | 30 ++++++++++++++++------------- src/Ampersand/Input/PreProcessor.hs | 13 +++++++++++++ 4 files changed, 33 insertions(+), 14 deletions(-) create mode 100644 src/Ampersand/Input/PreProcessor.hs diff --git a/ampersand.cabal b/ampersand.cabal index 377e15472f..d80b126f8e 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -133,6 +133,7 @@ library Ampersand.Input.ADL1.Parser, Ampersand.Input.ADL1.ParsingLib, Ampersand.Input.Parsing, + Ampersand.Input.PreProcessor, Ampersand.Input.Xslx.XLSX, Ampersand.Misc, Ampersand.Misc.Options, diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index 4accff5b79..79470441ca 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -93,13 +93,14 @@ data ContextElement = CMeta Meta | CPop P_Population | CIncl Include -- an INCLUDE statement -data Include = Include Origin FilePath +data Include = Include Origin FilePath [String] --- IncludeStatement ::= 'INCLUDE' String pIncludeStatement :: AmpParser Include pIncludeStatement = Include <$> currPos <* pKey "INCLUDE" <*> pString + <*> (pBrackets (pString `sepBy` pComma) <|> return []) --- LanguageRef ::= 'IN' ('DUTCH' | 'ENGLISH') pLanguageRef :: AmpParser Lang diff --git a/src/Ampersand/Input/Parsing.hs b/src/Ampersand/Input/Parsing.hs index 0dc6617f6f..398ad5c111 100644 --- a/src/Ampersand/Input/Parsing.hs +++ b/src/Ampersand/Input/Parsing.hs @@ -11,6 +11,7 @@ module Ampersand.Input.Parsing ( ) where import Ampersand.ADL1 +import Ampersand.Input.PreProcessor import Ampersand.Basics import Ampersand.Core.ParseTree (mkContextOfPopsOnly) import Ampersand.Input.ADL1.CtxError @@ -35,24 +36,23 @@ parseADL :: Options -- ^ The options given through the comman -> IO (Guarded P_Context) -- ^ The resulting context parseADL opts fp = do curDir <- getCurrentDirectory canonical <- canonicalizePath fp - parseThing opts (ParseCandidate (Just curDir) Nothing fp Nothing canonical) + parseThing opts (ParseCandidate (Just curDir) Nothing fp Nothing canonical []) parseMeta :: Options -> IO (Guarded P_Context) -parseMeta opts = parseThing opts (ParseCandidate Nothing (Just $ Origin "Formal Ampersand specification") "AST.adl" (Just FormalAmpersand) "AST.adl") +parseMeta opts = parseThing opts (ParseCandidate Nothing (Just $ Origin "Formal Ampersand specification") "AST.adl" (Just FormalAmpersand) "AST.adl" []) parseSystemContext :: Options -> IO (Guarded P_Context) -parseSystemContext opts = parseThing opts (ParseCandidate Nothing (Just $ Origin "Ampersand specific system context") "SystemContext.adl" (Just SystemContext) "SystemContext.adl") +parseSystemContext opts = parseThing opts (ParseCandidate Nothing (Just $ Origin "Ampersand specific system context") "SystemContext.adl" (Just SystemContext) "SystemContext.adl" []) parseThing :: Options -> ParseCandidate -> IO (Guarded P_Context) parseThing opts pc = whenCheckedIO (parseADLs opts [] [pc] ) $ \ctxts -> return $ Checked $ foldl1 mergeContexts ctxts - -- | Parses several ADL files parseADLs :: Options -- ^ The options given through the command line -> [ParseCandidate] -- ^ The list of files that have already been parsed - -> [ParseCandidate] -- ^ A list of files that still are to be parsed. + -> [ParseCandidate] -- ^ A list of files that still are to be parsed. -> IO (Guarded [P_Context]) -- ^ The resulting contexts parseADLs opts parsedFilePaths fpIncludes = case fpIncludes of @@ -70,6 +70,7 @@ data ParseCandidate = ParseCandidate , pcFilePath :: FilePath -- The absolute or relative filename as found in the INCLUDE statement , pcFileKind :: Maybe FileKind -- In case the file is included into ampersand.exe, its FileKind. , pcCanonical :: FilePath -- The canonicalized path of the candicate + , pcDefineds :: [PreProcDefine] } instance Eq ParseCandidate where a == b = pcFileKind a == pcFileKind b && pcCanonical a `equalFilePath` pcCanonical b @@ -108,19 +109,22 @@ parseSingleADL opts pc ; case mFileContents of Left err -> return $ mkErrorReadingINCLUDE (pcOrigin pc) filePath err Right fileContents -> - whenCheckedIO (return $ parseCtx filePath fileContents) $ \(ctxts, includes) -> - do parseCandidates <- mapM include2ParseCandidate includes - return (Checked (ctxts, parseCandidates)) + whenCheckedIO + (return $ parseCtx filePath $ preProcess fileContents $ pcDefineds pc) + $ \(ctxts, includes) -> + do parseCandidates <- mapM include2ParseCandidate includes + return (Checked (ctxts, parseCandidates)) } where include2ParseCandidate :: Include -> IO ParseCandidate - include2ParseCandidate (Include org str) = do + include2ParseCandidate (Include org str defs) = do let canonical = myNormalise ( takeDirectory filePath str ) - return ParseCandidate { pcBasePath = Just filePath - , pcOrigin = Just org - , pcFilePath = str - , pcFileKind = pcFileKind pc + return ParseCandidate { pcBasePath = Just filePath + , pcOrigin = Just org + , pcFilePath = str + , pcFileKind = pcFileKind pc , pcCanonical = canonical + , pcDefineds = pcDefineds pc ++ defs } myNormalise :: FilePath -> FilePath -- see http://neilmitchell.blogspot.nl/2015/10/filepaths-are-subtle-symlinks-are-hard.html why System.Filepath doesn't support reduction of x/foo/../bar into x/bar. diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs new file mode 100644 index 0000000000..3e5c24344c --- /dev/null +++ b/src/Ampersand/Input/PreProcessor.hs @@ -0,0 +1,13 @@ +module Ampersand.Input.PreProcessor ( + preProcess + , PreProcDefine +) where + +import GHC.Base +import Prelude +import Data.List + +type PreProcDefine = String + +preProcess :: String -> [PreProcDefine] -> String +preProcess x _ = x From 190748d3659c5698166f9de396e3715174c5a8ac Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Fri, 7 Sep 2018 09:56:11 +0200 Subject: [PATCH 004/131] First attempt at PreProcessor. Swapped arguments on PreProcess to make it point-free. Current parser implementation is very ugly, and might not work. Also, the Include statement as is takes values that are quoted as strings, this is not elegant. Moreover, it currently takes the arguments in 'real code' rather than in comments. This should be changed to retain backwards compatibility for code that uses the pre-processor. --- src/Ampersand/Input/Parsing.hs | 4 +- src/Ampersand/Input/PreProcessor.hs | 107 ++++++++++++++++++++++++++-- 2 files changed, 104 insertions(+), 7 deletions(-) diff --git a/src/Ampersand/Input/Parsing.hs b/src/Ampersand/Input/Parsing.hs index 398ad5c111..efc4e0d3f4 100644 --- a/src/Ampersand/Input/Parsing.hs +++ b/src/Ampersand/Input/Parsing.hs @@ -34,7 +34,7 @@ import Text.Parsec.Prim (runP) parseADL :: Options -- ^ The options given through the command line -> FilePath -- ^ The path of the file to be parsed, either absolute or relative to the current user's path -> IO (Guarded P_Context) -- ^ The resulting context -parseADL opts fp = do curDir <- getCurrentDirectory +parseADL opts fp = do curDir <- getCurrentDirectory canonical <- canonicalizePath fp parseThing opts (ParseCandidate (Just curDir) Nothing fp Nothing canonical []) @@ -110,7 +110,7 @@ parseSingleADL opts pc Left err -> return $ mkErrorReadingINCLUDE (pcOrigin pc) filePath err Right fileContents -> whenCheckedIO - (return $ parseCtx filePath $ preProcess fileContents $ pcDefineds pc) + (return $ parseCtx filePath $ (preProcess (pcDefineds pc) fileContents)) $ \(ctxts, includes) -> do parseCandidates <- mapM include2ParseCandidate includes return (Checked (ctxts, parseCandidates)) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index 3e5c24344c..412f8cb6ff 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -3,11 +3,108 @@ module Ampersand.Input.PreProcessor ( , PreProcDefine ) where -import GHC.Base -import Prelude -import Data.List +import Data.List +import Data.String +import Data.Char +import Data.Either +import Data.Maybe +import Prelude type PreProcDefine = String -preProcess :: String -> [PreProcDefine] -> String -preProcess x _ = x +preProcess :: [PreProcDefine] -> String -> String +preProcess defs = block2file defs True . file2block + +-- Run the full parser +file2block :: String -> Block +file2block = parseBlock . map parseLine . lines + +-- Turn a block back +block2file :: [PreProcDefine] -> Bool -> Block -> String +block2file defs shown = unlines . map (blockElem2string defs shown) + +-- Handle single entry in a block +blockElem2string :: [PreProcDefine] -> Bool -> BlockElem -> String +blockElem2string _ True (Left line) = line +blockElem2string _ False (Left line) = "-- hide by preprocc " ++ line +-- Lots of unpacking to get to the IfBlock +blockElem2string defs False (Right (IfBlock (Guard guard) block)) = + "-- IF " ++ guard ++ block2file defs False block ++ "-- ENDIF" +blockElem2string defs True (Right (IfBlock (Guard guard) block)) = + "-- IF " ++ guard ++ "\n" ++ + (block2file defs (guard `elem` defs) block) ++ + "\n-- ENDIF" + +-- Here the experimentation starts + +{- Our grammar is: +Codeline = Any line that is not IfStartLine or IfEndLine +Word = consecutive non-whitespace chars +String litterals are encased in pairs of ' +: is concatenation +| is disjunction +\ is negation + +IfStartLine = ' '* : '-- if ' : Word : ' '* : '\n' +IfEndLine = ' '* : '-- endif ' : ' '* : '\n' +CodeLine = Line \ (IfStartLine | IfEndLine) + +IfBlock = IfStartLine : Block : IfEndLine + +Block = (CodeLine | IfBlock)* + -} + +-- Do we want to implement the relevant strings + +-- "Implement" the grammar in Haskell Types +newtype Guard = Guard String + +type BlockElem = Either String IfBlock +type Block = [ BlockElem ] +data IfBlock = IfBlock Guard Block + +data Line = Codeline String + | IfStart Guard + | IfEnd + +-- First, define a function that reads our primitive 'line' + +-- It must be possible to do this nicer. Probably with something like <* and *> or <|> +parseLine :: String -> Line +parseLine line = case parseIfStartLine line of + Just guard -> IfStart guard + _ -> case parseIfEndLine line of + Just () -> IfEnd + _ -> Codeline line + +parseIfStartLine :: String -> Maybe Guard +parseIfStartLine x = fmap (Guard . head . words) (stripPrefix "-- IF " $ stripFront x) + +parseIfEndLine :: String -> Maybe () +parseIfEndLine x = fmap (const ()) (stripPrefix "-- ENDIF" $ stripFront x) + +-- Next, define a function that processes our data type [Line] + +-- Probably want something like: +-- parseBlock :: [Line] -> ( [Line] , Block ) +-- or +-- parseBlock :: [Line] -> ( Block, [Line] ) +parseBlock :: [Line] -> Block +parseBlock [] = [] +parseBlock (line:rest) = case line of + Codeline plainLine -> (Left plainLine) : parseBlock rest + IfStart guard -> let (blockLines, remainingLines) = break endsBlock rest in + (Right $ IfBlock guard $ parseBlock blockLines) : parseBlock remainingLines + IfEnd -> (Left "") : parseBlock rest + + + +-- Helper functions + +stripFront :: String -> String +stripFront = dropWhile isSpace + +-- there has to be a better way +endsBlock :: Line -> Bool +endsBlock IfEnd = True +endsBlock _ = False From 092550c72eb866ee9d07c2943b3bdc5a3af96ef0 Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Wed, 12 Sep 2018 14:51:43 +0200 Subject: [PATCH 005/131] Change syntax so PreProcessor directives are marked with #. This does not apply to the INCLUDE statement. Properly having the flags there behind a comment requires work on the parser I cannot do. --- src/Ampersand/Input/PreProcessor.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index 412f8cb6ff..128df246e8 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -29,11 +29,11 @@ blockElem2string _ True (Left line) = line blockElem2string _ False (Left line) = "-- hide by preprocc " ++ line -- Lots of unpacking to get to the IfBlock blockElem2string defs False (Right (IfBlock (Guard guard) block)) = - "-- IF " ++ guard ++ block2file defs False block ++ "-- ENDIF" + "-- IF " ++ guard ++ block2file defs False block ++ "-- #ENDIF" blockElem2string defs True (Right (IfBlock (Guard guard) block)) = - "-- IF " ++ guard ++ "\n" ++ + "-- #IF " ++ guard ++ "\n" ++ (block2file defs (guard `elem` defs) block) ++ - "\n-- ENDIF" + "\n-- #ENDIF" -- Here the experimentation starts @@ -78,10 +78,10 @@ parseLine line = case parseIfStartLine line of _ -> Codeline line parseIfStartLine :: String -> Maybe Guard -parseIfStartLine x = fmap (Guard . head . words) (stripPrefix "-- IF " $ stripFront x) +parseIfStartLine x = fmap (Guard . head . words) (stripPrefix "-- #IF " $ stripFront x) parseIfEndLine :: String -> Maybe () -parseIfEndLine x = fmap (const ()) (stripPrefix "-- ENDIF" $ stripFront x) +parseIfEndLine x = fmap (const ()) (stripPrefix "-- #ENDIF" $ stripFront x) -- Next, define a function that processes our data type [Line] From cd9a22b16bba99d00e5da08beee34b9c27bcc580 Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Wed, 12 Sep 2018 15:41:52 +0200 Subject: [PATCH 006/131] Change spacing for pre-processor directives. --- src/Ampersand/Input/PreProcessor.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index 128df246e8..f3a4867b2f 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -29,11 +29,11 @@ blockElem2string _ True (Left line) = line blockElem2string _ False (Left line) = "-- hide by preprocc " ++ line -- Lots of unpacking to get to the IfBlock blockElem2string defs False (Right (IfBlock (Guard guard) block)) = - "-- IF " ++ guard ++ block2file defs False block ++ "-- #ENDIF" + "--#IF " ++ guard ++ block2file defs False block ++ "--#ENDIF" blockElem2string defs True (Right (IfBlock (Guard guard) block)) = - "-- #IF " ++ guard ++ "\n" ++ + "--#IF " ++ guard ++ "\n" ++ (block2file defs (guard `elem` defs) block) ++ - "\n-- #ENDIF" + "\n--#ENDIF" -- Here the experimentation starts @@ -78,10 +78,10 @@ parseLine line = case parseIfStartLine line of _ -> Codeline line parseIfStartLine :: String -> Maybe Guard -parseIfStartLine x = fmap (Guard . head . words) (stripPrefix "-- #IF " $ stripFront x) +parseIfStartLine x = fmap (Guard . head . words) (stripPrefix "--#IF " $ stripFront x) parseIfEndLine :: String -> Maybe () -parseIfEndLine x = fmap (const ()) (stripPrefix "-- #ENDIF" $ stripFront x) +parseIfEndLine x = fmap (const ()) (stripPrefix "--#ENDIF" $ stripFront x) -- Next, define a function that processes our data type [Line] From 6d6acb4936baffa242730eb6ba2508948d8efb37 Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Thu, 13 Sep 2018 15:40:15 +0200 Subject: [PATCH 007/131] Add IfNot; refactor code; fix ENDIF line counting twice. parseLine now uses Alternative (not quite happy with it yet). BlockElem is now a proper data type, rather than an Either. Made an attempt at improving parseBlock. It feels like we are closer to something idiomatic, but for now it is not a clear improvement. --- src/Ampersand/Input/PreProcessor.hs | 122 +++++++++++++--------------- 1 file changed, 57 insertions(+), 65 deletions(-) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index f3a4867b2f..5fb4338ff9 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -6,9 +6,8 @@ module Ampersand.Input.PreProcessor ( import Data.List import Data.String import Data.Char -import Data.Either import Data.Maybe -import Prelude +import GHC.Base type PreProcDefine = String @@ -23,88 +22,81 @@ file2block = parseBlock . map parseLine . lines block2file :: [PreProcDefine] -> Bool -> Block -> String block2file defs shown = unlines . map (blockElem2string defs shown) --- Handle single entry in a block -blockElem2string :: [PreProcDefine] -> Bool -> BlockElem -> String -blockElem2string _ True (Left line) = line -blockElem2string _ False (Left line) = "-- hide by preprocc " ++ line --- Lots of unpacking to get to the IfBlock -blockElem2string defs False (Right (IfBlock (Guard guard) block)) = - "--#IF " ++ guard ++ block2file defs False block ++ "--#ENDIF" -blockElem2string defs True (Right (IfBlock (Guard guard) block)) = - "--#IF " ++ guard ++ "\n" ++ - (block2file defs (guard `elem` defs) block) ++ - "\n--#ENDIF" - --- Here the experimentation starts - -{- Our grammar is: -Codeline = Any line that is not IfStartLine or IfEndLine -Word = consecutive non-whitespace chars -String litterals are encased in pairs of ' -: is concatenation -| is disjunction -\ is negation - -IfStartLine = ' '* : '-- if ' : Word : ' '* : '\n' -IfEndLine = ' '* : '-- endif ' : ' '* : '\n' -CodeLine = Line \ (IfStartLine | IfEndLine) - -IfBlock = IfStartLine : Block : IfEndLine - -Block = (CodeLine | IfBlock)* - -} - --- Do we want to implement the relevant strings +-- Do we want to implement the relevant strings e.g. "--# IF" as constants? -- "Implement" the grammar in Haskell Types newtype Guard = Guard String -type BlockElem = Either String IfBlock +data BlockElem = LineElem String + | IfElem IfBlock + | IfNotElem NotIfBlock + type Block = [ BlockElem ] -data IfBlock = IfBlock Guard Block + +data IfBlock = IfBlock Guard Block +data NotIfBlock = IfNotBlock Guard Block data Line = Codeline String + | IfNotStart Guard | IfStart Guard | IfEnd -- First, define a function that reads our primitive 'line' --- It must be possible to do this nicer. Probably with something like <* and *> or <|> +-- We now do (f x) <|> (g x), would be nicer to have (f <|> g) x +-- would require <|> :: (a -> Maybe b) -> (a -> Maybe b) -> (a -> Maybe b) +-- Monad >=> comes close but not quite parseLine :: String -> Line -parseLine line = case parseIfStartLine line of - Just guard -> IfStart guard - _ -> case parseIfEndLine line of - Just () -> IfEnd - _ -> Codeline line - -parseIfStartLine :: String -> Maybe Guard -parseIfStartLine x = fmap (Guard . head . words) (stripPrefix "--#IF " $ stripFront x) - -parseIfEndLine :: String -> Maybe () -parseIfEndLine x = fmap (const ()) (stripPrefix "--#ENDIF" $ stripFront x) +parseLine line = fromMaybe (Codeline line) $ (parseIfStartLine line + <|> parseNotIfStartLine line + <|> parseIfEndLine line) + +--f :: (a -> Maybe b) -> (a -> Maybe b) -> (a -> Maybe b) + +parseIfStartLine :: String -> Maybe Line +parseIfStartLine x = fmap (IfStart . Guard . head . words) (stripPrefix "--#IF " $ dropWhile isSpace x) + +parseNotIfStartLine :: String -> Maybe Line +parseNotIfStartLine x = fmap (IfNotStart . Guard . head . words) (stripPrefix "--#IFNOT " $ dropWhile isSpace x) + +parseIfEndLine :: String -> Maybe Line +parseIfEndLine x = fmap (const IfEnd) (stripPrefix "--#ENDIF" $ dropWhile isSpace x) -- Next, define a function that processes our data type [Line] --- Probably want something like: --- parseBlock :: [Line] -> ( [Line] , Block ) --- or --- parseBlock :: [Line] -> ( Block, [Line] ) +-- Use blockParser to turn a list of lines into a list of BlockElem +-- Note that blockParser could consume more than one line +-- Fold after build? parseBlock :: [Line] -> Block parseBlock [] = [] -parseBlock (line:rest) = case line of - Codeline plainLine -> (Left plainLine) : parseBlock rest - IfStart guard -> let (blockLines, remainingLines) = break endsBlock rest in - (Right $ IfBlock guard $ parseBlock blockLines) : parseBlock remainingLines - IfEnd -> (Left "") : parseBlock rest +parseBlock lineList = (\(x, y) -> y ++ parseBlock x) . blockParser $ lineList +blockParser :: [Line] -> ([Line], [BlockElem] ) +blockParser [] = ([], []) +blockParser (line:rest) = case line of + Codeline plainLine -> (rest, [LineElem plainLine]) + IfStart guard -> let (blockLines, remainingLines) = break endsIfBlock rest in + ( remainingLines, [IfElem $ IfBlock guard (parseBlock blockLines)] ) + IfNotStart guard -> let (blockLines, remainingLines) = break endsIfBlock rest in + ( remainingLines, [IfNotElem $ IfNotBlock guard (parseBlock blockLines)] ) + IfEnd -> (rest, [LineElem "--#ENDIF"] ) - --- Helper functions +endsIfBlock :: Line -> Bool +endsIfBlock IfEnd = True +endsIfBlock _ = False -stripFront :: String -> String -stripFront = dropWhile isSpace --- there has to be a better way -endsBlock :: Line -> Bool -endsBlock IfEnd = True -endsBlock _ = False + +-- Handle single entry in a block +-- list of flags Showing this element? 2 process output +blockElem2string :: [PreProcDefine] -> Bool -> BlockElem -> String +blockElem2string _ True (LineElem line) = line +blockElem2string _ False (LineElem line) = "--#hiden by preprocc " ++ line +-- Lots of unpacking to get to the IfBlock +blockElem2string defs hiding (IfElem (IfBlock (Guard guard) block)) = + "--#IF " ++ guard ++ "\n" ++ + (block2file defs (hiding && (guard `elem` defs)) block) + +blockElem2string defs hiding (IfNotElem (IfNotBlock (Guard guard) block)) = + "--#IFNOT " ++ guard ++ "\n" ++ + (block2file defs (hiding && not (guard `elem` defs)) block) From ebd8aa9c9d1ce674ef28561104a9cb99ac8488a8 Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Thu, 20 Sep 2018 11:17:13 +0200 Subject: [PATCH 008/131] Create separate executable to run preprocessor. It did not seem easy to make a compiler flag, so I decided on a separate executable as a temporary measure. Not sure how to do this in the future. --- ampersand.cabal | 9 +++++++++ preProcApp/Main.hs | 11 +++++++++++ 2 files changed, 20 insertions(+) create mode 100644 preProcApp/Main.hs diff --git a/ampersand.cabal b/ampersand.cabal index 30379ab1a0..9bd51de486 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -190,6 +190,15 @@ executable ampersand default-extensions:NoImplicitPrelude build-depends: base == 4.10.*, ampersand + +executable ampPreProc + hs-source-dirs: preProcApp + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -Wall -threaded + default-extensions:NoImplicitPrelude + build-depends: base == 4.10.*, + ampersand Test-Suite regression-test type: exitcode-stdio-1.0 diff --git a/preProcApp/Main.hs b/preProcApp/Main.hs new file mode 100644 index 0000000000..186537e893 --- /dev/null +++ b/preProcApp/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Ampersand.Input.PreProcessor +import Ampersand.Basics.UTF8 + +main :: IO () +main = + do + filename:defs <- getArgs; + fileContents <- readUTF8File fileName; + return (preProcess defs fileContents); \ No newline at end of file From eed4651551cfc908cbf58b862902d9cd51d0a80b Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Thu, 20 Sep 2018 13:41:27 +0200 Subject: [PATCH 009/131] Fix issue of adding extra lines. We had inconsistent treatment of newlines. Note that now we always add an extraneous newline to the end of a file. --- src/Ampersand/Input/PreProcessor.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index 5fb4338ff9..0bfdde9567 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -20,7 +20,7 @@ file2block = parseBlock . map parseLine . lines -- Turn a block back block2file :: [PreProcDefine] -> Bool -> Block -> String -block2file defs shown = unlines . map (blockElem2string defs shown) +block2file defs shown = concat . map (blockElem2string defs shown) -- Do we want to implement the relevant strings e.g. "--# IF" as constants? @@ -79,7 +79,7 @@ blockParser (line:rest) = case line of ( remainingLines, [IfElem $ IfBlock guard (parseBlock blockLines)] ) IfNotStart guard -> let (blockLines, remainingLines) = break endsIfBlock rest in ( remainingLines, [IfNotElem $ IfNotBlock guard (parseBlock blockLines)] ) - IfEnd -> (rest, [LineElem "--#ENDIF"] ) + IfEnd -> (rest, [] ) endsIfBlock :: Line -> Bool endsIfBlock IfEnd = True @@ -88,15 +88,17 @@ endsIfBlock _ = False -- Handle single entry in a block +-- Responsible for adding newlines -- list of flags Showing this element? 2 process output blockElem2string :: [PreProcDefine] -> Bool -> BlockElem -> String -blockElem2string _ True (LineElem line) = line -blockElem2string _ False (LineElem line) = "--#hiden by preprocc " ++ line +blockElem2string _ True (LineElem line) = line ++ "\n" +blockElem2string _ False (LineElem line) = "--hiden by preprocc " ++ line ++ "\n" -- Lots of unpacking to get to the IfBlock blockElem2string defs hiding (IfElem (IfBlock (Guard guard) block)) = "--#IF " ++ guard ++ "\n" ++ - (block2file defs (hiding && (guard `elem` defs)) block) - + (block2file defs (hiding && (guard `elem` defs)) block) ++ + "--#ENDIF\n" blockElem2string defs hiding (IfNotElem (IfNotBlock (Guard guard) block)) = "--#IFNOT " ++ guard ++ "\n" ++ - (block2file defs (hiding && not (guard `elem` defs)) block) + (block2file defs (hiding && not (guard `elem` defs)) block) ++ + "--#ENDIF\n" From 825bcc09f0fbbc760231a964472c6b1feadce1a9 Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Thu, 20 Sep 2018 16:29:22 +0200 Subject: [PATCH 010/131] Change preprocessor to use Parsec. Technically, the lexer could also be replaced, but the current version seems fine. Perhaps if we want more flexibility in the commands, or want to retain comments that are after the guard in the output. The function turning a block back into a (partially commented) string could probably also be replaced by a stateful parser. Not at all necessary though. Finally, we should return something like Either ParseError String from preProcess so we can propagate parsing errors rather than crashing. --- preProcApp/Main.hs | 9 +- src/Ampersand/Input/PreProcessor.hs | 175 +++++++++++++++++----------- 2 files changed, 113 insertions(+), 71 deletions(-) diff --git a/preProcApp/Main.hs b/preProcApp/Main.hs index 186537e893..fad7202ccf 100644 --- a/preProcApp/Main.hs +++ b/preProcApp/Main.hs @@ -1,11 +1,14 @@ module Main where +import Ampersand +import System.Environment import Ampersand.Input.PreProcessor -import Ampersand.Basics.UTF8 +import Ampersand.Basics.UTF8 (readUTF8File) main :: IO () main = do filename:defs <- getArgs; - fileContents <- readUTF8File fileName; - return (preProcess defs fileContents); \ No newline at end of file + input <- readUTF8File filename + inputString <- return $ either id id input + putStr $ preProcess defs inputString ++ "\n" diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index 0bfdde9567..8a02e50da4 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -7,85 +7,124 @@ import Data.List import Data.String import Data.Char import Data.Maybe -import GHC.Base +import Data.Bool +import Data.Either +import Data.Functor +import Control.Monad hiding (guard) +import Control.Applicative hiding ( many ) +import Text.Parsec hiding ( (<|>) ) +import Prelude type PreProcDefine = String preProcess :: [PreProcDefine] -> String -> String -preProcess defs = block2file defs True . file2block +preProcess defs = block2file defs True . (either (error . show) id) <$> file2block "" --- Run the full parser -file2block :: String -> Block -file2block = parseBlock . map parseLine . lines +-- Run the parser +file2block :: String -> String -> Either ParseError Block +file2block fileName = parseFile fileName . map lexLine . lines + +-- LEXER +data LexLine = Codeline String + | IfNotStart Guard + | IfStart Guard + | IfEnd +instance Show LexLine where + show = showLex + +showLex :: LexLine -> String +showLex (Codeline x) = x +showLex (IfNotStart x) = "If Not " ++ guard x +showLex (IfStart x) = "If " ++ guard x +showLex (IfEnd) = "End If" + +parseIfStartLine :: String -> Maybe LexLine +parseIfStartLine x = fmap (IfStart . Guard . head . words) (stripPrefix "--#IF " $ dropWhile isSpace x) --- Turn a block back -block2file :: [PreProcDefine] -> Bool -> Block -> String -block2file defs shown = concat . map (blockElem2string defs shown) +parseNotIfStartLine :: String -> Maybe LexLine +parseNotIfStartLine x = fmap (IfNotStart . Guard . head . words) (stripPrefix "--#IFNOT " $ dropWhile isSpace x) --- Do we want to implement the relevant strings e.g. "--# IF" as constants? +parseIfEndLine :: String -> Maybe LexLine +parseIfEndLine x = fmap (const IfEnd) (stripPrefix "--#ENDIF" $ dropWhile isSpace x) --- "Implement" the grammar in Haskell Types +lexLine :: String -> LexLine +lexLine line = fromMaybe (Codeline line) $ (parseIfStartLine line + <|> parseNotIfStartLine line + <|> parseIfEndLine line) + +-- PARSER newtype Guard = Guard String +guard :: Guard -> String +guard (Guard x) = x data BlockElem = LineElem String | IfElem IfBlock - | IfNotElem NotIfBlock + | IfNotElem IfNotBlock type Block = [ BlockElem ] data IfBlock = IfBlock Guard Block -data NotIfBlock = IfNotBlock Guard Block - -data Line = Codeline String - | IfNotStart Guard - | IfStart Guard - | IfEnd - --- First, define a function that reads our primitive 'line' - --- We now do (f x) <|> (g x), would be nicer to have (f <|> g) x --- would require <|> :: (a -> Maybe b) -> (a -> Maybe b) -> (a -> Maybe b) --- Monad >=> comes close but not quite -parseLine :: String -> Line -parseLine line = fromMaybe (Codeline line) $ (parseIfStartLine line - <|> parseNotIfStartLine line - <|> parseIfEndLine line) - ---f :: (a -> Maybe b) -> (a -> Maybe b) -> (a -> Maybe b) - -parseIfStartLine :: String -> Maybe Line -parseIfStartLine x = fmap (IfStart . Guard . head . words) (stripPrefix "--#IF " $ dropWhile isSpace x) - -parseNotIfStartLine :: String -> Maybe Line -parseNotIfStartLine x = fmap (IfNotStart . Guard . head . words) (stripPrefix "--#IFNOT " $ dropWhile isSpace x) - -parseIfEndLine :: String -> Maybe Line -parseIfEndLine x = fmap (const IfEnd) (stripPrefix "--#ENDIF" $ dropWhile isSpace x) - --- Next, define a function that processes our data type [Line] - --- Use blockParser to turn a list of lines into a list of BlockElem --- Note that blockParser could consume more than one line --- Fold after build? -parseBlock :: [Line] -> Block -parseBlock [] = [] -parseBlock lineList = (\(x, y) -> y ++ parseBlock x) . blockParser $ lineList - -blockParser :: [Line] -> ([Line], [BlockElem] ) -blockParser [] = ([], []) -blockParser (line:rest) = case line of - Codeline plainLine -> (rest, [LineElem plainLine]) - IfStart guard -> let (blockLines, remainingLines) = break endsIfBlock rest in - ( remainingLines, [IfElem $ IfBlock guard (parseBlock blockLines)] ) - IfNotStart guard -> let (blockLines, remainingLines) = break endsIfBlock rest in - ( remainingLines, [IfNotElem $ IfNotBlock guard (parseBlock blockLines)] ) - IfEnd -> (rest, [] ) - -endsIfBlock :: Line -> Bool -endsIfBlock IfEnd = True -endsIfBlock _ = False - +data IfNotBlock = IfNotBlock Guard Block + +type Parser a = Parsec [LexLine] () a + +myToken :: (LexLine -> Maybe a) -> Parser a +myToken constructor = tokenPrim showLex (\pos _ _ -> incSourceLine pos 1) constructor + +codeLine :: Parser BlockElem +codeLine = myToken ((fmap LineElem) <$> line2string) + where + line2string :: LexLine -> Maybe String + line2string (Codeline s) = Just s + line2string _ = Nothing + +ifStart :: Parser Guard +ifStart = myToken guard2string + where + guard2string (IfStart g) = Just g + guard2string _ = Nothing + +ifNotStart :: Parser Guard +ifNotStart = myToken guard2string + where + guard2string (IfNotStart g) = Just g + guard2string _ = Nothing + +ifEnd :: Parser () +ifEnd = myToken (matchIfEnd) + where + matchIfEnd IfEnd = Just () + matchIfEnd _ = Nothing + +ifBlock :: Parser IfBlock +ifBlock = do + guard' <- ifStart; + lines' <- many blockElem + _ <- ifEnd + return (IfBlock guard' lines') + +ifNotBlock :: Parser IfNotBlock +ifNotBlock = do + guard' <- ifNotStart; + lines' <- block + _ <- ifEnd + return (IfNotBlock guard' lines') + +blockElem :: Parser BlockElem +blockElem = choice [codeLine, IfElem <$> ifBlock, IfNotElem <$> ifNotBlock ] "a block element" + +block :: Parser Block +block = many blockElem + +parseFile :: String -> [LexLine] -> (Either ParseError Block) +parseFile fileName = parse (block <* eof) fileName + +-- Turn Blocks Back into text +-- Turn a block back +-- Could be done with a stateful monad where +block2file :: [PreProcDefine] -> Bool -> Block -> String +block2file defs shown = concat . map (blockElem2string defs shown) -- Handle single entry in a block -- Responsible for adding newlines @@ -94,11 +133,11 @@ blockElem2string :: [PreProcDefine] -> Bool -> BlockElem -> Strin blockElem2string _ True (LineElem line) = line ++ "\n" blockElem2string _ False (LineElem line) = "--hiden by preprocc " ++ line ++ "\n" -- Lots of unpacking to get to the IfBlock -blockElem2string defs hiding (IfElem (IfBlock (Guard guard) block)) = - "--#IF " ++ guard ++ "\n" ++ - (block2file defs (hiding && (guard `elem` defs)) block) ++ +blockElem2string defs showing (IfElem (IfBlock (Guard guard') block')) = + "--#IF " ++ guard' ++ "\n" ++ + (block2file defs (showing && (guard' `elem` defs)) block') ++ "--#ENDIF\n" -blockElem2string defs hiding (IfNotElem (IfNotBlock (Guard guard) block)) = - "--#IFNOT " ++ guard ++ "\n" ++ - (block2file defs (hiding && not (guard `elem` defs)) block) ++ +blockElem2string defs showing (IfNotElem (IfNotBlock (Guard guard') block')) = + "--#IFNOT " ++ guard' ++ "\n" ++ + (block2file defs (showing && not (guard' `elem` defs)) block') ++ "--#ENDIF\n" From 6ec72ff05abf5fbcdc979aadf59d9ce648d20e43 Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Fri, 21 Sep 2018 15:51:04 +0200 Subject: [PATCH 011/131] Make Lexer also use Parsec. This intentionally yields errors when one uses "--#" comments that aren't a preprocessor directive. --- src/Ampersand/Input/PreProcessor.hs | 100 ++++++++++++++++++---------- 1 file changed, 65 insertions(+), 35 deletions(-) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index 8a02e50da4..a94275b484 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -5,7 +5,6 @@ module Ampersand.Input.PreProcessor ( import Data.List import Data.String -import Data.Char import Data.Maybe import Data.Bool import Data.Either @@ -19,12 +18,16 @@ type PreProcDefine = String preProcess :: [PreProcDefine] -> String -> String preProcess defs = block2file defs True . (either (error . show) id) <$> file2block "" - + -- Run the parser file2block :: String -> String -> Either ParseError Block -file2block fileName = parseFile fileName . map lexLine . lines +file2block fileName = (parseLexedFile fileName) <=< (fullLexer fileName) -- LEXER + +type Lexer a = Parsec String () a + + data LexLine = Codeline String | IfNotStart Guard | IfStart Guard @@ -38,19 +41,46 @@ showLex (IfNotStart x) = "If Not " ++ guard x showLex (IfStart x) = "If " ++ guard x showLex (IfEnd) = "End If" -parseIfStartLine :: String -> Maybe LexLine -parseIfStartLine x = fmap (IfStart . Guard . head . words) (stripPrefix "--#IF " $ dropWhile isSpace x) +--preProcDirective :: Lexer () + + +whitespace :: Lexer () +whitespace = skipMany1 space + +ifWithGuard :: Lexer LexLine +ifWithGuard = (IfStart . Guard) <$> + (string "IF" *> + whitespace *> + some alphaNum <* + manyTill anyChar endOfLine + ) + +ifNotWithGuard :: Lexer LexLine +ifNotWithGuard = (IfNotStart . Guard) <$> + (string "IFNOT" *> + whitespace *> + some alphaNum <* + manyTill anyChar endOfLine + ) + +ifEnd :: Lexer LexLine +ifEnd = (const IfEnd) <$> + (string "ENDIF" *> + manyTill anyChar endOfLine + ) -parseNotIfStartLine :: String -> Maybe LexLine -parseNotIfStartLine x = fmap (IfNotStart . Guard . head . words) (stripPrefix "--#IFNOT " $ dropWhile isSpace x) +-- This fails without consuming input on comments, +-- but fails with consuming input (and message "preproccesor directive") +-- for comments starting with #. +preProcDirective :: Lexer LexLine +preProcDirective = try (spaces *> string "--") *> char '#' *> spaces *> + (ifWithGuard <|> ifNotWithGuard <|> ifEnd "preproccesor directive") -parseIfEndLine :: String -> Maybe LexLine -parseIfEndLine x = fmap (const IfEnd) (stripPrefix "--#ENDIF" $ dropWhile isSpace x) +lexLine :: Lexer LexLine +lexLine = preProcDirective <|> Codeline <$> manyTill anyChar endOfLine -lexLine :: String -> LexLine -lexLine line = fromMaybe (Codeline line) $ (parseIfStartLine line - <|> parseNotIfStartLine line - <|> parseIfEndLine line) +fullLexer :: String -> String -> Either ParseError [LexLine] +fullLexer filename = parse (many lexLine <* eof) filename -- PARSER newtype Guard = Guard String @@ -66,58 +96,58 @@ type Block = [ BlockElem ] data IfBlock = IfBlock Guard Block data IfNotBlock = IfNotBlock Guard Block -type Parser a = Parsec [LexLine] () a +type TokenParser a = Parsec [LexLine] () a -myToken :: (LexLine -> Maybe a) -> Parser a -myToken constructor = tokenPrim showLex (\pos _ _ -> incSourceLine pos 1) constructor +parserToken :: (LexLine -> Maybe a) -> TokenParser a +parserToken constructor = tokenPrim showLex (\pos _ _ -> incSourceLine pos 1) constructor -codeLine :: Parser BlockElem -codeLine = myToken ((fmap LineElem) <$> line2string) +lineElem :: TokenParser BlockElem +lineElem = parserToken ((fmap LineElem) <$> line2string) where line2string :: LexLine -> Maybe String line2string (Codeline s) = Just s line2string _ = Nothing -ifStart :: Parser Guard -ifStart = myToken guard2string +ifElemStart :: TokenParser Guard +ifElemStart = parserToken guard2string where guard2string (IfStart g) = Just g guard2string _ = Nothing -ifNotStart :: Parser Guard -ifNotStart = myToken guard2string +ifNotElemStart :: TokenParser Guard +ifNotElemStart = parserToken guard2string where guard2string (IfNotStart g) = Just g guard2string _ = Nothing -ifEnd :: Parser () -ifEnd = myToken (matchIfEnd) +ifElemEnd :: TokenParser () +ifElemEnd = parserToken (matchIfEnd) where matchIfEnd IfEnd = Just () matchIfEnd _ = Nothing -ifBlock :: Parser IfBlock +ifBlock :: TokenParser IfBlock ifBlock = do - guard' <- ifStart; + guard' <- ifElemStart; lines' <- many blockElem - _ <- ifEnd + _ <- ifElemEnd return (IfBlock guard' lines') -ifNotBlock :: Parser IfNotBlock +ifNotBlock :: TokenParser IfNotBlock ifNotBlock = do - guard' <- ifNotStart; + guard' <- ifNotElemStart; lines' <- block - _ <- ifEnd + _ <- ifElemEnd return (IfNotBlock guard' lines') -blockElem :: Parser BlockElem -blockElem = choice [codeLine, IfElem <$> ifBlock, IfNotElem <$> ifNotBlock ] "a block element" +blockElem :: TokenParser BlockElem +blockElem = choice [lineElem, IfElem <$> ifBlock, IfNotElem <$> ifNotBlock ] "a block element" -block :: Parser Block +block :: TokenParser Block block = many blockElem -parseFile :: String -> [LexLine] -> (Either ParseError Block) -parseFile fileName = parse (block <* eof) fileName +parseLexedFile :: String -> [LexLine] -> (Either ParseError Block) +parseLexedFile fileName = parse (block <* eof) fileName -- Turn Blocks Back into text From 4af10f2a52939027a71d0e6ca6f0b172db567f24 Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Fri, 21 Sep 2018 17:39:07 +0200 Subject: [PATCH 012/131] Make preProcess return a potential error. Implemented once using Either, (in preProcess') and once using Guarded through a translation layer (in preProcess). Also fixed a bug where IFNOT did not work, because apparently the 'string' parser from Parsec consumes input on a partial match. --- preProcApp/Main.hs | 2 +- src/Ampersand/Input/Parsing.hs | 2 +- src/Ampersand/Input/PreProcessor.hs | 29 +++++++++++++++++++---------- 3 files changed, 21 insertions(+), 12 deletions(-) diff --git a/preProcApp/Main.hs b/preProcApp/Main.hs index fad7202ccf..4c7ad27a39 100644 --- a/preProcApp/Main.hs +++ b/preProcApp/Main.hs @@ -11,4 +11,4 @@ main = filename:defs <- getArgs; input <- readUTF8File filename inputString <- return $ either id id input - putStr $ preProcess defs inputString ++ "\n" + putStr $ show (preProcess filename defs inputString) ++ "\n" diff --git a/src/Ampersand/Input/Parsing.hs b/src/Ampersand/Input/Parsing.hs index efc4e0d3f4..686af6afad 100644 --- a/src/Ampersand/Input/Parsing.hs +++ b/src/Ampersand/Input/Parsing.hs @@ -110,7 +110,7 @@ parseSingleADL opts pc Left err -> return $ mkErrorReadingINCLUDE (pcOrigin pc) filePath err Right fileContents -> whenCheckedIO - (return $ parseCtx filePath $ (preProcess (pcDefineds pc) fileContents)) + (return $ parseCtx filePath =<< (preProcess filePath (pcDefineds pc) fileContents)) $ \(ctxts, includes) -> do parseCandidates <- mapM include2ParseCandidate includes return (Checked (ctxts, parseCandidates)) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index a94275b484..67806dbaf7 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -1,9 +1,11 @@ module Ampersand.Input.PreProcessor ( preProcess + , preProcess' , PreProcDefine ) where import Data.List +import qualified Data.List.NonEmpty as NEL import Data.String import Data.Maybe import Data.Bool @@ -12,12 +14,19 @@ import Data.Functor import Control.Monad hiding (guard) import Control.Applicative hiding ( many ) import Text.Parsec hiding ( (<|>) ) +import Text.Parsec.Error import Prelude +import Ampersand.Input.ADL1.CtxError type PreProcDefine = String -preProcess :: [PreProcDefine] -> String -> String -preProcess defs = block2file defs True . (either (error . show) id) <$> file2block "" +preProcess :: String -> [PreProcDefine] -> String -> Guarded String +preProcess f d i = case preProcess' f d i of + (Left err) -> Errors $ (PE . Message . show $ err) NEL.:| [] + (Right out) -> Checked out + +preProcess' :: String -> [PreProcDefine] -> String -> Either ParseError String +preProcess' fileName defs input = (block2file defs True) <$> (file2block fileName input) -- Run the parser file2block :: String -> String -> Either ParseError Block @@ -49,23 +58,23 @@ whitespace = skipMany1 space ifWithGuard :: Lexer LexLine ifWithGuard = (IfStart . Guard) <$> - (string "IF" *> - whitespace *> - some alphaNum <* + (try(string "IF") *> + whitespace *> + some alphaNum <* manyTill anyChar endOfLine ) ifNotWithGuard :: Lexer LexLine ifNotWithGuard = (IfNotStart . Guard) <$> - (string "IFNOT" *> - whitespace *> - some alphaNum <* + (try(string "IFNOT") *> + whitespace *> + some alphaNum <* manyTill anyChar endOfLine ) ifEnd :: Lexer LexLine ifEnd = (const IfEnd) <$> - (string "ENDIF" *> + (try(string "ENDIF") *> manyTill anyChar endOfLine ) @@ -74,7 +83,7 @@ ifEnd = (const IfEnd) <$> -- for comments starting with #. preProcDirective :: Lexer LexLine preProcDirective = try (spaces *> string "--") *> char '#' *> spaces *> - (ifWithGuard <|> ifNotWithGuard <|> ifEnd "preproccesor directive") + (ifNotWithGuard <|> ifWithGuard <|> ifEnd "preproccesor directive") lexLine :: Lexer LexLine lexLine = preProcDirective <|> Codeline <$> manyTill anyChar endOfLine From 73342cef5c6840cd6df2f17508e4a840ec0ee193 Mon Sep 17 00:00:00 2001 From: Rieks Date: Tue, 2 Oct 2018 09:26:38 +0200 Subject: [PATCH 013/131] Split SystemContext from its documentation - arguments for this are in SystemContext.docadl --- AmpersandData/SystemContext/SystemContext.adl | 48 ++------------- .../SystemContext/SystemContext.docadl | 58 +++++++++++++++++++ 2 files changed, 63 insertions(+), 43 deletions(-) create mode 100644 AmpersandData/SystemContext/SystemContext.docadl diff --git a/AmpersandData/SystemContext/SystemContext.adl b/AmpersandData/SystemContext/SystemContext.adl index 1d3169143a..840de6318e 100644 --- a/AmpersandData/SystemContext/SystemContext.adl +++ b/AmpersandData/SystemContext/SystemContext.adl @@ -1,57 +1,19 @@ CONTEXT SystemContext IN ENGLISH - + PATTERN SystemSpecific - CONCEPT SESSION "een semi-permanente interactieve informatie-uitwisseling, ook bekend als een dialoog, een gesprek of een vergadering, tussen twee of meer communicerende apparaten, of tussen een computer en gebruiker" - PURPOSE CONCEPT SESSION IN DUTCH - {+Sessies zijn nodig om de dialoog aan te kunnen duiden tussen de gebruiker en de computer+} - PURPOSE CONCEPT SESSION IN ENGLISH - {+Sessions are required to allow for associating information with individual visitors+} - CONCEPT Role "een functie of onderdeel die speciaal in een bepaalde bewerking of proces wordt uitgevoerd" - PURPOSE CONCEPT Role IN DUTCH - {+We hebben rollen nodig om een basale vorm van beveiliging te implementeren, gebaseerd op permissies. +} - PURPOSE CONCEPT Role IN ENGLISH - {+We need roles to implement a basic form of security based on permissions. +} - CONCEPT DateTime "een specifiek moment, tijdstip" - PURPOSE CONCEPT DateTime IN DUTCH - {+Om bewerkingen te kunnen plaatsen in de tijd is het nodig om het over specifieke momenten te kunnen hebben.+} - PURPOSE CONCEPT DateTime IN ENGLISH - {+Telling the time enables some ordering of events in time.+} - - REPRESENT DateTime TYPE DATETIME - RELATION lastAccess[SESSION*DateTime] [UNI] - MEANING IN DUTCH "het moment waarop de sessie voor het laatst actief was" - MEANING IN ENGLISH "the last timestamp that a session was active" - PURPOSE RELATION lastAccess IN DUTCH - {+Een sessie kan op een bepaald moment actief zijn. Deze relatie bevat de informatie wanneer dat voor de laatste keer was.+} - PURPOSE RELATION lastAccess IN ENGLISH - {+A session can be active at some moment in time. This relation holds the information when that was for the last time.+} + RELATION sessionAccount[SESSION*Account] [UNI] RELATION sessionAllowedRoles[SESSION*Role] - MEANING IN DUTCH "een rol kan zijn toegestaan gedurende een sessie" - MEANING IN ENGLISH "a role can be allowed during a session" - PURPOSE RELATION sessionAllowedRoles IN DUTCH - {+Aan een gebruiker kunnen specifieke rollen zijn toegekend.+} - PURPOSE RELATION sessionAllowedRoles IN ENGLISH - {+A user can be granted specific roles.+} RELATION sessionActiveRoles[SESSION*Role] - MEANING IN DUTCH "een rol kan in gebruik zijn gedurende een sessie" - MEANING IN ENGLISH "a role can be active during a session" - PURPOSE RELATION sessionActiveRoles IN DUTCH - {+Gedurende een sessie kan een gebruiker over de permissies van specifieke rollen beschikken.+} - PURPOSE RELATION sessionActiveRoles IN ENGLISH - {+During a session the user can have roles, that grants permission for specific events.+} - - PURPOSE CONCEPT "ONE" IN DUTCH - {+De universele singleton+} - PURPOSE CONCEPT "ONE" IN ENGLISH - {+The universal singleton+} -- The following rule is required for the access control mechanism. It ensures that only allowed roles can be activated RULE "Active roles MUST be a subset of allowed roles" : sessionActiveRoles |- sessionAllowedRoles - RELATION sessionAccount[SESSION*Account] [UNI] + REPRESENT DateTime TYPE DATETIME + RELATION lastAccess[SESSION*DateTime] [UNI] RELATION accMostRecentLogin[Account*DateTime] [UNI] RELATION accLoginTimestamps[Account*DateTime] + ENDPATTERN ENDCONTEXT \ No newline at end of file diff --git a/AmpersandData/SystemContext/SystemContext.docadl b/AmpersandData/SystemContext/SystemContext.docadl new file mode 100644 index 0000000000..692fbd26f9 --- /dev/null +++ b/AmpersandData/SystemContext/SystemContext.docadl @@ -0,0 +1,58 @@ +CONTEXT SystemContext IN ENGLISH +{-This file contains the heritage documentation of SystemContext.adl. +This heritage documentation, however, still has several problems, e.g: + - The default texts are not ENGLISH, even though this is specified in the CONTEXT statement. + - The texts in Dutch say different things that the texts in English. + - The texts may not be appropriate in every situation, whereas the CONTEXT itself, of course, is. + +For a better explanation of stuff around sessions, roles, accounts, etc., see SIAMv3. +-} +PATTERN SystemSpecific + CONCEPT SESSION "een semi-permanente interactieve informatie-uitwisseling, ook bekend als een dialoog, een gesprek of een vergadering, tussen twee of meer communicerende apparaten, of tussen een computer en gebruiker" + PURPOSE CONCEPT SESSION IN DUTCH + {+Sessies zijn nodig om de dialoog aan te kunnen duiden tussen de gebruiker en de computer+} + PURPOSE CONCEPT SESSION IN ENGLISH + {+Sessions are required to allow for associating information with individual visitors+} + CONCEPT Role "een functie of onderdeel die speciaal in een bepaalde bewerking of proces wordt uitgevoerd" + PURPOSE CONCEPT Role IN DUTCH + {+We hebben rollen nodig om een basale vorm van beveiliging te implementeren, gebaseerd op permissies. +} + PURPOSE CONCEPT Role IN ENGLISH + {+We need roles to implement a basic form of security based on permissions. +} + CONCEPT DateTime "een specifiek moment, tijdstip" + PURPOSE CONCEPT DateTime IN DUTCH + {+Om bewerkingen te kunnen plaatsen in de tijd is het nodig om het over specifieke momenten te kunnen hebben.+} + PURPOSE CONCEPT DateTime IN ENGLISH + {+Telling the time enables some ordering of events in time.+} + + RELATION lastAccess[SESSION*DateTime] [UNI] -- This definition is only needed for `MEANING` to be interpreted correctly. + MEANING IN DUTCH "het moment waarop de sessie voor het laatst actief was" + MEANING IN ENGLISH "the last timestamp that a session was active" + PURPOSE RELATION lastAccess IN DUTCH + {+Een sessie kan op een bepaald moment actief zijn. Deze relatie bevat de informatie wanneer dat voor de laatste keer was.+} + PURPOSE RELATION lastAccess IN ENGLISH + {+A session can be active at some moment in time. This relation holds the information when that was for the last time.+} + + RELATION sessionAllowedRoles[SESSION*Role] -- This definition is only needed for `MEANING` to be interpreted correctly. + MEANING IN DUTCH "een rol kan zijn toegestaan gedurende een sessie" + MEANING IN ENGLISH "a role can be allowed during a session" + PURPOSE RELATION sessionAllowedRoles IN DUTCH + {+Aan een gebruiker kunnen specifieke rollen zijn toegekend.+} + PURPOSE RELATION sessionAllowedRoles IN ENGLISH + {+A user can be granted specific roles.+} + + RELATION sessionActiveRoles[SESSION*Role] -- This definition is only needed for `MEANING` to be interpreted correctly. + MEANING IN DUTCH "een rol kan in gebruik zijn gedurende een sessie" + MEANING IN ENGLISH "a role can be active during a session" + PURPOSE RELATION sessionActiveRoles IN DUTCH + {+Gedurende een sessie kan een gebruiker over de permissies van specifieke rollen beschikken.+} + PURPOSE RELATION sessionActiveRoles IN ENGLISH + {+During a session the user can have roles, that grants permission for specific events.+} + + PURPOSE CONCEPT "ONE" IN DUTCH + {+De universele singleton+} + PURPOSE CONCEPT "ONE" IN ENGLISH + {+The universal singleton+} + +ENDPATTERN + +ENDCONTEXT \ No newline at end of file From 5aad5c5e491046218465ef3bf0759bb91e0cba83 Mon Sep 17 00:00:00 2001 From: Rieks Date: Tue, 2 Oct 2018 11:38:21 +0200 Subject: [PATCH 014/131] updated preprocessor specs in the light of having seen bugs. --- AmpersandData/SystemContext/SystemContext.adl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/AmpersandData/SystemContext/SystemContext.adl b/AmpersandData/SystemContext/SystemContext.adl index 840de6318e..43bfe21e06 100644 --- a/AmpersandData/SystemContext/SystemContext.adl +++ b/AmpersandData/SystemContext/SystemContext.adl @@ -6,8 +6,8 @@ PATTERN SystemSpecific RELATION sessionAllowedRoles[SESSION*Role] RELATION sessionActiveRoles[SESSION*Role] - -- The following rule is required for the access control mechanism. It ensures that only allowed roles can be activated - RULE "Active roles MUST be a subset of allowed roles" : sessionActiveRoles |- sessionAllowedRoles + RULE "Active roles MUST be a subset of allowed roles": -- This rule is required for the access control mechanism. + sessionActiveRoles |- sessionAllowedRoles -- It ensures that only allowed roles can be activated. REPRESENT DateTime TYPE DATETIME RELATION lastAccess[SESSION*DateTime] [UNI] @@ -16,4 +16,4 @@ PATTERN SystemSpecific ENDPATTERN -ENDCONTEXT \ No newline at end of file +ENDCONTEXT From 2bbc131e0c4b18ae028a2ae1180e409e2be58569 Mon Sep 17 00:00:00 2001 From: bart Date: Wed, 3 Oct 2018 05:08:17 -0700 Subject: [PATCH 015/131] Fix bug, all comments were expected to be preProcDirective. --- src/Ampersand/Input/PreProcessor.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index 67806dbaf7..8cde450368 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -82,7 +82,7 @@ ifEnd = (const IfEnd) <$> -- but fails with consuming input (and message "preproccesor directive") -- for comments starting with #. preProcDirective :: Lexer LexLine -preProcDirective = try (spaces *> string "--") *> char '#' *> spaces *> +preProcDirective = try(spaces *> string "--#") *> spaces *> (ifNotWithGuard <|> ifWithGuard <|> ifEnd "preproccesor directive") lexLine :: Lexer LexLine From 2487783f05952698382cb3017b88046ef95622ad Mon Sep 17 00:00:00 2001 From: bart Date: Wed, 3 Oct 2018 05:30:29 -0700 Subject: [PATCH 016/131] Fix output of manual preprocessor app. --- preProcApp/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/preProcApp/Main.hs b/preProcApp/Main.hs index 4c7ad27a39..f6523eaf25 100644 --- a/preProcApp/Main.hs +++ b/preProcApp/Main.hs @@ -11,4 +11,4 @@ main = filename:defs <- getArgs; input <- readUTF8File filename inputString <- return $ either id id input - putStr $ show (preProcess filename defs inputString) ++ "\n" + putStr $ either show id (preProcess' filename defs inputString) ++ "\n" From cee29e318c4ec6d99e7aad3daca19fb4e7066139 Mon Sep 17 00:00:00 2001 From: bart Date: Wed, 3 Oct 2018 15:19:22 +0200 Subject: [PATCH 017/131] Add Else clauses. --- src/Ampersand/Input/PreProcessor.hs | 59 +++++++++++++++++++++-------- 1 file changed, 44 insertions(+), 15 deletions(-) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index 8cde450368..ff69b53a67 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -40,6 +40,7 @@ type Lexer a = Parsec String () a data LexLine = Codeline String | IfNotStart Guard | IfStart Guard + | ElseClause | IfEnd instance Show LexLine where show = showLex @@ -48,6 +49,7 @@ showLex :: LexLine -> String showLex (Codeline x) = x showLex (IfNotStart x) = "If Not " ++ guard x showLex (IfStart x) = "If " ++ guard x +showLex (ElseClause) = "Else" showLex (IfEnd) = "End If" --preProcDirective :: Lexer () @@ -78,12 +80,18 @@ ifEnd = (const IfEnd) <$> manyTill anyChar endOfLine ) +elseClause :: Lexer LexLine +elseClause = (const ElseClause) <$> + (try(string "ELSE") *> + manyTill anyChar endOfLine + ) + -- This fails without consuming input on comments, -- but fails with consuming input (and message "preproccesor directive") -- for comments starting with #. preProcDirective :: Lexer LexLine preProcDirective = try(spaces *> string "--#") *> spaces *> - (ifNotWithGuard <|> ifWithGuard <|> ifEnd "preproccesor directive") + (ifNotWithGuard <|> ifWithGuard <|> elseClause <|> ifEnd "preproccesor directive") lexLine :: Lexer LexLine lexLine = preProcDirective <|> Codeline <$> manyTill anyChar endOfLine @@ -92,18 +100,21 @@ fullLexer :: String -> String -> Either ParseError [LexLine] fullLexer filename = parse (many lexLine <* eof) filename -- PARSER -newtype Guard = Guard String +newtype Guard = Guard String deriving (Show) guard :: Guard -> String guard (Guard x) = x data BlockElem = LineElem String | IfElem IfBlock | IfNotElem IfNotBlock + deriving (Show) type Block = [ BlockElem ] -data IfBlock = IfBlock Guard Block -data IfNotBlock = IfNotBlock Guard Block +data IfBlock = IfBlock Guard Block (Maybe Block) + deriving (Show) +data IfNotBlock = IfNotBlock Guard Block (Maybe Block) + deriving (Show) type TokenParser a = Parsec [LexLine] () a @@ -135,19 +146,27 @@ ifElemEnd = parserToken (matchIfEnd) matchIfEnd IfEnd = Just () matchIfEnd _ = Nothing +elseClauseStart :: TokenParser () +elseClauseStart = parserToken (matchIfEnd) + where + matchIfEnd ElseClause = Just () + matchIfEnd _ = Nothing + ifBlock :: TokenParser IfBlock ifBlock = do - guard' <- ifElemStart; - lines' <- many blockElem - _ <- ifElemEnd - return (IfBlock guard' lines') + guard' <- ifElemStart; + lines' <- many blockElem + elseLines <- optionMaybe( elseClauseStart *> many blockElem) + _ <- ifElemEnd + return (IfBlock guard' lines' elseLines) ifNotBlock :: TokenParser IfNotBlock ifNotBlock = do - guard' <- ifNotElemStart; - lines' <- block - _ <- ifElemEnd - return (IfNotBlock guard' lines') + guard' <- ifNotElemStart; + lines' <- block + elseLines <- optionMaybe( elseClauseStart *> many blockElem) + _ <- ifElemEnd + return (IfNotBlock guard' lines' elseLines) blockElem :: TokenParser BlockElem blockElem = choice [lineElem, IfElem <$> ifBlock, IfNotElem <$> ifNotBlock ] "a block element" @@ -172,11 +191,21 @@ blockElem2string :: [PreProcDefine] -> Bool -> BlockElem -> Strin blockElem2string _ True (LineElem line) = line ++ "\n" blockElem2string _ False (LineElem line) = "--hiden by preprocc " ++ line ++ "\n" -- Lots of unpacking to get to the IfBlock -blockElem2string defs showing (IfElem (IfBlock (Guard guard') block')) = +blockElem2string defs showing (IfElem (IfBlock (Guard guard') block' elseBlock)) = "--#IF " ++ guard' ++ "\n" ++ - (block2file defs (showing && (guard' `elem` defs)) block') ++ + (block2file defs (showing && (guard' `elem` defs)) block') ++ + (maybe "" + ( ("--#ELSE\n" ++) . + block2file defs (showing && not (guard' `elem` defs)) + ) elseBlock + ) ++ "--#ENDIF\n" -blockElem2string defs showing (IfNotElem (IfNotBlock (Guard guard') block')) = +blockElem2string defs showing (IfNotElem (IfNotBlock (Guard guard') block' elseBlock)) = "--#IFNOT " ++ guard' ++ "\n" ++ (block2file defs (showing && not (guard' `elem` defs)) block') ++ + (maybe "" + ( ("--#ELSE\n" ++) . + block2file defs (showing && (guard' `elem` defs)) + ) elseBlock + ) ++ "--#ENDIF\n" From 15870cf2e76dc0f7a5bbda3a44a1b89d5b415455 Mon Sep 17 00:00:00 2001 From: bart Date: Fri, 5 Oct 2018 14:38:28 +0200 Subject: [PATCH 018/131] Refactor entire preprocessor, minor fixes. List of fixes: - We can now handle files that aren't terminated by a newline (we do this by crudely appending a newline to each file) - We expanded the syntax for a preprocessor directive. Now, we also accept more dashes than just "--" and whitespace between the dashes and the '#'. The most notable refactor is merging the IfBlock and IfNotBlock types into the GuardedBlock type. This was done to factor out the function showGuardedBlock, which render both IF and IFNOT blocks. As the logic is complicated and very similar, it made sense to merge them. We also reordered the definitions in the Lexer and Parser so the high-level definitions come first. Finally, we factored out some common code and added a whole lot of documentation. --- src/Ampersand/Input/PreProcessor.hs | 283 ++++++++++++++++------------ 1 file changed, 162 insertions(+), 121 deletions(-) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index ff69b53a67..2bc466f6cc 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -20,114 +20,161 @@ import Ampersand.Input.ADL1.CtxError type PreProcDefine = String -preProcess :: String -> [PreProcDefine] -> String -> Guarded String +-- Shim that changes our 'Either ParseError a' from preProcess' into 'Guarded a' +-- | Runs the preProcessor on input +preProcess :: String -- ^ filename, used only for error reporting + -> [PreProcDefine] -- ^ list of flags, The list of defined 'flags + -> String -- ^ input, The actual string to processs + -> Guarded String -- ^ result, The result of processing preProcess f d i = case preProcess' f d i of (Left err) -> Errors $ (PE . Message . show $ err) NEL.:| [] (Right out) -> Checked out -preProcess' :: String -> [PreProcDefine] -> String -> Either ParseError String -preProcess' fileName defs input = (block2file defs True) <$> (file2block fileName input) +-- | Runs the preProcessor on input +preProcess' :: String -- ^ filename, used only for error reporting + -> [PreProcDefine] -- ^ list of flags, The list of defined 'flags + -> String -- ^ input, The actual string to process + -> Either ParseError String -- ^ result, The result of processing +-- We append "\n" because the parser cannot handle a final line not terminated by a newline. +preProcess' fileName defs input = (block2file defs True) <$> (file2block fileName (input ++ "\n")) -- Run the parser -file2block :: String -> String -> Either ParseError Block -file2block fileName = (parseLexedFile fileName) <=< (fullLexer fileName) +file2block :: String -- ^ filename, used only for error reporting + -> String -- ^ input, the string to process + -> Either ParseError Block -- ^ result +file2block fileName = (parseLexedFile fileName) <=< (runLexer fileName) --- LEXER - -type Lexer a = Parsec String () a +---- LEXER +newtype Guard = Guard String +guard :: Guard -> String +guard (Guard x) = x -data LexLine = Codeline String +data LexLine = CodeLine String | IfNotStart Guard | IfStart Guard | ElseClause - | IfEnd + | EndIf instance Show LexLine where show = showLex - showLex :: LexLine -> String -showLex (Codeline x) = x -showLex (IfNotStart x) = "If Not " ++ guard x -showLex (IfStart x) = "If " ++ guard x -showLex (ElseClause) = "Else" -showLex (IfEnd) = "End If" +showLex (CodeLine x) = x +showLex (IfNotStart x) = "IFNOT " ++ guard x +showLex (IfStart x) = "IF " ++ guard x +showLex (ElseClause) = "ELSE" +showLex (EndIf) = "ENDIF" ---preProcDirective :: Lexer () +type Lexer a = Parsec String () a +-- | Transform the String 'input' into a list of LexLine tokens. Using 'filename' for error reporting. +runLexer :: String -- ^ filename, only used for error reporting + -> String -- ^ input, the string to process + -> Either ParseError [LexLine] +runLexer filename = parse (many lexLine <* eof) filename -whitespace :: Lexer () -whitespace = skipMany1 space +lexLine :: Lexer LexLine +lexLine = preProcDirective <|> codeLine -ifWithGuard :: Lexer LexLine -ifWithGuard = (IfStart . Guard) <$> - (try(string "IF") *> - whitespace *> - some alphaNum <* - manyTill anyChar endOfLine +codeLine :: Lexer LexLine +codeLine = CodeLine <$> untillEOL + +preProcDirective :: Lexer LexLine +preProcDirective = (try preProcPrefix) *> + ( ifNotGuard + <|> ifGuard + <|> elseClause + <|> ifEnd + "preproccesor directive" + ) + +-- This pattern signifies the line is meant for the preProcessor. +-- Lines that don't start with this pattern are 'CodeLine's +preProcPrefix :: Lexer () +preProcPrefix = spaces *> string "--" *> many (char '-') *> spaces *> char '#' *> spaces + +ifGuard :: Lexer LexLine +ifGuard = (IfStart . Guard) <$> + (try(string "IF") *> + whitespace *> + some alphaNum <* + untillEOL ) -ifNotWithGuard :: Lexer LexLine -ifNotWithGuard = (IfNotStart . Guard) <$> - (try(string "IFNOT") *> - whitespace *> - some alphaNum <* - manyTill anyChar endOfLine +ifNotGuard :: Lexer LexLine +ifNotGuard = (IfNotStart . Guard) <$> + (try(string "IFNOT") *> + whitespace *> + some alphaNum <* + untillEOL ) -ifEnd :: Lexer LexLine -ifEnd = (const IfEnd) <$> - (try(string "ENDIF") *> - manyTill anyChar endOfLine - ) - elseClause :: Lexer LexLine -elseClause = (const ElseClause) <$> - (try(string "ELSE") *> - manyTill anyChar endOfLine - ) - --- This fails without consuming input on comments, --- but fails with consuming input (and message "preproccesor directive") --- for comments starting with #. -preProcDirective :: Lexer LexLine -preProcDirective = try(spaces *> string "--#") *> spaces *> - (ifNotWithGuard <|> ifWithGuard <|> elseClause <|> ifEnd "preproccesor directive") +elseClause = (const ElseClause) <$> (try(string "ELSE") *> untillEOL) -lexLine :: Lexer LexLine -lexLine = preProcDirective <|> Codeline <$> manyTill anyChar endOfLine +ifEnd :: Lexer LexLine +ifEnd = (const EndIf) <$> (try(string "ENDIF") *> untillEOL) -fullLexer :: String -> String -> Either ParseError [LexLine] -fullLexer filename = parse (many lexLine <* eof) filename +-- Helper Lexers +whitespace :: Lexer () +whitespace = skipMany1 space --- PARSER -newtype Guard = Guard String deriving (Show) -guard :: Guard -> String -guard (Guard x) = x +untillEOL :: Lexer String +untillEOL = manyTill anyChar endOfLine + +---- PARSER +-- | A block element is either a normal line, or a Guarded Block (i.e. an IF or IFNOT block) data BlockElem = LineElem String - | IfElem IfBlock - | IfNotElem IfNotBlock - deriving (Show) + | GuardedElem GuardedBlock -- These cover IF and IFNOT blocks type Block = [ BlockElem ] -data IfBlock = IfBlock Guard Block (Maybe Block) - deriving (Show) -data IfNotBlock = IfNotBlock Guard Block (Maybe Block) - deriving (Show) +-- The first BOOL here determines whether this is an IF or IFNOT block +data GuardedBlock = GuardedBlock Bool -- ^ This covers whether this is an IF or an IFNOT block. True for IF, false for IFNOT. + Guard -- ^ The guard of the IF or IFNOT + Block -- ^ The actual Block + (Maybe Block) -- ^ An optional ELSE block. + {- (Note that there is a difference between Maybe [] and Nothing here. + The first represents and empty ELSE block, the second an absent block. + This matters for preserving line numbers. + -} type TokenParser a = Parsec [LexLine] () a -parserToken :: (LexLine -> Maybe a) -> TokenParser a -parserToken constructor = tokenPrim showLex (\pos _ _ -> incSourceLine pos 1) constructor +parseLexedFile :: String -> [LexLine] -> (Either ParseError Block) +parseLexedFile fileName = parse (many blockElem <* eof) fileName + +blockElem :: TokenParser BlockElem +blockElem = choice [lineElem, ifBlock, ifNotBlock ] "a normal code line, an IF block or an IFNOT block" lineElem :: TokenParser BlockElem lineElem = parserToken ((fmap LineElem) <$> line2string) where line2string :: LexLine -> Maybe String - line2string (Codeline s) = Just s + line2string (CodeLine s) = Just s line2string _ = Nothing +ifBlock :: TokenParser BlockElem +ifBlock = GuardedElem <$> (pure (GuardedBlock True) + <*> ifElemStart + <*> many blockElem + <*> optionMaybe(elseClauseStart *> many blockElem) + <* ifElemEnd + ) + +ifNotBlock :: TokenParser BlockElem +ifNotBlock = GuardedElem <$> (pure (GuardedBlock False) + <*> ifNotElemStart + <*> many blockElem + <*> optionMaybe(elseClauseStart *> many blockElem) + <* ifElemEnd + ) +{-| Helper function to create parsers. Takes a constructor of type (LexLine -> Maybe a) and returns a parser. The + returned parser yields x if the constructor returns Just x and the parser fails if the constructor returns Nothing. +-} +parserToken :: (LexLine -> Maybe a) -> TokenParser a +parserToken constructor = tokenPrim showLex (\pos _ _ -> incSourceLine pos 1) constructor + ifElemStart :: TokenParser Guard ifElemStart = parserToken guard2string where @@ -141,71 +188,65 @@ ifNotElemStart = parserToken guard2string guard2string _ = Nothing ifElemEnd :: TokenParser () -ifElemEnd = parserToken (matchIfEnd) +ifElemEnd = parserToken matchIfEnd where - matchIfEnd IfEnd = Just () + matchIfEnd EndIf = Just () matchIfEnd _ = Nothing elseClauseStart :: TokenParser () -elseClauseStart = parserToken (matchIfEnd) +elseClauseStart = parserToken matchIfEnd where matchIfEnd ElseClause = Just () matchIfEnd _ = Nothing -ifBlock :: TokenParser IfBlock -ifBlock = do - guard' <- ifElemStart; - lines' <- many blockElem - elseLines <- optionMaybe( elseClauseStart *> many blockElem) - _ <- ifElemEnd - return (IfBlock guard' lines' elseLines) - -ifNotBlock :: TokenParser IfNotBlock -ifNotBlock = do - guard' <- ifNotElemStart; - lines' <- block - elseLines <- optionMaybe( elseClauseStart *> many blockElem) - _ <- ifElemEnd - return (IfNotBlock guard' lines' elseLines) +---- TURN BLOCK BACK INTO TEXT -blockElem :: TokenParser BlockElem -blockElem = choice [lineElem, IfElem <$> ifBlock, IfNotElem <$> ifNotBlock ] "a block element" - -block :: TokenParser Block -block = many blockElem - -parseLexedFile :: String -> [LexLine] -> (Either ParseError Block) -parseLexedFile fileName = parse (block <* eof) fileName +{- Note the recursion here: + block2file calls blockElem2String, which might call showGuardedBlock, which calls block2file and potentially also + showElse, which again calls block2file --- Turn Blocks Back into text + This matches the recursion where a 'Block' contains multiple 'BlockElem's which can contain a 'GuardedBlock' which + contains a main 'Block', and potentially an ELSE 'Block'. +-} --- Turn a block back --- Could be done with a stateful monad where -block2file :: [PreProcDefine] -> Bool -> Block -> String +-- | Renders a Block type back into a String, according to some context +block2file :: [PreProcDefine] -- ^ flags, List of defined flags + -> Bool -- ^ showing, whether we are showing the current block, or it is hidden + -> Block -- ^ block, the block we want to process + -> String block2file defs shown = concat . map (blockElem2string defs shown) --- Handle single entry in a block --- Responsible for adding newlines --- list of flags Showing this element? 2 process output -blockElem2string :: [PreProcDefine] -> Bool -> BlockElem -> String -blockElem2string _ True (LineElem line) = line ++ "\n" -blockElem2string _ False (LineElem line) = "--hiden by preprocc " ++ line ++ "\n" --- Lots of unpacking to get to the IfBlock -blockElem2string defs showing (IfElem (IfBlock (Guard guard') block' elseBlock)) = - "--#IF " ++ guard' ++ "\n" ++ - (block2file defs (showing && (guard' `elem` defs)) block') ++ - (maybe "" - ( ("--#ELSE\n" ++) . - block2file defs (showing && not (guard' `elem` defs)) - ) elseBlock - ) ++ - "--#ENDIF\n" -blockElem2string defs showing (IfNotElem (IfNotBlock (Guard guard') block' elseBlock)) = - "--#IFNOT " ++ guard' ++ "\n" ++ - (block2file defs (showing && not (guard' `elem` defs)) block') ++ - (maybe "" - ( ("--#ELSE\n" ++) . - block2file defs (showing && (guard' `elem` defs)) - ) elseBlock - ) ++ - "--#ENDIF\n" +-- | Renders a single block element back into text +blockElem2string :: [PreProcDefine] -- ^ flags, the list of active flags + -> Bool -- ^ showing, whether we are showing the current block element, or it is hidden + -> BlockElem -- ^ blockElem, the block element to render + -> String +blockElem2string _ True (LineElem line) = line ++ "\n" +blockElem2string _ False (LineElem line) = "--hiden by preprocc " ++ line ++ "\n" +blockElem2string defs showing (GuardedElem guardedElem) = showGuardedBlock defs showing guardedElem + +-- | Renders a GuardedBlock +-- This is where the rendering logic of IF and IFNOT is implemented +-- Simplification of this function is why IF and IFNOT are both represented by the type GuardedBlock +showGuardedBlock :: [PreProcDefine] -- ^ flags, the list of active flags + -> Bool -- ^ showing, whether we are showing the current block element, or it is hidden + -> GuardedBlock -- ^ guardedBlock, the element to render + -> String +showGuardedBlock defs showing (GuardedBlock ifType (Guard guard') block elseBlock) = + -- The xor (not ifType) is a succinct way to express the difference between IF blocks and NOTIF blocks + let showMainBody = (xor (not ifType) (guard' `elem` defs)) in + concat [ guardedBlockName ifType ++ guard' ++ "\n" + , (block2file defs (showing && showMainBody) block ) + , (showElse defs (showing && (not showMainBody)) elseBlock) + , "--#ENDIF\n" + ] + +-- Helper functions +guardedBlockName :: Bool -> String +guardedBlockName ifType = (if ifType then "--#IF " else "--#IFNOT ") + +showElse :: [PreProcDefine] -> Bool -> Maybe Block -> String +showElse defs showing = maybe "" (("--#ELSE\n" ++) . block2file defs showing) + +xor :: Bool -> Bool -> Bool +xor p q = (p || q) && not (p && q) \ No newline at end of file From b0dd4a9a9f82433f92f8e68e4540e4e0f654177f Mon Sep 17 00:00:00 2001 From: bart Date: Fri, 5 Oct 2018 16:21:18 +0200 Subject: [PATCH 019/131] Make INCLUDE backwards compatible. Rather crude attempt, using commentary and pKey "--#" for recognizing a string. --- src/Ampersand/Input/ADL1/Parser.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index 79470441ca..141f755a7b 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -94,13 +94,13 @@ data ContextElement = CMeta Meta | CIncl Include -- an INCLUDE statement data Include = Include Origin FilePath [String] ---- IncludeStatement ::= 'INCLUDE' String +--- IncludeStatement ::= 'INCLUDE' ('--#' [ "vars" ]) pIncludeStatement :: AmpParser Include pIncludeStatement = Include <$> currPos <* pKey "INCLUDE" <*> pString - <*> (pBrackets (pString `sepBy` pComma) <|> return []) + <*> optList (try (pKey "--#") *> (pBrackets (pString `sepBy` pComma) <|> return []) "list of flags") --- LanguageRef ::= 'IN' ('DUTCH' | 'ENGLISH') pLanguageRef :: AmpParser Lang From ef5a399f1d75f102553bbc123ca4846b8e9ef293 Mon Sep 17 00:00:00 2001 From: bart Date: Mon, 8 Oct 2018 14:08:26 +0200 Subject: [PATCH 020/131] Put INCLUDE flags behind an optional "--#" Reverts the previous commit. We now allow an include statement with flagsin either of the following 2 forms: INCLUDE "filename" ["FLAG"] INCLUDE "filename" --# ["FLAG"] This is done by the preprocessor detecting the second form and converting it to the first. The last commit did not work. There we tried to allow for comments in the ampersand parser. This actually requires work in the lexer. Specifically, it requires making the lexer distinguish --# from --. As this is difficult, this functionality was pulled into the preProcessor. In the end, we might want to put this, combined with giving the actual flags in the Lexer. --- src/Ampersand/Input/ADL1/Parser.hs | 4 +-- src/Ampersand/Input/PreProcessor.hs | 51 ++++++++++++++++++++--------- 2 files changed, 37 insertions(+), 18 deletions(-) diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index 141f755a7b..79470441ca 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -94,13 +94,13 @@ data ContextElement = CMeta Meta | CIncl Include -- an INCLUDE statement data Include = Include Origin FilePath [String] ---- IncludeStatement ::= 'INCLUDE' ('--#' [ "vars" ]) +--- IncludeStatement ::= 'INCLUDE' String pIncludeStatement :: AmpParser Include pIncludeStatement = Include <$> currPos <* pKey "INCLUDE" <*> pString - <*> optList (try (pKey "--#") *> (pBrackets (pString `sepBy` pComma) <|> return []) "list of flags") + <*> (pBrackets (pString `sepBy` pComma) <|> return []) --- LanguageRef ::= 'IN' ('DUTCH' | 'ENGLISH') pLanguageRef :: AmpParser Lang diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index 2bc466f6cc..d214f3fde5 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -51,6 +51,7 @@ guard :: Guard -> String guard (Guard x) = x data LexLine = CodeLine String + | IncludeLine String (Maybe String) | IfNotStart Guard | IfStart Guard | ElseClause @@ -58,11 +59,12 @@ data LexLine = CodeLine String instance Show LexLine where show = showLex showLex :: LexLine -> String -showLex (CodeLine x) = x -showLex (IfNotStart x) = "IFNOT " ++ guard x -showLex (IfStart x) = "IF " ++ guard x -showLex (ElseClause) = "ELSE" -showLex (EndIf) = "ENDIF" +showLex (CodeLine x) = x +showLex (IncludeLine x y) = x ++ " " ++ maybe "" id y +showLex (IfNotStart x) = "IFNOT " ++ guard x +showLex (IfStart x) = "IF " ++ guard x +showLex (ElseClause) = "ELSE" +showLex (EndIf) = "ENDIF" type Lexer a = Parsec String () a @@ -73,10 +75,18 @@ runLexer :: String -- ^ filename, only used for error reporting runLexer filename = parse (many lexLine <* eof) filename lexLine :: Lexer LexLine -lexLine = preProcDirective <|> codeLine +lexLine = preProcDirective <|> includeLine <|> codeLine codeLine :: Lexer LexLine -codeLine = CodeLine <$> untillEOL +codeLine = CodeLine <$> untilEOL + +includeLine :: Lexer LexLine +includeLine = do { + ; spaces' <- try (many space <* string "INCLUDE") + ; included <- manyTill anyChar (lookAhead . try $ (( (:[]) <$> endOfLine) <|> string "--#")) + ; flags <- optionMaybe $ (try . string $ "--#") *> untilEOL + ; return $ IncludeLine (spaces' ++ "INCLUDE" ++ included) flags + } preProcDirective :: Lexer LexLine preProcDirective = (try preProcPrefix) *> @@ -97,7 +107,7 @@ ifGuard = (IfStart . Guard) <$> (try(string "IF") *> whitespace *> some alphaNum <* - untillEOL + untilEOL ) ifNotGuard :: Lexer LexLine @@ -105,26 +115,27 @@ ifNotGuard = (IfNotStart . Guard) <$> (try(string "IFNOT") *> whitespace *> some alphaNum <* - untillEOL + untilEOL ) elseClause :: Lexer LexLine -elseClause = (const ElseClause) <$> (try(string "ELSE") *> untillEOL) +elseClause = (const ElseClause) <$> (try(string "ELSE") *> untilEOL) ifEnd :: Lexer LexLine -ifEnd = (const EndIf) <$> (try(string "ENDIF") *> untillEOL) +ifEnd = (const EndIf) <$> (try(string "ENDIF") *> untilEOL) -- Helper Lexers whitespace :: Lexer () whitespace = skipMany1 space -untillEOL :: Lexer String -untillEOL = manyTill anyChar endOfLine +untilEOL :: Lexer String +untilEOL = manyTill anyChar endOfLine ---- PARSER -- | A block element is either a normal line, or a Guarded Block (i.e. an IF or IFNOT block) data BlockElem = LineElem String + | IncludeElem String (Maybe String) | GuardedElem GuardedBlock -- These cover IF and IFNOT blocks type Block = [ BlockElem ] @@ -145,14 +156,19 @@ parseLexedFile :: String -> [LexLine] -> (Either ParseError Block) parseLexedFile fileName = parse (many blockElem <* eof) fileName blockElem :: TokenParser BlockElem -blockElem = choice [lineElem, ifBlock, ifNotBlock ] "a normal code line, an IF block or an IFNOT block" +blockElem = choice [lineElem, includeElem, ifBlock, ifNotBlock ] lineElem :: TokenParser BlockElem lineElem = parserToken ((fmap LineElem) <$> line2string) where - line2string :: LexLine -> Maybe String line2string (CodeLine s) = Just s - line2string _ = Nothing + line2string _ = Nothing + +includeElem :: TokenParser BlockElem +includeElem = parserToken (line2string) + where + line2string (IncludeLine s m) = Just $ IncludeElem s m + line2string _ = Nothing ifBlock :: TokenParser BlockElem ifBlock = GuardedElem <$> (pure (GuardedBlock True) @@ -222,7 +238,10 @@ blockElem2string :: [PreProcDefine] -- ^ flags, the list of active flags -> BlockElem -- ^ blockElem, the block element to render -> String blockElem2string _ True (LineElem line) = line ++ "\n" +blockElem2string _ True (IncludeElem line flags) = line ++ " " ++ fromMaybe "" flags ++ "\n" blockElem2string _ False (LineElem line) = "--hiden by preprocc " ++ line ++ "\n" +blockElem2string _ False (IncludeElem line flags) = "--hiden by preprocc " ++ line ++ + " " ++ fromMaybe "" flags ++ "\n" blockElem2string defs showing (GuardedElem guardedElem) = showGuardedBlock defs showing guardedElem -- | Renders a GuardedBlock From 89524aec84e371c40a88a49cb6e17f324f134963 Mon Sep 17 00:00:00 2001 From: Bart Marinissen Date: Fri, 2 Nov 2018 10:26:50 +0100 Subject: [PATCH 021/131] Fix missed version increase on new executable The pre-processor has a new executable. (So you can see the results of running the pre-processor) There was a version-bump where this executable was missed. --- ampersand.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ampersand.cabal b/ampersand.cabal index 02fbbf9026..d0cccc58fb 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -191,7 +191,7 @@ executable ampPreProc default-language: Haskell2010 ghc-options: -Wall -threaded default-extensions:NoImplicitPrelude - build-depends: base == 4.10.*, + build-depends: base == 4.11.*, ampersand Test-Suite regression-test From 043e852887b3104ca64acc539c249c663e8c1246 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink <> Date: Sat, 1 Dec 2018 16:51:43 +0100 Subject: [PATCH 022/131] Add 'public' folder in prototype directory to better distinguish between public and non-public scripts --- ReleaseNotes.md | 1 + src/Ampersand/Prototype/ProtoUtil.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 7795f6b62c..1d6b103e05 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -3,6 +3,7 @@ ## Unreleased changes * Add semantics to difference in API or INTERFACE keywords. +* Add 'public' folder in prototype directory to better distinguish between public and non-public scripts. If used, requires change in 'customizations' folder ## v3.11.5 (23 november 2018) diff --git a/src/Ampersand/Prototype/ProtoUtil.hs b/src/Ampersand/Prototype/ProtoUtil.hs index 2f45cd02d9..b9a8d3ad02 100644 --- a/src/Ampersand/Prototype/ProtoUtil.hs +++ b/src/Ampersand/Prototype/ProtoUtil.hs @@ -35,7 +35,7 @@ writePrototypeAppFile opts relFilePath content = getAppDir :: Options -> String getAppDir opts = - dirPrototype opts "app" "project" + dirPrototype opts "public" "app" "project" -- Copy entire directory tree from srcBase/ to tgtBase/, overwriting existing files, but not emptying existing directories. -- NOTE: tgtBase specifies the copied directory target, not its parent From 8bd146cc6e1e9f09c06ce308c08c65b9b66607cf Mon Sep 17 00:00:00 2001 From: bart Date: Mon, 10 Dec 2018 16:15:26 +0100 Subject: [PATCH 023/131] Fix bug with line-numbers. There were two issues with line numbers: * empty Lines before an --#IF or an --#IFNOT were swallowed * INCLUDE statements without flags (i.e. without a --# on the line) had an extra newline behind them. The first issue was because Parsec's `spaces` also accepts newlines as whitespace. The second issue was due to the complexity of lexing an include statement. It should not include the newline, but it did in the case where there are no include flags. This meant an extra newline was output. --- src/Ampersand/Input/PreProcessor.hs | 45 +++++++++++++++++------------ 1 file changed, 26 insertions(+), 19 deletions(-) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index d214f3fde5..44b4284d74 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -9,6 +9,7 @@ import qualified Data.List.NonEmpty as NEL import Data.String import Data.Maybe import Data.Bool +import Data.Char import Data.Either import Data.Functor import Control.Monad hiding (guard) @@ -18,6 +19,8 @@ import Text.Parsec.Error import Prelude import Ampersand.Input.ADL1.CtxError +import Debug.Trace + type PreProcDefine = String -- Shim that changes our 'Either ParseError a' from preProcess' into 'Guarded a' @@ -51,7 +54,7 @@ guard :: Guard -> String guard (Guard x) = x data LexLine = CodeLine String - | IncludeLine String (Maybe String) + | IncludeLine String String | IfNotStart Guard | IfStart Guard | ElseClause @@ -59,12 +62,12 @@ data LexLine = CodeLine String instance Show LexLine where show = showLex showLex :: LexLine -> String -showLex (CodeLine x) = x -showLex (IncludeLine x y) = x ++ " " ++ maybe "" id y -showLex (IfNotStart x) = "IFNOT " ++ guard x -showLex (IfStart x) = "IF " ++ guard x -showLex (ElseClause) = "ELSE" -showLex (EndIf) = "ENDIF" +showLex (CodeLine x) = "LEX: CODELINE " ++ x +showLex (IncludeLine x y) = "LEX: INCLUDE " ++ x ++ "--#" ++ y +showLex (IfNotStart x) = "LEX: IFNOT " ++ guard x +showLex (IfStart x) = "LEX: IF " ++ guard x +showLex (ElseClause) = "LEX: ELSE" +showLex (EndIf) = "LEX: ENDIF" type Lexer a = Parsec String () a @@ -78,13 +81,17 @@ lexLine :: Lexer LexLine lexLine = preProcDirective <|> includeLine <|> codeLine codeLine :: Lexer LexLine -codeLine = CodeLine <$> untilEOL +codeLine = (traceShowId . CodeLine) <$> untilEOL includeLine :: Lexer LexLine includeLine = do { ; spaces' <- try (many space <* string "INCLUDE") - ; included <- manyTill anyChar (lookAhead . try $ (( (:[]) <$> endOfLine) <|> string "--#")) - ; flags <- optionMaybe $ (try . string $ "--#") *> untilEOL + ; included <- manyTill anyChar ((lookAhead . try ) + ( return () <$> string "--#" + <|> return () <$> endOfLine + ) + ) + ; flags <- string "--#" *> untilEOL <|> endOfLine *> return "" ; return $ IncludeLine (spaces' ++ "INCLUDE" ++ included) flags } @@ -100,10 +107,10 @@ preProcDirective = (try preProcPrefix) *> -- This pattern signifies the line is meant for the preProcessor. -- Lines that don't start with this pattern are 'CodeLine's preProcPrefix :: Lexer () -preProcPrefix = spaces *> string "--" *> many (char '-') *> spaces *> char '#' *> spaces +preProcPrefix = whitespace *> string "--" *> many (char '-') *> whitespace *> char '#' *> whitespace ifGuard :: Lexer LexLine -ifGuard = (IfStart . Guard) <$> +ifGuard = (traceShowId . IfStart . Guard) <$> (try(string "IF") *> whitespace *> some alphaNum <* @@ -111,7 +118,7 @@ ifGuard = (IfStart . Guard) <$> ) ifNotGuard :: Lexer LexLine -ifNotGuard = (IfNotStart . Guard) <$> +ifNotGuard = (traceShowId . IfNotStart . Guard) <$> (try(string "IFNOT") *> whitespace *> some alphaNum <* @@ -126,7 +133,7 @@ ifEnd = (const EndIf) <$> (try(string "ENDIF") *> untilEOL) -- Helper Lexers whitespace :: Lexer () -whitespace = skipMany1 space +whitespace = skipMany1 $ satisfy (\x -> isSpace x && not (x == '\n' || x == '\r')) untilEOL :: Lexer String untilEOL = manyTill anyChar endOfLine @@ -135,7 +142,7 @@ untilEOL = manyTill anyChar endOfLine -- | A block element is either a normal line, or a Guarded Block (i.e. an IF or IFNOT block) data BlockElem = LineElem String - | IncludeElem String (Maybe String) + | IncludeElem String String | GuardedElem GuardedBlock -- These cover IF and IFNOT blocks type Block = [ BlockElem ] @@ -238,10 +245,9 @@ blockElem2string :: [PreProcDefine] -- ^ flags, the list of active flags -> BlockElem -- ^ blockElem, the block element to render -> String blockElem2string _ True (LineElem line) = line ++ "\n" -blockElem2string _ True (IncludeElem line flags) = line ++ " " ++ fromMaybe "" flags ++ "\n" +blockElem2string _ True (IncludeElem line flags) = line ++ " " ++ flags ++ "\n" blockElem2string _ False (LineElem line) = "--hiden by preprocc " ++ line ++ "\n" -blockElem2string _ False (IncludeElem line flags) = "--hiden by preprocc " ++ line ++ - " " ++ fromMaybe "" flags ++ "\n" +blockElem2string _ False (IncludeElem line flags) = "--hiden by preprocc " ++ line ++ " " ++ flags ++ "\n" blockElem2string defs showing (GuardedElem guardedElem) = showGuardedBlock defs showing guardedElem -- | Renders a GuardedBlock @@ -268,4 +274,5 @@ showElse :: [PreProcDefine] -> Bool -> Maybe Block -> String showElse defs showing = maybe "" (("--#ELSE\n" ++) . block2file defs showing) xor :: Bool -> Bool -> Bool -xor p q = (p || q) && not (p && q) \ No newline at end of file +xor p q = (p || q) && not (p && q) + From f27f0eeae33951b692f8c410d543e4dac0aeaad2 Mon Sep 17 00:00:00 2001 From: bart Date: Tue, 11 Dec 2018 12:53:21 +0100 Subject: [PATCH 024/131] Remove debug statement that were left in. --- src/Ampersand/Input/PreProcessor.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index 44b4284d74..fb0174fbc5 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -19,8 +19,6 @@ import Text.Parsec.Error import Prelude import Ampersand.Input.ADL1.CtxError -import Debug.Trace - type PreProcDefine = String -- Shim that changes our 'Either ParseError a' from preProcess' into 'Guarded a' @@ -81,7 +79,7 @@ lexLine :: Lexer LexLine lexLine = preProcDirective <|> includeLine <|> codeLine codeLine :: Lexer LexLine -codeLine = (traceShowId . CodeLine) <$> untilEOL +codeLine = CodeLine <$> untilEOL includeLine :: Lexer LexLine includeLine = do { @@ -110,7 +108,7 @@ preProcPrefix :: Lexer () preProcPrefix = whitespace *> string "--" *> many (char '-') *> whitespace *> char '#' *> whitespace ifGuard :: Lexer LexLine -ifGuard = (traceShowId . IfStart . Guard) <$> +ifGuard = (IfStart . Guard) <$> (try(string "IF") *> whitespace *> some alphaNum <* @@ -118,7 +116,7 @@ ifGuard = (traceShowId . IfStart . Guard) <$> ) ifNotGuard :: Lexer LexLine -ifNotGuard = (traceShowId . IfNotStart . Guard) <$> +ifNotGuard = (IfNotStart . Guard) <$> (try(string "IFNOT") *> whitespace *> some alphaNum <* From dd734eab6d4eec63111964aa411903f3b1096866 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink <> Date: Tue, 3 Jul 2018 11:44:59 +0200 Subject: [PATCH 025/131] Revert "Comment out solution for #792. Implementation in Prototype framework takes longer than expected." This reverts commit be25e5ef22c14511ff1f41795c7660026fa38f60. --- ReleaseNotes.md | 1 + src/Ampersand/Prototype/GenFrontend.hs | 4 +--- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 1d6b103e05..f56eefc7ed 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -4,6 +4,7 @@ * Add semantics to difference in API or INTERFACE keywords. * Add 'public' folder in prototype directory to better distinguish between public and non-public scripts. If used, requires change in 'customizations' folder +* [Issue #792](https://github.com/AmpersandTarski/Ampersand/issues/792) Add possibility to extend TXT in interfaces ## v3.11.5 (23 november 2018) diff --git a/src/Ampersand/Prototype/GenFrontend.hs b/src/Ampersand/Prototype/GenFrontend.hs index 61c8cb59f2..09201804e3 100644 --- a/src/Ampersand/Prototype/GenFrontend.hs +++ b/src/Ampersand/Prototype/GenFrontend.hs @@ -369,14 +369,12 @@ genViewObject fSpec depth obj@FEObjE{} = , subObjContents = intercalate "\n" lns , subObjExprIsUni = exprIsUni subObj } - FEObjT{} -> fatal "No view for TXT-like objects is defined." -{- Code already in place. Wait for Prototype framework to implement backend + FEObjT{} -> do return SubObjAttr{ subObjName = escapeIdentifier $ objName subObj , subObjLabel = objName subObj , subObjContents = objTxt subObj , subObjExprIsUni = True } --} getTemplateForObject :: IO FilePath getTemplateForObject | relIsProp obj && (not . exprIsIdent) obj -- special 'checkbox-like' template for propery relations From 0f9e377a4607a22954da2ea8fa5133ea03366ee2 Mon Sep 17 00:00:00 2001 From: Rieks Date: Thu, 13 Dec 2018 07:50:54 +0100 Subject: [PATCH 026/131] Testfiles for preprocessor --- .../prototype/shouldSucceed/PreprocTest1.adl | 32 ++++++++++ .../shouldSucceed/PreprocTestPopulation.adl | 49 ++++++++++++++ .../prototype/shouldSucceed/Preprocessor.adl | 64 +++++++++++++++++++ 3 files changed, 145 insertions(+) create mode 100644 testing/Travis/testcases/prototype/shouldSucceed/PreprocTest1.adl create mode 100644 testing/Travis/testcases/prototype/shouldSucceed/PreprocTestPopulation.adl create mode 100644 testing/Travis/testcases/prototype/shouldSucceed/Preprocessor.adl diff --git a/testing/Travis/testcases/prototype/shouldSucceed/PreprocTest1.adl b/testing/Travis/testcases/prototype/shouldSucceed/PreprocTest1.adl new file mode 100644 index 0000000000..91111856d2 --- /dev/null +++ b/testing/Travis/testcases/prototype/shouldSucceed/PreprocTest1.adl @@ -0,0 +1,32 @@ +CONTEXT "PreprocTest1" + +INCLUDE "./PreprocTestPopulation.adl" --# [ "!GenerateErrorIfThisVarIsSet" ] + +r1 :: A * B1 +r2 :: A * B2 + +INTERFACE "Test": I[SESSION] cRud BOX + [ "Vars": V[SESSION*Var] cRud + , "NoVars": V[SESSION*NoVar] cRud + , "Ifc" : V[SESSION*A] cRud BOX + [ "A = ": I cRud +--#IF EditableInterfaceA + --#IFNOT DoNotShowR1 + , "r1": r1 cRUd + --# ENDIF + --#IF ShowR2 + , "r2": r2 cRUd + --#ENDIF +--#ENDIF +--#IFNOT EditableInterfaceA + --#IFNOT DoNotShowR1 + , "r1": r1 cRud + --#ENDIF + --#IF ShowR2 + , "r2": r2 cRud + --#ENDIF +--#ENDIF + ] + ] + +ENDCONTEXT \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldSucceed/PreprocTestPopulation.adl b/testing/Travis/testcases/prototype/shouldSucceed/PreprocTestPopulation.adl new file mode 100644 index 0000000000..a5bbef3484 --- /dev/null +++ b/testing/Travis/testcases/prototype/shouldSucceed/PreprocTestPopulation.adl @@ -0,0 +1,49 @@ +CONTEXT PreprocTestPopulation + +--#IFNOT SpecifyDefPop +POPULATION NoVar CONTAINS [ "SpecifyDefPop" ] +--#ELSE +POPULATION Var CONTAINS [ "SpecifyDefPop" ] + +POPULATION r1 CONTAINS [ ("a1","b1.1")] +POPULATION r1 CONTAINS [ ("a1","b1.2")] +POPULATION r1 CONTAINS [ ("a2","b1.3")] +POPULATION r1 CONTAINS [ ("a2","b1.4")] + +POPULATION r2 CONTAINS [ ("a2","b2.1")] +POPULATION r2 CONTAINS [ ("a2","b2.2")] +POPULATION r2 CONTAINS [ ("a3","b2.3")] +POPULATION r2 CONTAINS [ ("a3","b2.4")] +--#ENDIF + +--#IF GenerateErrorIfThisVarIsSet +"The preprocessor has a bug if this line produces an error" +--#ENDIF + +--#IF EditableInterfaceA +POPULATION Var CONTAINS [ "EditableInterfaceA" ] +--#ELSE +POPULATION NoVar CONTAINS [ "EditableInterfaceA" ] +--#ENDIF +--#IF DoNotShowR1 +POPULATION Var CONTAINS [ "DoNotShowR1" ] +--#ELSE +POPULATION NoVar CONTAINS [ "DoNotShowR1" ] +--#ENDIF +--#IF ShowR2 +POPULATION Var CONTAINS [ "ShowR2" ] +--#ELSE +POPULATION NoVar CONTAINS [ "ShowR2" ] +--#ENDIF +--#IF Debugging +POPULATION Var CONTAINS [ "Debugging" ] +--#ELSE +POPULATION NoVar CONTAINS [ "Debugging" ] +--#ENDIF +--#IF Ontluizen +POPULATION Var CONTAINS [ "Ontluizen" ] +--#ELSE +POPULATION NoVar CONTAINS [ "Ontluizen" ] +--#ENDIF + +ENDCONTEXT \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldSucceed/Preprocessor.adl b/testing/Travis/testcases/prototype/shouldSucceed/Preprocessor.adl new file mode 100644 index 0000000000..68c8c05f9e --- /dev/null +++ b/testing/Travis/testcases/prototype/shouldSucceed/Preprocessor.adl @@ -0,0 +1,64 @@ +CONTEXT "Preprocessor" IN DUTCH +PURPOSE CONTEXT "Preprocessor" +{+The purpose of this application is to provide some (limited) testing +of the functionality of the Ampersand Preprocessor. + +The purpose of the preprocessor is to allow parts of a script to be conditionally ignored, +which enables developers to conditionally implement features/capabilities in their applications +without them having to maintain lots of different files, as would have been the case without the preprocessor. + +This functionality should be (or will be) backwards compatible, +which means that files that do not use preprocessor-specific syntax will be compiled as usual, +and files that use preprocessor-specific syntax can also be interpreted by ampersand versions that do not have the preprocessor, +provided they do not use the preprocessor to resolve conflicts of rules. + +At the time of writing, the preprocssor specifications are as follows: + +A line of text, that + (a) starts with optional whitespace, + (b) is followed by 2 or more `-` characters, (nu is dat 2 `-` chars) + (c) is followed by optional whitespace, (dat mag nu nog niet) + (d) is followed by `#` and + (e) is followed with optional whitespace, + is not interpreted by the Ampersand parser, but is passed to the Preprocessor instead. +The text behind the `#`-character up till the end of the line is the `TextToBePreprocessed`. +`TextToBePreprocessed` is defined by the (PCRE) regex `^\s*--+\s*#\s*(?P.*)$`. +Note that Ampersand versions that do not support preprocessing will treat such texts as comment. + +A preprocessor Keyword is the first word in `TextToBePreprocessed`. +`Keyword` is defined by the (PCRE) regex `(?P\w+\b)` when it is applied to `TextToBePreprocessed`. +In absolute terms, that would be `^\s*--+\s*#\s*(?P\w+\b).*$` +followed by optional whitespace and keyword consisting of alphanumeric characters. +Keywords are (thus) case sensitive. +Examples: `--#IF Debugging` or ` -- # ENDIF` + +Currently, valid keyword syntax is as follows (the (PCRE) regexes are assumed to be applied on `TextToBePreprocessed`): +- `IF`, `IFNOT` each take one argument - a variable. + Formally, this is defined by (PCRE) regex `(?PIF|IFNOT)\s+(?P\w+)`. + Examples `--#IF Debugging` or `--#IFNOT UserSpecifiesLoginMethod` +- `ELSE` and `ENDIF` do not take arguments. +The preprocessor treats any text following these syntaxes as comments (i.e.: ignores such texts) + +Also the syntax of `INCLUDE` statements is extended to include an optional comment that specifies a list of quoted variable names. +Example `INCLUDE "../SIAMv3/Login.ifc" --# [ "Debugging", "NoLogout" ]`. +The (PCRE) regex is `\bINCLUDE\s+"(?P[^"]+)"(\s+(--#\s*)?\[\s*"(?P!?\w+)"(\s*,\s*"(?P!?\w+)")*\])?` +where any text in groups `var1` or `var2` are variable names that may (optionally) be preceeded with a `!` character. +For each such variable names, a variable is created that can be referenced by its name. +When the variable name was preceeded with a `!` character, its value is initialized as 'false'; +When the variable name was not preceeded with a `!` character, its value is initialized as 'true'; +If a variable with a specified name was already created, the newly created variable takes precedence. +After a file inclusion terminates, the variables that the INCLUDE statement created are all destroyed. + +When the preprocessor parses the file that is `INCLUDE`d, +preprocessor commands that evaluate a variable (such as `IF` or `IFNOT`) +will use the value as defined in that `INCLUDE` statement +or (recursively) in that of a 'higher' `INCLUDE` statement. + +Files in this project contain examples of the syntax that explain the use. ++} + + -- This line should be treated as comment, and not as a --#preprocessor statement. + +INCLUDE "./PreprocTest1.adl" --# [ "ShowR2", "DoNotShowR1", "EditableInterfaceA", "GenerateErrorIfThisVarIsSet" ] --dit is een test + +ENDCONTEXT \ No newline at end of file From 6ce9fd72d715745c868cfbc796958f9b9a2e78a5 Mon Sep 17 00:00:00 2001 From: Rieks Date: Thu, 13 Dec 2018 08:28:26 +0100 Subject: [PATCH 027/131] Update na lesje van Han over testcases schrijven --- .../{prototype/shouldSucceed => Preprocessor}/Preprocessor.adl | 2 +- .../PreprocTest1.adl => Preprocessor/includes/PreprocTest.adl} | 0 .../includes}/PreprocTestPopulation.adl | 0 testing/Travis/testcases/Preprocessor/testinfo.yaml | 2 ++ 4 files changed, 3 insertions(+), 1 deletion(-) rename testing/Travis/testcases/{prototype/shouldSucceed => Preprocessor}/Preprocessor.adl (96%) rename testing/Travis/testcases/{prototype/shouldSucceed/PreprocTest1.adl => Preprocessor/includes/PreprocTest.adl} (100%) rename testing/Travis/testcases/{prototype/shouldSucceed => Preprocessor/includes}/PreprocTestPopulation.adl (100%) create mode 100644 testing/Travis/testcases/Preprocessor/testinfo.yaml diff --git a/testing/Travis/testcases/prototype/shouldSucceed/Preprocessor.adl b/testing/Travis/testcases/Preprocessor/Preprocessor.adl similarity index 96% rename from testing/Travis/testcases/prototype/shouldSucceed/Preprocessor.adl rename to testing/Travis/testcases/Preprocessor/Preprocessor.adl index 68c8c05f9e..e84df64e0c 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/Preprocessor.adl +++ b/testing/Travis/testcases/Preprocessor/Preprocessor.adl @@ -59,6 +59,6 @@ Files in this project contain examples of the syntax that explain the use. -- This line should be treated as comment, and not as a --#preprocessor statement. -INCLUDE "./PreprocTest1.adl" --# [ "ShowR2", "DoNotShowR1", "EditableInterfaceA", "GenerateErrorIfThisVarIsSet" ] --dit is een test +INCLUDE "./includes/PreprocTest.adl" --# [ "ShowR2", "DoNotShowR1", "EditableInterfaceA", "GenerateErrorIfThisVarIsSet" ] --dit is een test ENDCONTEXT \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldSucceed/PreprocTest1.adl b/testing/Travis/testcases/Preprocessor/includes/PreprocTest.adl similarity index 100% rename from testing/Travis/testcases/prototype/shouldSucceed/PreprocTest1.adl rename to testing/Travis/testcases/Preprocessor/includes/PreprocTest.adl diff --git a/testing/Travis/testcases/prototype/shouldSucceed/PreprocTestPopulation.adl b/testing/Travis/testcases/Preprocessor/includes/PreprocTestPopulation.adl similarity index 100% rename from testing/Travis/testcases/prototype/shouldSucceed/PreprocTestPopulation.adl rename to testing/Travis/testcases/Preprocessor/includes/PreprocTestPopulation.adl diff --git a/testing/Travis/testcases/Preprocessor/testinfo.yaml b/testing/Travis/testcases/Preprocessor/testinfo.yaml new file mode 100644 index 0000000000..2aa18756f4 --- /dev/null +++ b/testing/Travis/testcases/Preprocessor/testinfo.yaml @@ -0,0 +1,2 @@ +command : ampersand --verbose +shouldSucceed : yes From c2cb6cf82c1fd68029697ef46179d3d3492203c1 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink <> Date: Fri, 14 Dec 2018 07:51:06 +0100 Subject: [PATCH 028/131] Add id and label to interface object output --- src/Ampersand/Output/ToJSON/Interfaces.hs | 74 ++++++++++++----------- 1 file changed, 39 insertions(+), 35 deletions(-) diff --git a/src/Ampersand/Output/ToJSON/Interfaces.hs b/src/Ampersand/Output/ToJSON/Interfaces.hs index 8878a8fb59..09801fe0bb 100644 --- a/src/Ampersand/Output/ToJSON/Interfaces.hs +++ b/src/Ampersand/Output/ToJSON/Interfaces.hs @@ -11,24 +11,26 @@ import Ampersand.FSpec.ToFSpec.Calc data Interfaces = Interfaces [JSONInterface] deriving (Generic, Show) data JSONInterface = JSONInterface - { ifcJSONinterfaceRoles :: [String] + { ifcJSONid :: String + , ifcJSONlabel :: String + , ifcJSONinterfaceRoles :: [String] , ifcJSONboxClass :: Maybe String , ifcJSONifcObject :: JSONObjectDef , ifcJSONisAPI :: Bool } deriving (Generic, Show) data JSONObjectDef = JSONObjectDef - { ifcJSONtype :: String - , ifcJSONtxt :: Maybe String - , ifcJSONid :: String - , ifcJSONlabel :: String - , ifcJSONviewId :: Maybe String - , ifcJSONNormalizationSteps :: Maybe [String] -- Not used in frontend. Just informative for analisys - , ifcJSONrelation :: Maybe String - , ifcJSONrelationIsFlipped :: Maybe Bool - , ifcJSONcrud :: Maybe JSONCruds - , ifcJSONexpr :: Maybe JSONexpr - , ifcJSONsubinterfaces :: Maybe JSONSubInterface + { ifcobjJSONtype :: String + , ifcobjJSONtxt :: Maybe String + , ifcobjJSONid :: String + , ifcobjJSONlabel :: String + , ifcobjJSONviewId :: Maybe String + , ifcobjJSONNormalizationSteps :: Maybe [String] -- Not used in frontend. Just informative for analisys + , ifcobjJSONrelation :: Maybe String + , ifcobjJSONrelationIsFlipped :: Maybe Bool + , ifcobjJSONcrud :: Maybe JSONCruds + , ifcobjJSONexpr :: Maybe JSONexpr + , ifcobjJSONsubinterfaces :: Maybe JSONSubInterface } deriving (Generic, Show) data JSONSubInterface = JSONSubInterface { subJSONboxClass :: Maybe String @@ -85,7 +87,9 @@ instance JSON SubInterface JSONSubInterface where } instance JSON Interface JSONInterface where fromAmpersand multi interface = JSONInterface - { ifcJSONinterfaceRoles = map name . ifcRoles $ interface + { ifcJSONid = escapeIdentifier . ifcname $ interface + , ifcJSONlabel = ifcname interface + , ifcJSONinterfaceRoles = map name . ifcRoles $ interface , ifcJSONboxClass = Nothing -- todo, fill with box class of toplevel ifc box , ifcJSONifcObject = fromAmpersand multi (BxExpr $ ifcObj interface) , ifcJSONisAPI = ifcIsAPI interface @@ -124,17 +128,17 @@ instance JSON BoxItem JSONObjectDef where fromAmpersand multi obj = case obj of BxExpr object' -> JSONObjectDef - { ifcJSONtype = "ObjExpression" - , ifcJSONid = escapeIdentifier . name $ object - , ifcJSONlabel = name object - , ifcJSONviewId = fmap name viewToUse - , ifcJSONNormalizationSteps = Just $ showPrf showA.cfProof.objExpression $ object - , ifcJSONrelation = fmap (showRel . fst) mEditableDecl - , ifcJSONrelationIsFlipped = fmap snd mEditableDecl - , ifcJSONcrud = Just $ fromAmpersand multi (objcrud object) - , ifcJSONexpr = Just $ fromAmpersand multi object - , ifcJSONsubinterfaces = fmap (fromAmpersand multi) (objmsub object) - , ifcJSONtxt = Nothing + { ifcobjJSONtype = "ObjExpression" + , ifcobjJSONid = escapeIdentifier . name $ object + , ifcobjJSONlabel = name object + , ifcobjJSONviewId = fmap name viewToUse + , ifcobjJSONNormalizationSteps = Just $ showPrf showA.cfProof.objExpression $ object + , ifcobjJSONrelation = fmap (showRel . fst) mEditableDecl + , ifcobjJSONrelationIsFlipped = fmap snd mEditableDecl + , ifcobjJSONcrud = Just $ fromAmpersand multi (objcrud object) + , ifcobjJSONexpr = Just $ fromAmpersand multi object + , ifcobjJSONsubinterfaces = fmap (fromAmpersand multi) (objmsub object) + , ifcobjJSONtxt = Nothing } where opts = getOpts fSpec @@ -150,15 +154,15 @@ instance JSON BoxItem JSONObjectDef where Nothing -> (target normalizedInterfaceExp, Nothing) -- fall back to typechecker type object = substituteReferenceObjectDef fSpec object' BxTxt object -> JSONObjectDef - { ifcJSONtype = "ObjText" - , ifcJSONid = escapeIdentifier . name $ object - , ifcJSONlabel = name object - , ifcJSONviewId = Nothing - , ifcJSONNormalizationSteps = Nothing - , ifcJSONrelation = Nothing - , ifcJSONrelationIsFlipped = Nothing - , ifcJSONcrud = Nothing - , ifcJSONexpr = Nothing - , ifcJSONsubinterfaces = Nothing - , ifcJSONtxt = Just $ objtxt object + { ifcobjJSONtype = "ObjText" + , ifcobjJSONid = escapeIdentifier . name $ object + , ifcobjJSONlabel = name object + , ifcobjJSONviewId = Nothing + , ifcobjJSONNormalizationSteps = Nothing + , ifcobjJSONrelation = Nothing + , ifcobjJSONrelationIsFlipped = Nothing + , ifcobjJSONcrud = Nothing + , ifcobjJSONexpr = Nothing + , ifcobjJSONsubinterfaces = Nothing + , ifcobjJSONtxt = Just $ objtxt object } From ab20b9db300c41fe675826fb1a4491f7894e54f2 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Mon, 17 Dec 2018 17:54:20 +0100 Subject: [PATCH 029/131] Remove garbage --- src/Ampersand/Classes/Relational.hs.orig | 271 ----------------------- 1 file changed, 271 deletions(-) delete mode 100644 src/Ampersand/Classes/Relational.hs.orig diff --git a/src/Ampersand/Classes/Relational.hs.orig b/src/Ampersand/Classes/Relational.hs.orig deleted file mode 100644 index 464811fd69..0000000000 --- a/src/Ampersand/Classes/Relational.hs.orig +++ /dev/null @@ -1,271 +0,0 @@ -module Ampersand.Classes.Relational - ( HasProps(..) - , Relational(..) - ) where - -import Ampersand.ADL1 -import Ampersand.Basics -import Ampersand.Core.ParseTree(Prop(..),Props) -import Data.Maybe -import qualified Data.Set as Set - -class HasProps r where - properties :: r -> Props -class Relational r where - isProp :: r -> Bool -- > tells whether the argument is a property - isImin :: r -> Bool -- > tells whether the argument is equivalent to I- - isTrue :: r -> Bool -- > tells whether the argument is equivalent to V - isFalse :: r -> Bool -- > tells whether the argument is equivalent to V- - isFunction :: r -> Bool - isTot :: r -> Bool -- - isUni :: r -> Bool -- - isSur :: r -> Bool -- - isInj :: r -> Bool -- - isRfx :: r -> Bool -- - isIrf :: r -> Bool -- - isTrn :: r -> Bool -- - isSym :: r -> Bool -- - isAsy :: r -> Bool -- - isIdent :: r -> Bool -- > tells whether the argument is equivalent to I - isEpsilon :: r -> Bool -- > tells whether the argument is equivalent to I - -instance HasProps Relation where - properties d = fromMaybe (decprps d) (decprps_calc d) - -isSingleton :: A_Concept -> Bool -isSingleton ONE = True -isSingleton _ = False - --- The function "properties" does not only provide the properties provided by the Ampersand user, --- but tries to derive the most obvious multiplicity constraints as well. The more multiplicity constraints are known, --- the better the data structure that is derived. --- Not every constraint that can be proven is obtained by this function. This does not hurt Ampersand. -properties' :: Expression -> Props -properties' expr = case expr of - EDcD dcl -> properties dcl - EDcI{} -> Set.fromList [Uni,Tot,Inj,Sur,Sym,Asy,Trn,Rfx] - EEps a sgn -> Set.fromList $ [Tot | a == source sgn]++[Sur | a == target sgn] ++ [Uni,Inj] - EDcV sgn -> Set.fromList $ - [Tot] - ++[Sur] - ++[Inj | isSingleton (source sgn)] - ++[Uni | isSingleton (target sgn)] - ++[Asy | isEndo sgn, isSingleton (source sgn)] - ++[Sym | isEndo sgn] - ++[Rfx | isEndo sgn] - ++[Trn | isEndo sgn] - EBrk f -> properties' f - ECps (l,r) -> Set.fromList $ [m | m<-Set.elems (properties' l `Set.intersection` properties' r) - , m `elem` [Uni,Tot,Inj,Sur]] -- endo properties can be used and deduced by and from rules: many rules are properties (TODO) - EPrd (l,r) -> Set.fromList $ [Tot | isTot l]++[Sur | isSur r]++[Rfx | isRfx l&&isRfx r]++[Trn] - EKl0 e' -> Set.fromList [Rfx,Trn] `Set.union` (properties' e' Set.\\ Set.fromList [Uni,Inj]) - EKl1 e' -> Set.singleton Trn `Set.union` (properties' e' Set.\\ Set.fromList [Uni,Inj]) - ECpl e' -> Set.singleton Sym `Set.intersection` properties' e' - EFlp e' -> Set.map flp $ properties' e' - EMp1{} -> Set.fromList [Uni,Inj,Sym,Asy,Trn] - _ -> Set.empty - -instance Relational Expression where -- TODO: see if we can find more multiplicity constraints... - -- | isTrue e == True means that e is true, i.e. the population of e is (source e * target e). - -- isTrue e == False does not mean anything. - -- the function isTrue is meant to produce a quick answer, without any form of theorem proving. - isTrue expr - = case expr of - EEqu (l,r) -> l == r - EInc (l,_) -> isTrue l - EIsc (l,r) -> isTrue l && isTrue r - EUni (l,r) -> isTrue l || isTrue r - EDif (l,r) -> isTrue l && isFalse r - ECps (l,r) | isUni l && isTot l -> isTrue r - -- | isSur r && isSur r -> isTrue l --HJO, 20180331: Disabled this statement, for it has probably been bitrotted??? - | otherwise -> isTrue l && isTrue r - EPrd (l,r) -> isTrue l && isTrue r || isTot l && isSur r || isRfx l && isRfx r - EKl0 e -> isTrue e - EKl1 e -> isTrue e - EFlp e -> isTrue e - ECpl e -> isFalse e - EDcD{} -> False - EDcI c -> isSingleton c - EEps i _ -> isSingleton i - EDcV{} -> True - EBrk e -> isTrue e - _ -> False -- TODO: find richer answers for ERrs, ELrs, EDia, ERad, and EMp1 - - -- | isFalse e == True means that e is false, i.e. the population of e is empty. - -- isFalse e == False does not mean anything. - -- the function isFalse is meant to produce a quick answer, without any form of theorem proving. - isFalse expr - = case expr of - EEqu (l,r) -> l == notCpl r - EInc (_,r) -> isFalse r - EIsc (l,r) -> isFalse r || isFalse l - EUni (l,r) -> isFalse r && isFalse l - EDif (l,r) -> isFalse l || isTrue r - ECps (l,r) -> isFalse r || isFalse l - EPrd (l,r) -> isFalse r || isFalse l - EKl0 e -> isFalse e - EKl1 e -> isFalse e - EFlp e -> isFalse e - ECpl e -> isTrue e - EDcD{} -> False - EDcI{} -> False - EEps{} -> False - EDcV{} -> False - EBrk e -> isFalse e - _ -> False -- TODO: find richer answers for ERrs, ELrs, EDia, and ERad - - isProp expr = isAsy expr && isSym expr - - -- | The function isIdent tries to establish whether an expression is an identity relation. - -- It does a little bit more than just test on ERel I _. - -- If it returns False, this must be interpreted as: the expression is definitely not I, an may not be equal to I as far as the computer can tell on face value. - isIdent expr = (\x -> if x && (source expr /= target expr) - then fatal $ "Something wrong with isIdent." ++ show expr - else x - ) $ - case expr of - EEqu (l,r) -> isIdent (EIsc (EInc (l,r), EInc (r,l))) -- TODO: maybe derive something better? - EInc (l,r) -> isIdent (EUni (ECpl l, r)) -- TODO: maybe derive something better? - EIsc (l,r) -> isIdent l && isIdent r - EUni (l,r) -> isIdent l && isIdent r - EDif (l,r) -> isIdent l && isFalse r - ECps (l,r) -> isIdent l && isIdent r - EKl0 e -> isIdent e || isFalse e - EKl1 e -> isIdent e - ECpl e -> isImin e - EDcD{} -> False - EDcI{} -> True - EEps{} -> False - EDcV sgn -> isEndo sgn && isSingleton (source sgn) - EBrk f -> isIdent f - EFlp f -> isIdent f - _ -> False -- TODO: find richer answers for ELrs, ERrs, EDia, EPrd, and ERad - isEpsilon e = case e of - EEps{} -> True - _ -> False - - isImin expr' = case expr' of -- > tells whether the argument is equivalent to I- - EEqu (l,r) -> isImin (EIsc (EInc (l,r), EInc (r,l))) -- TODO: maybe derive something better? - EInc (l,r) -> isImin (EUni (ECpl l, r)) -- TODO: maybe derive something better? - EIsc (l,r) -> isImin l && isImin r - EUni (l,r) -> isImin l && isImin r - EDif (l,r) -> isImin l && isFalse r - ECpl e -> isIdent e - EDcD{} -> False - EDcI{} -> False - EEps{} -> False - EDcV{} -> False - EBrk f -> isImin f - EFlp f -> isImin f - _ -> False -- TODO: find richer answers for ELrs, ERrs, and EDia - isFunction r = isUni r && isTot r - -<<<<<<< HEAD - isTot r = Tot `elem` properties r --- isUni r = Uni `elem` properties r - isUni = isUni' Uni - where - isUni' :: Prop -> Expression -> Bool - isUni' prop expr - = case expr of - EEqu (_,_) -> False - EInc (_,_) -> False - EIsc (l,r) -> isUni' prop l || isUni' prop r - EUni (_,_) -> z - EDif (l,_) -> isUni' prop l - ECps (l,r) -> isUni' prop l && isUni' prop r - EPrd (_,_) -> z - EKl0 e -> isUni' prop e - EKl1 e -> isUni' prop e - EFlp e -> isUni' (flp prop) e - ECpl _ -> z - ELrs _ -> z - ERrs _ -> z - EDia _ -> z - ERad _ -> z - EDcD d -> prop `elem` properties d - EDcI{} -> True - EEps{} -> True - EDcV{} -> z - EBrk e -> isUni' prop e - EMp1{} -> True - where - z = prop `elem` properties expr - isSur r = Sur `elem` properties r - isInj r = isUni (flp r) - isRfx r = Rfx `elem` properties r - isIrf r = Irf `elem` properties r - isTrn r = Trn `elem` properties r - isSym r = Sym `elem` properties r - isAsy r = Asy `elem` properties r -======= - isTot = isTotSur Tot - isSur = isTotSur Sur - - isUni = isUniInj Uni - isInj = isUniInj Inj - - isRfx r = Rfx `elem` properties' r - isIrf r = Irf `elem` properties' r - isTrn r = Trn `elem` properties' r - isSym r = Sym `elem` properties' r - isAsy r = Asy `elem` properties' r - --- Not to be exported: -isTotSur :: Prop -> Expression -> Bool -isTotSur prop expr - = case expr of - EEqu (_,_) -> False - EInc (_,_) -> False - EIsc (l,r) -> isTotSur prop l || isTotSur prop r - EUni (_,_) -> todo - EDif (l,_) -> isTotSur prop l - ECps (l,r) -> isTotSur prop l && isTotSur prop r - EPrd (_,_) -> todo - EKl0 e -> isTotSur prop e - EKl1 e -> isTotSur prop e - EFlp e -> isTotSur (flp prop) e - ECpl _ -> todo - ELrs _ -> todo - ERrs _ -> todo - EDia _ -> todo - ERad _ -> todo - EDcD d -> prop `elem` properties d - EDcI{} -> True - EEps c sgn -> case prop of - Tot -> c == source sgn - Sur -> c == target sgn - _ -> fatal $ "isTotSur must not be called with "++show prop - EDcV{} -> todo - EBrk e -> isTotSur prop e - EMp1{} -> True - where - todo = prop `elem` properties' expr - -isUniInj :: Prop -> Expression -> Bool -isUniInj prop expr - = case expr of - EEqu (_,_) -> False - EInc (_,_) -> False - EIsc (l,r) -> isUniInj prop l || isUniInj prop r - EUni (_,_) -> todo - EDif (l,_) -> isUniInj prop l - ECps (l,r) -> isUniInj prop l && isUniInj prop r - EPrd (_,_) -> todo - EKl0 e -> isUniInj prop e - EKl1 e -> isUniInj prop e - EFlp e -> isUniInj (flp prop) e - ECpl _ -> todo - ELrs _ -> todo - ERrs _ -> todo - EDia _ -> todo - ERad _ -> todo - EDcD d -> prop `elem` properties d - EDcI{} -> True - EEps{} -> True - EDcV{} -> todo - EBrk e -> isUniInj prop e - EMp1{} -> True - where - todo = prop `elem` properties' expr ->>>>>>> development From cff94e4042b418acc9afd8b5974ba50ded211b5d Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink <> Date: Thu, 20 Dec 2018 14:52:04 +0100 Subject: [PATCH 030/131] Only run composer install when clean install of prototype framework is downloaded --- ReleaseNotes.md | 1 + src/Ampersand/Prototype/GenFrontend.hs | 52 +++++++++++++++++++------- 2 files changed, 39 insertions(+), 14 deletions(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index b0f3015afd..6bb9bdf4de 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -2,6 +2,7 @@ ## Unreleased changes +* Only run composer install when clean install of prototype framework is downloaded * [Issue #855](https://github.com/AmpersandTarski/Ampersand/issues/855) Minor enhancement in CLASSIFY statement * Add semantics to difference in API or INTERFACE keywords. * Add 'public' folder in prototype directory to better distinguish between public and non-public scripts. If used, requires change in 'customizations' folder diff --git a/src/Ampersand/Prototype/GenFrontend.hs b/src/Ampersand/Prototype/GenFrontend.hs index 09201804e3..310fc8eb4d 100644 --- a/src/Ampersand/Prototype/GenFrontend.hs +++ b/src/Ampersand/Prototype/GenFrontend.hs @@ -13,6 +13,7 @@ import Codec.Archive.Zip import Control.Exception import Control.Monad import qualified Data.ByteString.Lazy as BL +import Data.Char import Data.Data import Data.List import Data.Maybe @@ -67,7 +68,7 @@ getTemplateDir fSpec = dirPrototype (getOpts fSpec) "templates" doGenFrontend :: FSpec -> IO () doGenFrontend fSpec = do { putStrLn "Generating frontend.." - ; downloadPrototypeFramework (getOpts fSpec) + ; isCleanInstall <- downloadPrototypeFramework (getOpts fSpec) ; copyTemplates fSpec ; feInterfaces <- buildInterfaces fSpec ; genViewInterfaces fSpec feInterfaces @@ -75,8 +76,9 @@ doGenFrontend fSpec = ; genRouteProvider fSpec feInterfaces ; copyCustomizations fSpec -- ; deleteTemplateDir fSpec -- don't delete template dir anymore, because it is required the next time the frontend is generated - ; putStrLn "Installing dependencies.." - ; installComposerLibs (getOpts fSpec) + ; when isCleanInstall $ do + putStrLn "Installing dependencies.." + installComposerLibs (getOpts fSpec) ; putStrLn "Frontend generated." } @@ -456,14 +458,14 @@ renderTemplate (Template template absPath) setAttrs = -downloadPrototypeFramework :: Options -> IO () +downloadPrototypeFramework :: Options -> IO Bool downloadPrototypeFramework opts = (do x <- allowExtraction - when x $ do - when (forceReinstallFramework opts) $ do - verboseLn opts $ "Emptying folder because redeploying prototype framework is forced" - destroyDestinationDir + if x + then do + verboseLn opts $ "Emptying folder to deploy prototype framework" + destroyDestinationDir verboseLn opts "Start downloading prototype framework." response <- parseRequest ("https://github.com/AmpersandTarski/Prototype/archive/"++zwolleVersion opts++".zip") >>= @@ -479,6 +481,8 @@ downloadPrototypeFramework opts = extractFilesFromArchive zipoptions archive writeFile (destination ".prototypeSHA") (show . zComment $ archive) + return x + else return x ) `catch` \err -> -- git failed to execute exitWith . FailedToInstallPrototypeFramework $ [ "Error encountered during deployment of prototype framework:" @@ -508,16 +512,36 @@ downloadPrototypeFramework opts = if destIsDirectory then do dirContents <- listDirectory destination - let emptyOrForced = (null dirContents) || (forceReinstallFramework opts) - unless emptyOrForced - (verboseLn opts $ + let emptyDir = null dirContents + let forceReinstall = forceReinstallFramework opts + if emptyDir + then return True + else do + if forceReinstall + then do + putStrLn "Deleting all files to deploy prototype framework in" + putStrLn (" " ++ destination) + putStrLn "Are you sure? y/n" + proceed <- promptUserYesNo + return proceed + else do + (verboseLn opts $ "(Re)deploying prototype framework not allowed, because\n" - ++ " "++destination++" isn't empty.") - return emptyOrForced + ++ " "++destination++" isn't empty. You could use the switch --force-reinstall-framework") + return False else do verboseLn opts $ "(Re)deploying prototype framework not allowed, because\n" ++ " "++destination++" isn't a directory." return False else return True - \ No newline at end of file + +promptUserYesNo :: IO Bool +promptUserYesNo = do + char <- getChar -- TODO: refactor that the first character is directly processed + case toUpper char of + 'Y' -> return True + 'N' -> return False + _ -> do when (char /= '\n') $ putStrLn "Please specify y/n" -- Remove 'when' part if first char it directly processed + x <- promptUserYesNo + return x \ No newline at end of file From 5f8cbc876c564cd235de472a33825d2f36da500f Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Fri, 21 Dec 2018 10:54:49 +0100 Subject: [PATCH 031/131] Add header for unreleased changes --- ReleaseNotes.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 46c427fd32..2df5387d3b 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,5 +1,7 @@ # Release notes of Ampersand +## Unreleased changes + ## v3.12.0 (21 december 2018) * [Issue #855](https://github.com/AmpersandTarski/Ampersand/issues/855) Minor enhancement in CLASSIFY statement From 85ae645c5650a4c4c53a169f1d341e279bbfc918 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Fri, 21 Dec 2018 08:32:18 +0100 Subject: [PATCH 032/131] bump version --- ReleaseNotes.md | 2 +- ampersand.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 7c9dac4b5e..46c427fd32 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,6 +1,6 @@ # Release notes of Ampersand -## Unreleased changes +## v3.12.0 (21 december 2018) * [Issue #855](https://github.com/AmpersandTarski/Ampersand/issues/855) Minor enhancement in CLASSIFY statement * Add semantics to difference in API or INTERFACE keywords. diff --git a/ampersand.cabal b/ampersand.cabal index ceb67e56a6..07cc2aba68 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -1,5 +1,5 @@ name: ampersand -version: 3.11.5 +version: 3.12.0 author: Stef Joosten maintainer: stef.joosten@ou.nl synopsis: Toolsuite for automated design of enterprise information systems. From cce35dd4c086a2f896ef8abfc47632e8955e5b24 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Fri, 21 Dec 2018 10:54:49 +0100 Subject: [PATCH 033/131] Add header for unreleased changes --- ReleaseNotes.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 46c427fd32..2df5387d3b 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,5 +1,7 @@ # Release notes of Ampersand +## Unreleased changes + ## v3.12.0 (21 december 2018) * [Issue #855](https://github.com/AmpersandTarski/Ampersand/issues/855) Minor enhancement in CLASSIFY statement From 07d6a0e40db9c9932edc9cef1d71c53390b8bb71 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sat, 22 Dec 2018 15:45:24 +0100 Subject: [PATCH 034/131] Some simplifications and a temporary fatal added --- ReleaseNotes.md | 2 + src/Ampersand/FSpec/FSpec.hs | 1 + src/Ampersand/FSpec/SQL.hs | 13 +++-- src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs | 10 ++-- src/Ampersand/Output/ToJSON/Relations.hs | 3 ++ .../shouldSucceed/validate/Issue862a.adl | 54 +++++++++++++++++++ 6 files changed, 72 insertions(+), 11 deletions(-) create mode 100644 testing/Travis/testcases/prototype/shouldSucceed/validate/Issue862a.adl diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 2df5387d3b..b73f81f189 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -2,6 +2,8 @@ ## Unreleased changes +* [Issue #862](https://github.com/AmpersandTarski/Ampersand/issues/862) Bug in generated SQL in several cases where CLASSIFY statements were involved in combination with relations with the INJ property. + ## v3.12.0 (21 december 2018) * [Issue #855](https://github.com/AmpersandTarski/Ampersand/issues/855) Minor enhancement in CLASSIFY statement diff --git a/src/Ampersand/FSpec/FSpec.hs b/src/Ampersand/FSpec/FSpec.hs index 40cd315b8d..35c7a6cb5c 100644 --- a/src/Ampersand/FSpec/FSpec.hs +++ b/src/Ampersand/FSpec/FSpec.hs @@ -293,6 +293,7 @@ getConceptTableFor fSpec c = case lookupCpt fSpec c of data RelStore = RelStore { rsDcl :: Relation + , rsStoredFlipped :: Bool , rsSrcAtt :: SqlAttribute , rsTrgAtt :: SqlAttribute } deriving (Show, Typeable) diff --git a/src/Ampersand/FSpec/SQL.hs b/src/Ampersand/FSpec/SQL.hs index da1b8b4cef..3d491b765b 100644 --- a/src/Ampersand/FSpec/SQL.hs +++ b/src/Ampersand/FSpec/SQL.hs @@ -340,7 +340,10 @@ nonSpecialSelectExpr fSpec expr= | otherwise = let part1 = makeIntersectSelectExpr (map fst esI ++ map fst esR) part2 = makeIntersectSelectExpr esRest - in traceComment ["Combination of optimized and non-optimized intersections"] + in traceComment ["Combination of optimized and non-optimized intersections" + ," part1 : "++(showA . foldl1 (./\.) $ map fst esI ++ map fst esR) + ," part2 : "++(showA . foldl1 (./\.) $ esRest) + ] BSE { bseSetQuantifier = SQDefault , bseSrc = Col { cTable = [] , cCol = [sourceAlias] @@ -1256,10 +1259,12 @@ broadQuery fSpec obj = isInBroadQuery :: Expression -> ObjectDef -> Bool isInBroadQuery ctxExpr sObj = - (isUni . objExpression $ sObj) - && (isJust . attThatisInTableOf (target . objExpression $ obj) $ sObj) + (isUni subExpr) + && (isJust . attThatisInTableOf (target subExpr) $ sObj) && (source ctxExpr /= target ctxExpr || null (primitives ctxExpr)) --this is required to prevent conflicts in rows of the same broad table. See explanation in issue #627 - && (target ctxExpr /= target (objExpression sObj) || (not . isFlipped . objExpression $ sObj)) -- see issue #760 for motivation of this line. + && (target ctxExpr /= target subExpr || (not . isFlipped $ subExpr)) -- see issue #760 for motivation of this line. + where + subExpr = objExpression sObj attThatisInTableOf :: A_Concept -> ObjectDef -> Maybe SqlAttribute attThatisInTableOf cpt od = diff --git a/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs b/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs index 11eccc1920..604de53519 100644 --- a/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs +++ b/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs @@ -69,10 +69,12 @@ makeGeneratedSqlPlugs opts context calcProps = conceptTables ++ linkTables where f d = if isStoredFlipped d then RelStore { rsDcl = d + , rsStoredFlipped = isStoredFlipped d , rsSrcAtt = dclAttrib d , rsTrgAtt = lookupC (target d) } else RelStore { rsDcl = d + , rsStoredFlipped = isStoredFlipped d , rsSrcAtt = lookupC (source d) , rsTrgAtt = dclAttrib d } @@ -221,13 +223,7 @@ wayToStore dcl = case (isInj d, isUni d) of (False , False ) -> Nothing --Will become a link-table (True , False ) -> Just flipped - (False , True ) -> Just plain - (True , True ) -> - case (isTot d, isSur d) of - (False , False ) -> Just plain - (True , False ) -> Just plain - (False , True ) -> Just plain - (True , True ) -> Just plain + (_ , True ) -> Just plain where d = EDcD dcl plain = (source d,False) flipped = (target d, True) diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index 77f70bce70..e1c8c111d7 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -72,7 +72,10 @@ instance JSON Relation RelTableInfo where (plug,srcAtt,trgAtt) = getRelationTableInfo fSpec dcl (plugSrc,_) = getConceptTableInfo fSpec (source dcl) (plugTrg,_) = getConceptTableInfo fSpec (target dcl) + -- relStore = filter isDcl . dLkpTbl $ plug + -- isDcl rs = rsDcl rs == dcl srcOrtgt + | plugSrc == plugTrg = fatal "TODO: See issue #864." | plug == plugSrc = Just "src" | plug == plugTrg = Just "tgt" | otherwise = Nothing diff --git a/testing/Travis/testcases/prototype/shouldSucceed/validate/Issue862a.adl b/testing/Travis/testcases/prototype/shouldSucceed/validate/Issue862a.adl new file mode 100644 index 0000000000..a20aeeaa4b --- /dev/null +++ b/testing/Travis/testcases/prototype/shouldSucceed/validate/Issue862a.adl @@ -0,0 +1,54 @@ +CONTEXT "Issue862a" IN ENGLISH +PURPOSE CONTEXT "Issue862a" +{+This context has a lot of relations with different properties, that are implemented in a single broad table.+} + +RELATION father [Person * Person] [UNI] +RELATION mothersChilds [Female * Person] [INJ] --this relation is the flipped 'mother' relation +RELATION isMale [Male * Male] [PROP] + + +CLASSIFY Female ISA Person +CLASSIFY Male ISA Person +POPULATION isMale CONTAINS + [ ("Rieks","Rieks") + , ("Stef","Stef") + , ("Han","Han") + , ("Pierre","Pierre") + , ("Bas","Bas") + , ("Harry","Harry") + , ("Timo", "Timo") + ] + +POPULATION father CONTAINS + [ ("Rieks", "Pierre") + , ("Stef", "Pierre") + , ("Han", "Pierre") + , ("Marian", "Pierre") + , ("Pierre", "Harry") + , ("Bas", "Stef") + , ("Suzanne", "Timo") + ] +POPULATION mothersChilds CONTAINS + [ ("Tiny","Rieks") + , ("Tiny","Stef") + , ("Tiny","Han") + , ("Tiny","Marian") + , ("Kate","Pierre") + , ("Janny","Bas") + , ("Marian","Suzanne") + ] + +INTERFACE "Persons": V[SESSION*Person] cRud BOX + [ persons: I ] + +INTERFACE "Person": I[Person] cRud BOX + [ person : I[Person] + , isMale : I[Male] + , father : father + , mother : mothersChilds~ + , kidsOfThisFather : father~ + , kidsOfThisMother : mothersChilds +-- , daughters : (I[Female] /\ (father;father~)) \/ +-- (I[Female] /\ (mothersChilds;mothersChilds~)) + ] +ENDCONTEXT \ No newline at end of file From 5e717b23c43dde6c9581aba881830f445a3145c8 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink <> Date: Sun, 23 Dec 2018 16:01:28 +0100 Subject: [PATCH 035/131] Rename and flatten fields in settings.json output --- src/Ampersand/Output/ToJSON/Settings.hs | 45 ++++++++++--------------- 1 file changed, 17 insertions(+), 28 deletions(-) diff --git a/src/Ampersand/Output/ToJSON/Settings.hs b/src/Ampersand/Output/ToJSON/Settings.hs index 3b853162cc..872770eb34 100644 --- a/src/Ampersand/Output/ToJSON/Settings.hs +++ b/src/Ampersand/Output/ToJSON/Settings.hs @@ -8,38 +8,27 @@ import Data.Hashable import qualified Data.Text as Text data Settings = Settings - { sngJSONversionInfo :: String - , sngJSONcontextName :: String - , sngJSONmysqlSettings :: MySQLSettings - , sngJSONenvironment :: String - , sngJSONmodelHash :: String + { sngJSONglobal_contextName :: String + , sngJSONmysql_dbHost :: String + , sngJSONmysql_dbName :: String + , sngJSONmysql_dbUser :: String + , sngJSONmysql_dbPass :: String + , sngJSONcompiler_version :: String + , sngJSONcompiler_env :: String + , sngJSONcompiler_modelHash :: String } deriving (Generic, Show) instance ToJSON Settings where toJSON = amp2Jason instance JSON MultiFSpecs Settings where fromAmpersand multi _ = Settings - { sngJSONversionInfo = ampersandVersionStr - , sngJSONcontextName = Text.unpack (fsName fSpec) - , sngJSONmysqlSettings = fromAmpersand multi multi - , sngJSONenvironment = show . environment . getOpts $ fSpec - , sngJSONmodelHash = show . hash $ fSpec + { sngJSONglobal_contextName = Text.unpack (fsName fSpec) + , sngJSONmysql_dbHost = sqlHost opts + , sngJSONmysql_dbName = dbName opts + , sngJSONmysql_dbUser = sqlLogin opts + , sngJSONmysql_dbPass = sqlPwd opts + , sngJSONcompiler_version = ampersandVersionStr + , sngJSONcompiler_env = show . environment . getOpts $ fSpec + , sngJSONcompiler_modelHash = show . hash $ fSpec } where fSpec = userFSpec multi - -data MySQLSettings = MySQLSettings - { msqlJSONdbHost :: String - , msqlJSONdbName :: String - , msqlJSONdbUser :: String - , msqlJSONdbPass :: String - } deriving (Generic, Show) -instance ToJSON MySQLSettings where - toJSON = amp2Jason -instance JSON MultiFSpecs MySQLSettings where - fromAmpersand multi _ = MySQLSettings - { msqlJSONdbHost = sqlHost opts - , msqlJSONdbName = dbName opts - , msqlJSONdbUser = sqlLogin opts - , msqlJSONdbPass = sqlPwd opts - } - where opts = getOpts fSpec - fSpec = userFSpec multi + opts = getOpts fSpec From af5a187f5543d9018f2d2e2195fda0f17a7291b4 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 23 Dec 2018 20:20:06 +0100 Subject: [PATCH 036/131] See https://marketplace.visualstudio.com/items?itemName=ndmitchell.haskell-ghcid --- .gitignore | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index bb7b2a5fd7..b0526bcbbb 100644 --- a/.gitignore +++ b/.gitignore @@ -33,4 +33,6 @@ miscellaneous/AmpersandBackup.jgfns .settings/org.eclipse.wst.common.project.facet.core.xml .settings/org.eclipse.php.core.prefs /.stack-work -\.ghci +/.ghci +/ghcid.txt + From 2935399b0732660e064ed7ab6616a1a5daa163dd Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 23 Dec 2018 22:05:07 +0100 Subject: [PATCH 037/131] Substitute underscores by dots in .json field names --- src/Ampersand/Output/ToJSON/JSONutils.hs | 29 +++++++++++++++++++----- 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/src/Ampersand/Output/ToJSON/JSONutils.hs b/src/Ampersand/Output/ToJSON/JSONutils.hs index 9bd8a251b9..728a723fc8 100644 --- a/src/Ampersand/Output/ToJSON/JSONutils.hs +++ b/src/Ampersand/Output/ToJSON/JSONutils.hs @@ -40,17 +40,34 @@ writeJSONFile opts fName x where file = fName <.> "json" fullFile = getGenericsDir opts file +-- We use aeson to generate .json in a simple and efficient way. +-- For details, see http://hackage.haskell.org/package/aeson/docs/Data-Aeson.html#t:ToJSON class (GToJSON Zero (Rep b), Generic b) => JSON a b | b -> a where fromAmpersand :: MultiFSpecs -> a -> b amp2Jason :: b -> Value amp2Jason = genericToJSON ampersandDefault +-- These are the modified defaults, to generate .json ampersandDefault :: AT.Options -ampersandDefault = defaultOptions {AT.fieldLabelModifier = stripLabel} - where stripLabel str - = case filter (isPrefixOf pfx) (tails str) of - [] -> fatal ("Label at Haskell side must contain `JSON`: "++str) - xs -> snd . splitAt (length pfx) . head $ xs - where pfx = "JSON" +ampersandDefault = defaultOptions {AT.fieldLabelModifier = alterLabel} + where + -- The label of a field is modified before it is written in the JSON file. + -- this is done because of different restrictions at the Haskell side and at + -- the .json side. In our case, we strip all characters upto the first occurence + -- of the prefix "JSON" (which is mandatory). in the rest of that string, we + -- substitute all underscores with dots. + alterLabel str = + case filter (isPrefixOf pfx) (tails str) of + [] -> fatal ("Label at Haskell side must contain `JSON`: "++str) + xs -> replace '_' '.' . snd . splitAt (length pfx) . head $ xs + where pfx = "JSON" + +-- | Replaces all instances of a value in a list by another value. +replace :: Eq a => + a -- ^ Value to look for + -> a -- ^ Value to replace it with + -> [a] -- ^ Input list + -> [a] -- ^ Output list +replace x y = map (\z -> if z == x then y else z) From a28ba2f8e3218ca2c0e9a5c18d44ab71183312ad Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 23 Dec 2018 22:57:19 +0100 Subject: [PATCH 038/131] Info whether relation is stored flipped --- src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs b/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs index 604de53519..db32b5df22 100644 --- a/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs +++ b/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs @@ -147,14 +147,17 @@ makeGeneratedSqlPlugs opts context calcProps = conceptTables ++ linkTables where bindedExp :: Expression bindedExp = EDcD dcl - theRelStore = if isFlipped trgExpr + isStoredFlipped = isFlipped trgExpr + theRelStore = if isStoredFlipped then RelStore { rsDcl = dcl + , rsStoredFlipped = isStoredFlipped , rsSrcAtt = trgAtt , rsTrgAtt = srcAtt } else RelStore { rsDcl = dcl + , rsStoredFlipped = isStoredFlipped , rsSrcAtt = srcAtt , rsTrgAtt = trgAtt } @@ -176,7 +179,7 @@ makeGeneratedSqlPlugs opts context calcProps = conceptTables ++ linkTables , attNull = isTot trgExpr , attDBNull = False -- false for link tables , attUniq = isUni trgExpr - , attFlipped = isFlipped trgExpr + , attFlipped = isStoredFlipped } trgAtt = Att { attName = concat["Tgt" | isEndo dcl]++(unquote . name . target) trgExpr , attExpr = trgExpr @@ -187,7 +190,7 @@ makeGeneratedSqlPlugs opts context calcProps = conceptTables ++ linkTables , attNull = isSur trgExpr , attDBNull = False -- false for link tables , attUniq = isInj trgExpr - , attFlipped = isFlipped trgExpr + , attFlipped = isStoredFlipped } -- | dist will distribute the relations amongst the sets of concepts. From 99d68bf3f97a636bc580d94e18669ffceccbcad1 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 23 Dec 2018 23:57:48 +0100 Subject: [PATCH 039/131] Fix issue #864 --- src/Ampersand/FSpec/FSpecAux.hs | 4 +-- src/Ampersand/FSpec/SQL.hs | 39 ++++++++++++++---------- src/Ampersand/Output/ToJSON/Relations.hs | 14 ++++----- 3 files changed, 31 insertions(+), 26 deletions(-) diff --git a/src/Ampersand/FSpec/FSpecAux.hs b/src/Ampersand/FSpec/FSpecAux.hs index 6973b2198e..26fd29536f 100644 --- a/src/Ampersand/FSpec/FSpecAux.hs +++ b/src/Ampersand/FSpec/FSpecAux.hs @@ -6,10 +6,10 @@ import Ampersand.ADL1 import Ampersand.FSpec.FSpec -- return table name and source and target column names for relation dcl -getRelationTableInfo :: FSpec -> Relation -> (PlugSQL,SqlAttribute,SqlAttribute) +getRelationTableInfo :: FSpec -> Relation -> (PlugSQL,RelStore) getRelationTableInfo fSpec dcl = case filter thisDcl . concatMap getRelInfos $ [p | InternalPlug p<-plugInfos fSpec ] of - [(p,store)] -> (p,rsSrcAtt store,rsTrgAtt store) + [(p,store)] -> (p,store) [] -> fatal ("Relation not found: "++name dcl) _ -> fatal ("Relation found multiple times: "++name dcl) where diff --git a/src/Ampersand/FSpec/SQL.hs b/src/Ampersand/FSpec/SQL.hs index 3d491b765b..acf0262808 100644 --- a/src/Ampersand/FSpec/SQL.hs +++ b/src/Ampersand/FSpec/SQL.hs @@ -219,7 +219,9 @@ maybeSpecialCase fSpec expr = (expr2Src,expr2trg,leftTable) = case expr2 of EDcD rel -> - let (plug,s,t) = getRelationTableInfo fSpec rel + let (plug,relstore) = getRelationTableInfo fSpec rel + s = rsSrcAtt relstore + t = rsTrgAtt relstore lt = TRSimple [QName (name plug)] `as` table2 in if isFlipped' then (QName (name t), QName (name s), lt) @@ -381,24 +383,28 @@ nonSpecialSelectExpr fSpec expr= isR e = case e of (ECps (EDcD r, EFlp (EDcD r'))) - -> let (plug,_,t) = getRelationTableInfo fSpec r in + -> let (plug,relstore) = getRelationTableInfo fSpec r in if r == r' && plug == broadTable - then Just (e,[QName (name t)]) + then Just (e,[QName . name . rsTrgAtt $ relstore]) else Nothing (ECps (EFlp (EDcD r'), EDcD r)) - -> let (plug,s,_) = getRelationTableInfo fSpec r in + -> let (plug,relstore) = getRelationTableInfo fSpec r in if r' == r && plug == broadTable - then Just (e,[QName (name s)]) + then Just (e,[QName . name . rsSrcAtt $ relstore]) else Nothing (EDcD r) - -> let (plug,s,t) = getRelationTableInfo fSpec r in + -> let (plug,relstore) = getRelationTableInfo fSpec r in if plug == broadTable - then Just (e,[QName (name s),QName (name t)]) + then Just (e,[QName . name . rsSrcAtt $ relstore + ,QName . name . rsTrgAtt $ relstore + ]) else Nothing (EFlp (EDcD r)) - -> let (plug,s,t) = getRelationTableInfo fSpec r in + -> let (plug,relstore) = getRelationTableInfo fSpec r in if plug == broadTable - then Just (e,[QName (name s),QName (name t)]) + then Just (e,[QName . name . rsSrcAtt $ relstore + ,QName . name . rsTrgAtt $ relstore + ]) else Nothing _ -> Nothing esRest :: [Expression] -- all other conjuctions @@ -900,8 +906,8 @@ selectRelation :: FSpec -> Relation -> BinQueryExpr selectRelation fSpec dcl = leafCode (getRelationTableInfo fSpec dcl) where - leafCode :: (PlugSQL,SqlAttribute,SqlAttribute) -> BinQueryExpr - leafCode (plug,s,t) + leafCode :: (PlugSQL,RelStore) -> BinQueryExpr + leafCode (plug,relstore) = BSE { bseSetQuantifier = SQDefault , bseSrc = Col { cTable = [] , cCol = [QName (name s)] @@ -915,7 +921,8 @@ selectRelation fSpec dcl = , bseWhr = Just . conjunctSQL . map notNull $ [Iden [QName (name c)] | c<-nub [s,t]] } - + where s = rsSrcAtt relstore + t = rsTrgAtt relstore isNotIn :: ValueExpr -> QueryExpr -> ValueExpr isNotIn value = In False value . InQueryExpr -- | select only the source of a binary expression @@ -1277,10 +1284,10 @@ broadQuery fSpec obj = (plug, _ ) = getConceptTableInfo fSpec cpt theDcl :: Maybe (PlugSQL, SqlAttribute) theDcl = case objExpression od of - EFlp (EDcD d) -> let (p, s, _) = getRelationTableInfo fSpec d - in Just (p, s) - EDcD d -> let (p, _, t) = getRelationTableInfo fSpec d - in Just (p, t) + EFlp (EDcD d) -> let (p,relstore) = getRelationTableInfo fSpec d + in Just (p, rsSrcAtt relstore) + EDcD d -> let (p,relstore) = getRelationTableInfo fSpec d + in Just (p, rsTrgAtt relstore) EDcI c -> Just $ getConceptTableInfo fSpec c _ -> Nothing diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index e1c8c111d7..41cf0b3de7 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -65,17 +65,15 @@ instance JSON Relation RelTableInfo where fromAmpersand multi dcl = RelTableInfo { rtiJSONname = name plug , rtiJSONtableOf = srcOrtgt - , rtiJSONsrcCol = fromAmpersand multi srcAtt - , rtiJSONtgtCol = fromAmpersand multi trgAtt + , rtiJSONsrcCol = fromAmpersand multi . rsSrcAtt $ relstore + , rtiJSONtgtCol = fromAmpersand multi . rsTrgAtt $ relstore } where fSpec = userFSpec multi - (plug,srcAtt,trgAtt) = getRelationTableInfo fSpec dcl - (plugSrc,_) = getConceptTableInfo fSpec (source dcl) - (plugTrg,_) = getConceptTableInfo fSpec (target dcl) - -- relStore = filter isDcl . dLkpTbl $ plug - -- isDcl rs = rsDcl rs == dcl + (plug,relstore) = getRelationTableInfo fSpec dcl + (plugSrc,_) = getConceptTableInfo fSpec (source dcl) + (plugTrg,_) = getConceptTableInfo fSpec (target dcl) srcOrtgt - | plugSrc == plugTrg = fatal "TODO: See issue #864." + | plugSrc == plugTrg = Just $ if rsStoredFlipped relstore then "tgt" else "src" | plug == plugSrc = Just "src" | plug == plugTrg = Just "tgt" | otherwise = Nothing From 29da4e1517aa3d8f229ad8053e487bc576533a66 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Mon, 24 Dec 2018 00:07:15 +0100 Subject: [PATCH 040/131] update ShowHS --- src/Ampersand/FSpec/ShowHS.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Ampersand/FSpec/ShowHS.hs b/src/Ampersand/FSpec/ShowHS.hs index bfa292ce7c..7b88ee27d1 100644 --- a/src/Ampersand/FSpec/ShowHS.hs +++ b/src/Ampersand/FSpec/ShowHS.hs @@ -78,6 +78,7 @@ instance ShowHS PlugSQL where ," , cLkpTbl = [ "++intercalate (indent++" , ") ["("++showHSName c++", "++showHSName cn++")" | (c,cn)<-cLkpTbl plug] ++ "]" ," , dLkpTbl = [ "++intercalate (indent++" , ") [ "RelStore "++showHSName (rsDcl store)++" " + ++show (rsStoredFlipped store)++" " ++showHSName (rsSrcAtt store)++" " ++showHSName (rsTrgAtt store)++" " | store<-dLkpTbl plug] ++ "]" @@ -90,6 +91,7 @@ instance ShowHS PlugSQL where ," , cLkpTbl = [ "++intercalate (indent++" , ") ["("++showHSName c++", "++showHSName cn++")" | (c,cn)<-cLkpTbl plug] ++ "]" ," , dLkpTbl = [ "++intercalate (indent++" , ") [ "RelStore "++showHSName (rsDcl store)++" " + ++show (rsStoredFlipped store)++" " ++showHSName (rsSrcAtt store)++" " ++showHSName (rsTrgAtt store)++" " | store<-dLkpTbl plug] ++ "]" From 5d94264eab1cb33dc6fee8e392d2a978cf7d55c1 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Mon, 24 Dec 2018 00:13:25 +0100 Subject: [PATCH 041/131] test --- src/Ampersand/Output/ToJSON/Relations.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index 41cf0b3de7..1e03c655d5 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -76,7 +76,7 @@ instance JSON Relation RelTableInfo where | plugSrc == plugTrg = Just $ if rsStoredFlipped relstore then "tgt" else "src" | plug == plugSrc = Just "src" | plug == plugTrg = Just "tgt" - | otherwise = Nothing + | otherwise = fatal "I am only looking for a case where this happens." instance JSON SqlAttribute TableCol where fromAmpersand _ att = TableCol { tcJSONname = attName att From a8c730c035311b3027cd3d0c8b815ffeab3bc4f8 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Mon, 24 Dec 2018 00:13:25 +0100 Subject: [PATCH 042/131] Revert "test" This reverts commit 5d94264eab1cb33dc6fee8e392d2a978cf7d55c1. --- src/Ampersand/Output/ToJSON/Relations.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index 1e03c655d5..41cf0b3de7 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -76,7 +76,7 @@ instance JSON Relation RelTableInfo where | plugSrc == plugTrg = Just $ if rsStoredFlipped relstore then "tgt" else "src" | plug == plugSrc = Just "src" | plug == plugTrg = Just "tgt" - | otherwise = fatal "I am only looking for a case where this happens." + | otherwise = Nothing instance JSON SqlAttribute TableCol where fromAmpersand _ att = TableCol { tcJSONname = attName att From 2b17159eefbdae55e648679e2499475fcd569ebb Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Mon, 24 Dec 2018 12:23:52 +0100 Subject: [PATCH 043/131] Fix bug in cases where a relation is exactly [SUR]. --- src/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs b/src/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs index fbb7a2825f..b904e96662 100644 --- a/src/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs +++ b/src/Ampersand/FSpec/ToFSpec/ADL2FSpec.hs @@ -433,7 +433,9 @@ tblcontents :: ContextInfo -> [Population] -> PlugSQL -> [[Maybe AAtomValue]] tblcontents ci ps plug = case plug of BinSQL{} -> let expr = case dLkpTbl plug of - [store] -> EDcD (rsDcl store) + [store] -> if rsStoredFlipped store + then EFlp . EDcD . rsDcl $ store + else EDcD . rsDcl $ store ss -> fatal ("Exactly one relation sould be stored in BinSQL. However, there are "++show (length ss)) in [[(Just . apLeft) p,(Just . apRight) p] |p<-Set.elems $ fullContents ci ps expr] TblSQL{} -> From ce5a64a5d0a9456283fba7e50bf01696ab7264ea Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Mon, 24 Dec 2018 18:45:48 +0100 Subject: [PATCH 044/131] simplify code --- src/Ampersand/FSpec/ShowHS.hs | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/src/Ampersand/FSpec/ShowHS.hs b/src/Ampersand/FSpec/ShowHS.hs index 7b88ee27d1..021e74b59d 100644 --- a/src/Ampersand/FSpec/ShowHS.hs +++ b/src/Ampersand/FSpec/ShowHS.hs @@ -77,11 +77,8 @@ instance ShowHS PlugSQL where ," , attributes = ["++intercalate ", " (map showHSName (attributes plug))++"]" ," , cLkpTbl = [ "++intercalate (indent++" , ") ["("++showHSName c++", "++showHSName cn++")" | (c,cn)<-cLkpTbl plug] ++ "]" ," , dLkpTbl = [ "++intercalate (indent++" , ") - [ "RelStore "++showHSName (rsDcl store)++" " - ++show (rsStoredFlipped store)++" " - ++showHSName (rsSrcAtt store)++" " - ++showHSName (rsTrgAtt store)++" " - | store<-dLkpTbl plug] ++ "]" + ( map (showHS opts (indent++" ")) . dLkpTbl $ plug) + ++ "]" ," }" ] BinSQL{} -> intercalate indent @@ -90,15 +87,21 @@ instance ShowHS PlugSQL where ,"BinSQL { sqlname = " ++ (show.name) plug ," , cLkpTbl = [ "++intercalate (indent++" , ") ["("++showHSName c++", "++showHSName cn++")" | (c,cn)<-cLkpTbl plug] ++ "]" ," , dLkpTbl = [ "++intercalate (indent++" , ") - [ "RelStore "++showHSName (rsDcl store)++" " - ++show (rsStoredFlipped store)++" " - ++showHSName (rsSrcAtt store)++" " - ++showHSName (rsTrgAtt store)++" " - | store<-dLkpTbl plug] ++ "]" - -- ," , sqlfpa = " ++ showHS opts "" (fpa plug) + ( map (showHS opts (indent++" ")) . dLkpTbl $ plug) + ++ "]" ," }" ] +instance ShowHS RelStore where + showHS _ indent store + = intercalate indent + [ "Relstore { rsDcl = " ++ showHSName (rsDcl store) + , " , rsStoredFlipped = " ++ show (rsStoredFlipped store) + , " , rsSrcAtt = " ++ showHSName (rsSrcAtt store) + , " , rsTrgAtt = " ++ showHSName (rsTrgAtt store) + , " }" + ] + instance ShowHSName SqlAttribute where showHSName sqAtt = haskellIdentifier ("sqlAtt_"++attName sqAtt) From 7488311accf88d9341b8ae5a9b321636383f01d8 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Mon, 24 Dec 2018 19:27:36 +0100 Subject: [PATCH 045/131] refactoring --- src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs | 86 +++++++++++-------------- 1 file changed, 38 insertions(+), 48 deletions(-) diff --git a/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs b/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs index db32b5df22..5558379985 100644 --- a/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs +++ b/src/Ampersand/FSpec/ToFSpec/ADL2Plug.hs @@ -58,26 +58,16 @@ makeGeneratedSqlPlugs opts context calcProps = conceptTables ++ linkTables tableKey = tyroot typ - isStoredFlipped :: Relation -> Bool - isStoredFlipped d - = snd . fromMaybe ftl . wayToStore $ d - where ftl = fatal ("relation `"++name d++"` cannot be stored in this table. "++show (properties d)++"\n\n"++show d) conceptLookuptable :: [(A_Concept,SqlAttribute)] conceptLookuptable = [(cpt,cptAttrib cpt) | cpt <-cpts] dclLookuptable :: [RelStore] dclLookuptable = map f dcls - where f d - = if isStoredFlipped d - then RelStore { rsDcl = d - , rsStoredFlipped = isStoredFlipped d - , rsSrcAtt = dclAttrib d - , rsTrgAtt = lookupC (target d) - } - else RelStore { rsDcl = d - , rsStoredFlipped = isStoredFlipped d - , rsSrcAtt = lookupC (source d) - , rsTrgAtt = dclAttrib d - } + where f d = + RelStore { rsDcl = d + , rsStoredFlipped = isStoredFlipped d + , rsSrcAtt = if isStoredFlipped d then dclAttrib d else lookupC (source d) + , rsTrgAtt = if isStoredFlipped d then lookupC (target d) else dclAttrib d + } lookupC :: A_Concept -> SqlAttribute lookupC cpt = case [f |(c',f)<-conceptLookuptable, cpt==c'] of @@ -147,20 +137,12 @@ makeGeneratedSqlPlugs opts context calcProps = conceptTables ++ linkTables where bindedExp :: Expression bindedExp = EDcD dcl - isStoredFlipped = isFlipped trgExpr - theRelStore = if isStoredFlipped - then RelStore - { rsDcl = dcl - , rsStoredFlipped = isStoredFlipped - , rsSrcAtt = trgAtt - , rsTrgAtt = srcAtt - } - else RelStore - { rsDcl = dcl - , rsStoredFlipped = isStoredFlipped - , rsSrcAtt = srcAtt - , rsTrgAtt = trgAtt - } + theRelStore = RelStore + { rsDcl = dcl + , rsStoredFlipped = isStoredFlipped dcl + , rsSrcAtt = if isStoredFlipped dcl then trgAtt else srcAtt + , rsTrgAtt = if isStoredFlipped dcl then srcAtt else trgAtt + } --the expr for the source of r srcExpr | isTot bindedExp = EDcI (source bindedExp) @@ -179,7 +161,7 @@ makeGeneratedSqlPlugs opts context calcProps = conceptTables ++ linkTables , attNull = isTot trgExpr , attDBNull = False -- false for link tables , attUniq = isUni trgExpr - , attFlipped = isStoredFlipped + , attFlipped = isStoredFlipped dcl } trgAtt = Att { attName = concat["Tgt" | isEndo dcl]++(unquote . name . target) trgExpr , attExpr = trgExpr @@ -190,7 +172,7 @@ makeGeneratedSqlPlugs opts context calcProps = conceptTables ++ linkTables , attNull = isSur trgExpr , attDBNull = False -- false for link tables , attUniq = isInj trgExpr - , attFlipped = isStoredFlipped + , attFlipped = isStoredFlipped dcl } -- | dist will distribute the relations amongst the sets of concepts. @@ -212,25 +194,33 @@ makeGeneratedSqlPlugs opts context calcProps = conceptTables ++ linkTables Nothing -> False Just x -> x `elem` tyCpts typ ] - - conceptTableOf :: Relation -> Maybe A_Concept - conceptTableOf d = if sqlBinTables opts - then Nothing - else fst <$> wayToStore d + conceptTableOf :: Relation -> Maybe A_Concept + conceptTableOf = fst . wayToStore opts + isStoredFlipped :: Relation -> Bool + isStoredFlipped = snd . wayToStore opts --- | this function tells in what concepttable a given relation is to be stored. If stored --- in a concept table, it returns the concept and a boolean, telling wether or not the relation --- is stored flipped. -wayToStore :: Relation -> Maybe (A_Concept,Bool) -wayToStore dcl = +-- | this function tells how a given relation is to be stored. If stored +-- in a concept table, it returns that concept. It allways returns a boolean +-- telling wether or not the relation is stored flipped. +wayToStore :: Options -> Relation -> (Maybe A_Concept,Bool) +wayToStore opts dcl + | sqlBinTables opts = (Nothing, False) + | otherwise = case (isInj d, isUni d) of - (False , False ) -> Nothing --Will become a link-table - (True , False ) -> Just flipped - (_ , True ) -> Just plain + (True , False ) -> inConceptTableFlipped + (_ , True ) -> inConceptTablePlain + (False , False ) -> inLinkTable --Will become a link-table where d = EDcD dcl - plain = (source d,False) - flipped = (target d, True) - + inConceptTablePlain = (Just $ source d,False) + inConceptTableFlipped = (Just $ target d, True) + inLinkTable = ( Nothing + , -- The order of columns in a linked table could + -- potentially speed up queries, in cases where + -- the relation is TOT or SUR. In that case there + -- should be no need to look in the concept table, + -- for all atoms are in the first colum of the link table + not (isTot d) && isSur d + ) unquote :: String -> String unquote str From f50472e3bc8f4f0fff824f1bc7e903ff18f3b74d Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink <> Date: Tue, 25 Dec 2018 10:54:12 +0100 Subject: [PATCH 046/131] Use development version of prototype framework. TODO: set to specific tag before merge to master --- src/Ampersand/Misc/Options.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/Misc/Options.hs b/src/Ampersand/Misc/Options.hs index 8304777317..bf53a41f48 100644 --- a/src/Ampersand/Misc/Options.hs +++ b/src/Ampersand/Misc/Options.hs @@ -207,7 +207,7 @@ getOptions' envOpts = , dirOutput = fromMaybe "." $ envDirOutput envOpts , outputfile = fatal "No monadic options available." , dirPrototype = fromMaybe "." (envDirPrototype envOpts) takeBaseName fName <.> ".proto" - , zwolleVersion = "v1.0.1" + , zwolleVersion = "development" -- "v1.0.1" , forceReinstallFramework = False , dirCustomizations = ["customizations"] , dbName = fmap toLower . fromMaybe ("ampersand_"++takeBaseName fName) $ envDbName envOpts From 0714bd4caeed9c64629cd807b62220f8242dd52f Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink <> Date: Tue, 25 Dec 2018 15:29:06 +0100 Subject: [PATCH 047/131] Use new pre-release of prototype framework --- src/Ampersand/Misc/Options.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/Misc/Options.hs b/src/Ampersand/Misc/Options.hs index bf53a41f48..ed8c1a9a89 100644 --- a/src/Ampersand/Misc/Options.hs +++ b/src/Ampersand/Misc/Options.hs @@ -207,7 +207,7 @@ getOptions' envOpts = , dirOutput = fromMaybe "." $ envDirOutput envOpts , outputfile = fatal "No monadic options available." , dirPrototype = fromMaybe "." (envDirPrototype envOpts) takeBaseName fName <.> ".proto" - , zwolleVersion = "development" -- "v1.0.1" + , zwolleVersion = "v1.1.0" , forceReinstallFramework = False , dirCustomizations = ["customizations"] , dbName = fmap toLower . fromMaybe ("ampersand_"++takeBaseName fName) $ envDbName envOpts From d197cbdb4ef183126e31bb74e71d49c4543ef26c Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink <> Date: Fri, 28 Dec 2018 17:34:21 +0100 Subject: [PATCH 048/131] Update changelog to indicate new prototype framework version --- ReleaseNotes.md | 1 + 1 file changed, 1 insertion(+) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 096b996ba6..b04f74e67f 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -2,6 +2,7 @@ ## Unreleased changes +* Update to prototype framework v1.1.0 (was v1.0.1). See [releases](https://github.com/AmpersandTarski/Prototype/releases) for more information * Add 'public' folder in prototype directory to better distinguish between public and non-public scripts. If used, requires change in 'customizations' folder * [Issue #792](https://github.com/AmpersandTarski/Ampersand/issues/792) Add possibility to extend TXT in interfaces * Only run composer install when clean install of prototype framework is downloaded From 99e287a94ad5b2504cfcfe496e6e1ed28ad160f7 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink <> Date: Fri, 28 Dec 2018 19:29:47 +0100 Subject: [PATCH 049/131] Update travis configuration. The prototype framework uses php 7.1 now --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index aad78939d7..59d6ddabd0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,7 +6,7 @@ sudo: required language: php php: - - 7.0 + - 7.1 cache: directories: From 972d30c9d0ecfe9e76c9bf74631313696fce4a5a Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sat, 29 Dec 2018 17:06:15 +0100 Subject: [PATCH 050/131] Fixes issue #862 --- src/Ampersand/FSpec/SQL.hs | 143 ++++++++++++++++--------------------- 1 file changed, 62 insertions(+), 81 deletions(-) diff --git a/src/Ampersand/FSpec/SQL.hs b/src/Ampersand/FSpec/SQL.hs index acf0262808..7c51fa2a63 100644 --- a/src/Ampersand/FSpec/SQL.hs +++ b/src/Ampersand/FSpec/SQL.hs @@ -365,8 +365,6 @@ nonSpecialSelectExpr fSpec expr= ] } where - broadTable :: PlugSQL -- The broad table where everything in the optimized case comes from. - broadTable = fst . getConceptTableInfo fSpec . source . head $ exprs esI :: [(Expression,Name)] -- all conjunctions that are of the form I esI = mapMaybe isI exprs where @@ -376,37 +374,13 @@ nonSpecialSelectExpr fSpec expr= EDcI c -> Just (e,sqlAttConcept fSpec c) EEps c _ -> Just (e,sqlAttConcept fSpec c) _ -> Nothing - esR :: [(Expression,[Name])] -- all conjuctions that are of the form r;r~ where r is in the same broad table as I + esR :: [(Expression,Name)] -- all conjuctions that are of the form r;r~ where r is in the same broad table (and same row!) as I esR = mapMaybe isR exprs where - isR :: Expression -> Maybe (Expression,[Name]) - isR e = - case e of - (ECps (EDcD r, EFlp (EDcD r'))) - -> let (plug,relstore) = getRelationTableInfo fSpec r in - if r == r' && plug == broadTable - then Just (e,[QName . name . rsTrgAtt $ relstore]) - else Nothing - (ECps (EFlp (EDcD r'), EDcD r)) - -> let (plug,relstore) = getRelationTableInfo fSpec r in - if r' == r && plug == broadTable - then Just (e,[QName . name . rsSrcAtt $ relstore]) - else Nothing - (EDcD r) - -> let (plug,relstore) = getRelationTableInfo fSpec r in - if plug == broadTable - then Just (e,[QName . name . rsSrcAtt $ relstore - ,QName . name . rsTrgAtt $ relstore - ]) - else Nothing - (EFlp (EDcD r)) - -> let (plug,relstore) = getRelationTableInfo fSpec r in - if plug == broadTable - then Just (e,[QName . name . rsSrcAtt $ relstore - ,QName . name . rsTrgAtt $ relstore - ]) - else Nothing - _ -> Nothing + isR :: Expression -> Maybe (Expression,Name) + isR e = case isInBroadQuery fSpec (source . head $ exprs) e of + Nothing -> Nothing + Just att -> Just (e, QName . name $ att) esRest :: [Expression] -- all other conjuctions esRest = (exprs \\ (map fst esI)) \\ (map fst esR) optimizedIntersectSelectExpr :: BinQueryExpr @@ -423,7 +397,7 @@ nonSpecialSelectExpr fSpec expr= , cSpecial = Nothing} , bseTbl = [sqlConceptTable fSpec c] , bseWhr = Just . conjunctSQL $ - [notNull (Iden [nm]) | nm <- nub (map snd esI++concatMap snd esR)] + [notNull (Iden [nm]) | nm <- nub (map snd esI++map snd esR)] } where c = case map fst esI of [] -> fatal "This list must not be empty here." @@ -1189,16 +1163,16 @@ broadQuery fSpec obj = Nothing -> toSQL baseBinExpr Just InterfaceRef{} -> toSQL baseBinExpr Just Box{siObjs=sObjs} -> - case filter (isInBroadQuery (objExpression obj)) [x | BxExpr x <- sObjs] of + case mapMaybe (isInBroadQuery fSpec . target . objExpression $ obj) [objExpression x | BxExpr x <- sObjs] of [] -> toSQL baseBinExpr xs -> extendWithCols xs baseBinExpr where baseBinExpr = getBinQueryExprPlaceholder fSpec . objExpression $ obj - extendWithCols :: [ObjectDef] -> BinQueryExpr -> QueryExpr - extendWithCols objs bqe - | null objs = plainQE + extendWithCols :: [SqlAttribute] -> BinQueryExpr -> QueryExpr + extendWithCols atts bqe + | null atts = plainQE | otherwise = case bqe of BSE{} -> newSelect (newSelectList,newFrom,newWhere) @@ -1207,14 +1181,14 @@ broadQuery fSpec obj = case qeFrom plainQE of [TRSimple [n]] -> if n == sqlConcept fSpec tableCpt - then ( qeSelectList plainQE ++ map (makeCol Nothing) objs + then ( qeSelectList plainQE ++ map (makeCol Nothing) atts , qeFrom plainQE , qeWhere plainQE ) else subThings _ -> subThings BCQE{} -> newSelect subThings - BQEComment _ x -> extendWithCols objs x + BQEComment _ x -> extendWithCols atts x where newSelect (sl,f,w) = Select { qeSetQuantifier = Distinct @@ -1228,29 +1202,27 @@ broadQuery fSpec obj = , qeFetchFirst = Nothing } plainQE = toSQL bqe - makeCol :: Maybe Name -> ObjectDef -> (ValueExpr, Maybe Name) - makeCol tableName col = - case attThatisInTableOf (target . objExpression $ obj) col of - Nothing -> fatal ("this is unexpected behaviour. "++show col) - Just att -> ( Iden ( case tableName of - Nothing -> [QName (name att)] - Just tab -> [tab,QName (name att)] - ) - , Just ( QName $ -- The name is not sufficient for two reasons: - -- 1) the columname must be unique. For that reason, it is prefixed: - "ifc_"++ - -- 2) It must be injective. Because SQL deletes trailing spaces, - -- we have to cope with that: - escapeIdentifier (name col) - ) - ) + makeCol :: Maybe Name -> SqlAttribute -> (ValueExpr, Maybe Name) + makeCol tableName att = + ( Iden ( case tableName of + Nothing -> [QName (name att)] + Just tab -> [tab,QName (name att)] + ) + , Just ( QName $ -- The name is not sufficient for two reasons: + -- 1) the columname must be unique. For that reason, it is prefixed: + "ifc_"++ + -- 2) It must be injective. Because SQL deletes trailing spaces, + -- we have to cope with that: + escapeIdentifier (name att) + ) + ) subThings :: ( [(ValueExpr, Maybe Name)] , [TableRef] , Maybe ValueExpr ) subThings = ( [ (Iden [org,sourceAlias] , Just sourceAlias) , (Iden [org,targetAlias] , Just targetAlias) - ]++ map (makeCol . Just $ ct) objs + ]++ map (makeCol . Just $ ct) atts , [ TRQueryExpr plainQE `as` org , sqlConceptTable fSpec tableCpt `as` ct ] @@ -1262,34 +1234,43 @@ broadQuery fSpec obj = where org = Name "org" ct = Name "cptTbl" - tableCpt = source . objExpression . head $ objs + tableCpt = source . attExpr . head $ atts - isInBroadQuery :: Expression -> ObjectDef -> Bool - isInBroadQuery ctxExpr sObj = - (isUni subExpr) - && (isJust . attThatisInTableOf (target subExpr) $ sObj) - && (source ctxExpr /= target ctxExpr || null (primitives ctxExpr)) --this is required to prevent conflicts in rows of the same broad table. See explanation in issue #627 - && (target ctxExpr /= target subExpr || (not . isFlipped $ subExpr)) -- see issue #760 for motivation of this line. +-- Iff the expression is implemented in the concepttable of the given concept +-- AND can be read from the same row, the implementing +-- attribute is returnd +isInBroadQuery :: FSpec -> A_Concept -> Expression -> Maybe SqlAttribute +isInBroadQuery fSpec cpt = get where - subExpr = objExpression sObj - - attThatisInTableOf :: A_Concept -> ObjectDef -> Maybe SqlAttribute - attThatisInTableOf cpt od = - case theDcl of - Nothing -> Nothing - Just (p,att) -> if plug == p - then Just att - else Nothing - where - (plug, _ ) = getConceptTableInfo fSpec cpt - theDcl :: Maybe (PlugSQL, SqlAttribute) - theDcl = case objExpression od of - EFlp (EDcD d) -> let (p,relstore) = getRelationTableInfo fSpec d - in Just (p, rsSrcAtt relstore) - EDcD d -> let (p,relstore) = getRelationTableInfo fSpec d - in Just (p, rsTrgAtt relstore) - EDcI c -> Just $ getConceptTableInfo fSpec c - _ -> Nothing + get expr = + case expr of + EBrk e -> get e + EDcI c -> let (p, a ) = getConceptTableInfo fSpec c + in if p == broadTable + then Just a + else Nothing + EEps c _ + -> let (p, a ) = getConceptTableInfo fSpec c + in if p == broadTable + then Just a + else Nothing + EDcD d -> let (p,relstore) = getRelationTableInfo fSpec d + in if p == broadTable && not (rsStoredFlipped relstore) + then Just (rsTrgAtt relstore) + else Nothing + EFlp (EDcD d) + -> let (p,relstore) = getRelationTableInfo fSpec d + in if p == broadTable && rsStoredFlipped relstore + then Just (rsSrcAtt relstore) + else Nothing + EFlp (EBrk e) + -> get (EFlp e) + _ -> Nothing +-- (isUni subExpr) && False +-- && (isJust . attThatisInTableOf (target subExpr) $ sObj) +-- && (source ctxExpr /= target ctxExpr || null (primitives ctxExpr)) --this is required to prevent conflicts in rows of the same broad table. See explanation in issue #627 +-- && (target ctxExpr /= target subExpr || (not . isFlipped $ subExpr)) -- see issue #760 for motivation of this line. + (broadTable, _) = getConceptTableInfo fSpec cpt theONESingleton :: Col theONESingleton = Col { cTable = [] From 6e2f3cd7e6545f57dd4381fb4c2a1f81e4fe8dac Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sat, 29 Dec 2018 18:30:06 +0100 Subject: [PATCH 051/131] Fixes issue #865 --- ReleaseNotes.md | 3 ++- src/Ampersand/FSpec/SQL.hs | 14 ++++++++++++-- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index b73f81f189..04aeeb8388 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -2,7 +2,8 @@ ## Unreleased changes -* [Issue #862](https://github.com/AmpersandTarski/Ampersand/issues/862) Bug in generated SQL in several cases where CLASSIFY statements were involved in combination with relations with the INJ property. +* [Issue #862](https://github.com/AmpersandTarski/Ampersand/issues/862) Bugfix in generated SQL in several cases where CLASSIFY statements were involved in combination with relations with the INJ property. +* [Issue #865](https://github.com/AmpersandTarski/Ampersand/issues/865) Another bugfix in the generated SQL ## v3.12.0 (21 december 2018) diff --git a/src/Ampersand/FSpec/SQL.hs b/src/Ampersand/FSpec/SQL.hs index 7c51fa2a63..6a61b7dd42 100644 --- a/src/Ampersand/FSpec/SQL.hs +++ b/src/Ampersand/FSpec/SQL.hs @@ -385,7 +385,11 @@ nonSpecialSelectExpr fSpec expr= esRest = (exprs \\ (map fst esI)) \\ (map fst esR) optimizedIntersectSelectExpr :: BinQueryExpr optimizedIntersectSelectExpr - = BQEComment [BlockComment "Optimized intersection:"] + = BQEComment ([BlockComment "Optimized intersection:" + ,BlockComment $ " Expression: "++(showA . foldl1 (./\.) $ exprs)] + -- ++map (showComment "esI") esI + -- ++map (showComment "esR") esR + ) BSE { bseSetQuantifier = SQDefault , bseSrc = Col { cTable = [] , cCol = [sqlAttConcept fSpec c] @@ -397,13 +401,19 @@ nonSpecialSelectExpr fSpec expr= , cSpecial = Nothing} , bseTbl = [sqlConceptTable fSpec c] , bseWhr = Just . conjunctSQL $ - [notNull (Iden [nm]) | nm <- nub (map snd esI++map snd esR)] + [notNull (Iden [nm]) | nm <- nub (map snd esI++map snd esR)]++ + [BinOp (Iden [nm]) [Name "="] (Iden [sqlAttConcept fSpec c]) + | nm <- nub (map snd esR) + , nm /= sqlAttConcept fSpec c + ] } where c = case map fst esI of [] -> fatal "This list must not be empty here." EDcI cpt : _ -> cpt EEps cpt _ : _ -> cpt e : _ -> fatal $ "Unexpected expression: "++show e + showComment :: String -> (Expression, Name) -> Comment + showComment str (e,n) = BlockComment $ " "++str++": ("++showA e++", "++show n++")" nonOptimizedIntersectSelectExpr :: BinQueryExpr nonOptimizedIntersectSelectExpr = case map (selectExpr fSpec) exprs of From 7d488a737012eb7a019ff5674d7cb57d75142622 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sat, 29 Dec 2018 18:39:04 +0100 Subject: [PATCH 052/131] remove warning --- src/Ampersand/FSpec/SQL.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Ampersand/FSpec/SQL.hs b/src/Ampersand/FSpec/SQL.hs index 6a61b7dd42..b26099caef 100644 --- a/src/Ampersand/FSpec/SQL.hs +++ b/src/Ampersand/FSpec/SQL.hs @@ -412,8 +412,8 @@ nonSpecialSelectExpr fSpec expr= EDcI cpt : _ -> cpt EEps cpt _ : _ -> cpt e : _ -> fatal $ "Unexpected expression: "++show e - showComment :: String -> (Expression, Name) -> Comment - showComment str (e,n) = BlockComment $ " "++str++": ("++showA e++", "++show n++")" + -- showComment :: String -> (Expression, Name) -> Comment + -- showComment str (e,n) = BlockComment $ " "++str++": ("++showA e++", "++show n++")" nonOptimizedIntersectSelectExpr :: BinQueryExpr nonOptimizedIntersectSelectExpr = case map (selectExpr fSpec) exprs of From 90c31510ec0f55a05896b81a9ad715c5683b028a Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sat, 29 Dec 2018 19:41:52 +0100 Subject: [PATCH 053/131] test cases --- .../shouldSucceed/validate/Issue862a.adl | 32 +++++++++++++++---- .../shouldSucceed/validate/Issue865.adl | 13 ++++++++ 2 files changed, 38 insertions(+), 7 deletions(-) create mode 100644 testing/Travis/testcases/prototype/shouldSucceed/validate/Issue865.adl diff --git a/testing/Travis/testcases/prototype/shouldSucceed/validate/Issue862a.adl b/testing/Travis/testcases/prototype/shouldSucceed/validate/Issue862a.adl index a20aeeaa4b..2f04779947 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/validate/Issue862a.adl +++ b/testing/Travis/testcases/prototype/shouldSucceed/validate/Issue862a.adl @@ -5,7 +5,7 @@ PURPOSE CONTEXT "Issue862a" RELATION father [Person * Person] [UNI] RELATION mothersChilds [Female * Person] [INJ] --this relation is the flipped 'mother' relation RELATION isMale [Male * Male] [PROP] - +RELATION husband[Female * Male][UNI,INJ] CLASSIFY Female ISA Person CLASSIFY Male ISA Person @@ -18,7 +18,8 @@ POPULATION isMale CONTAINS , ("Harry","Harry") , ("Timo", "Timo") ] - +POPULATION Female CONTAINS + ["Suzanne"] POPULATION father CONTAINS [ ("Rieks", "Pierre") , ("Stef", "Pierre") @@ -37,18 +38,35 @@ POPULATION mothersChilds CONTAINS , ("Janny","Bas") , ("Marian","Suzanne") ] - -INTERFACE "Persons": V[SESSION*Person] cRud BOX - [ persons: I ] +POPULATION husband CONTAINS + [ ("Tiny","Pierre") + , ("Kate","Harry") + , ("Janny","Stef") + , ("Marian","Timo") + ] +INTERFACE "Persons": V[SESSION*Person] cRud BOX + [ persons: I + , husband: husband + , wife : husband~] +INTERFACE "Males": V[SESSION*Male] cRud BOX + [ persons: I + , wife : husband~] +INTERFACE "Females": V[SESSION*Female] cRud BOX + [ persons: I + , husband: husband] INTERFACE "Person": I[Person] cRud BOX [ person : I[Person] , isMale : I[Male] , father : father , mother : mothersChilds~ + , husband : husband + , wife : husband~ , kidsOfThisFather : father~ , kidsOfThisMother : mothersChilds --- , daughters : (I[Female] /\ (father;father~)) \/ --- (I[Female] /\ (mothersChilds;mothersChilds~)) + , daughters : (father~;I[Female]) \/ + (mothersChilds;I[Female]) + , sons : (father~;I[Male]) \/ + (mothersChilds;I[Male]) ] ENDCONTEXT \ No newline at end of file diff --git a/testing/Travis/testcases/prototype/shouldSucceed/validate/Issue865.adl b/testing/Travis/testcases/prototype/shouldSucceed/validate/Issue865.adl new file mode 100644 index 0000000000..8c553e91ed --- /dev/null +++ b/testing/Travis/testcases/prototype/shouldSucceed/validate/Issue865.adl @@ -0,0 +1,13 @@ +CONTEXT Issue865 + +isSuccessorOf :: Assignment * Assignment [UNI,INJ,ASY] -- IRF, + +POPULATION isSuccessorOf CONTAINS [ ("Ass2", "Ass1") ] +POPULATION isSuccessorOf CONTAINS [ ("Ass3", "Ass2"), ("aap","aap") ] + + +ROLE "Iemand" MAINTAINS "Niet Successor van zichzelf" +RULE "Niet Successor van zichzelf" : I[Assignment] |- -isSuccessorOf + +ENDCONTEXT + From c06d98ebb5aff415178ca4ebb0a0fac29ce4a97d Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 30 Dec 2018 20:32:08 +0100 Subject: [PATCH 054/131] Refactor and remove dead code --- src/Ampersand/ADL1/P2A_Converters.hs | 9 +++++ src/Ampersand/Basics/Auxiliaries.hs | 50 ---------------------------- 2 files changed, 9 insertions(+), 50 deletions(-) diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 7aec81fc71..63bea75ae2 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -1105,3 +1105,12 @@ orElse :: Maybe a -> Maybe a -> Maybe a x `orElse` y = case x of Just _ -> x Nothing -> y + +-- | getCycles returns a list of cycles in the edges list (each edge is a pair of a from-vertex +-- and a list of to-vertices) +getCycles :: Eq a => [(a, [a])] -> [[a]] +getCycles edges = + let allVertices = nub . concat $ [ from : to | (from, to) <- edges ] + keyFor v = fromMaybe (error "FATAL") $ elemIndex v allVertices + graphEdges = [ (v, keyFor v , map keyFor vs) | (v, vs) <- edges ] + in [ vs | CyclicSCC vs <- stronglyConnComp graphEdges ] diff --git a/src/Ampersand/Basics/Auxiliaries.hs b/src/Ampersand/Basics/Auxiliaries.hs index 0d85ce7602..3356639c1b 100644 --- a/src/Ampersand/Basics/Auxiliaries.hs +++ b/src/Ampersand/Basics/Auxiliaries.hs @@ -2,17 +2,12 @@ module Ampersand.Basics.Auxiliaries ( eqClass, eqCl, - getCycles, transClosureMap, transClosureMap', - combinations, converse, commaEng, commaNL, - fst3, snd3, thd3, Flippable(..), showTrace, showTraceTag, - blockParenthesize, - addToLastLine, indent ) where @@ -42,16 +37,6 @@ eqCl :: Ord b => (a -> b) -> [a] -> [[a]] eqCl _ [] = [] eqCl f lst = Map.elems (Map.fromListWith (++) [(f e,[e]) | e <- lst]) --- | getCycles returns a list of cycles in the edges list (each edge is a pair of a from-vertex --- and a list of to-vertices) -getCycles :: Eq a => [(a, [a])] -> [[a]] -getCycles edges = - let allVertices = nub . concat $ [ from : to | (from, to) <- edges ] - keyFor v = fromMaybe (error "FATAL") $ elemIndex v allVertices - graphEdges = [ (v, keyFor v , map keyFor vs) | (v, vs) <- edges ] - in [ vs | CyclicSCC vs <- stronglyConnComp graphEdges ] - - -- | Warshall's transitive closure algorithm transClosureMap' :: Ord a => Map.Map a [a] -> Map.Map a [a] transClosureMap' xs @@ -67,15 +52,6 @@ transClosureMap xs f :: Ord a => Map.Map a (Set.Set a) -> a -> Map.Map a (Set.Set a) f q x = Map.unionWith Set.union q (Map.fromListWith Set.union [(a, q Map.! x) | (a, bs) <- Map.assocs q, x `elem` bs]) --- The following function can be used to determine how much of a set of alternative expression is already determined --- | The 'combinations' function returns all possible combinations of lists of list. --- For example, --- --- > combinations [[1,2,3],[10,20],[4]] == [[1,10,4],[1,20,4],[2,10,4],[2,20,4],[3,10,4],[3,20,4]] -combinations :: [[a]] -> [[a]] -combinations [] = [[]] -combinations (es:ess) = [ x:xs | x<-es, xs<-combinations ess] - -- Convert list of a's with associated b's to a list of b's with associated a's. -- Each b in the result is unique, and so is each a per b, eg.: -- converse [("foo",[2,2,3]),("foo",[3,4]),("bar",[4,5])] == [(2,["foo"]),(3,["foo"]),(4,["foo","bar"]),(5,["bar"])] @@ -97,13 +73,6 @@ commaNL _ [a] = a commaNL str (a:as) = a++", "++commaNL str as commaNL _ [] = "" -fst3 :: (a,b,c)->a -snd3 :: (a,b,c)->b -thd3 :: (a,b,c)->c -fst3 (a,_,_) = a -snd3 (_,b,_) = b -thd3 (_,_,c) = c - class Flippable a where flp :: a -> a @@ -119,24 +88,5 @@ showTraceTag tag x = trace (tag ++ ": " ++ show x) x -- Code formatting utils -blockParenthesize :: String -> String -> String -> [[String]] -> [String] -blockParenthesize open close sep liness = - case liness of - [] -> [open ++ close] - _ -> concat [ zipWith (++) (pre:repeat " ") linez - | (pre, linez) <- zip ((open++" "): repeat (sep++" ")) liness ] ++ [close] --- [["line"], ["line1", "line2", "line3"],["linea", "lineb"] -> --- ( line --- , line1 --- line2 --- line3 --- , linea --- lineb --- ) - -addToLastLine :: String -> [String] -> [String] -addToLastLine str [] = [str] -addToLastLine str liness = init liness ++ [last liness ++ str] - indent :: Int -> [String] -> [String] indent n = map (replicate n ' ' ++) From 1a430487b2cbf290a47806dd02b7e02b73d76ed7 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 30 Dec 2018 20:34:34 +0100 Subject: [PATCH 055/131] move test files --- .../Sentinel/Tests/ShouldSucceed/Issue166.adl | 24 ------------------- testing/Travis/testcases/Simple/Issue166.adl | 13 ++++++++++ .../testcases/Simple}/Issue853.adl | 0 3 files changed, 13 insertions(+), 24 deletions(-) delete mode 100644 testing/Sentinel/Tests/ShouldSucceed/Issue166.adl create mode 100644 testing/Travis/testcases/Simple/Issue166.adl rename testing/{Sentinel/Tests/ShouldSucceed => Travis/testcases/Simple}/Issue853.adl (100%) diff --git a/testing/Sentinel/Tests/ShouldSucceed/Issue166.adl b/testing/Sentinel/Tests/ShouldSucceed/Issue166.adl deleted file mode 100644 index 7a1e4bb1fa..0000000000 --- a/testing/Sentinel/Tests/ShouldSucceed/Issue166.adl +++ /dev/null @@ -1,24 +0,0 @@ -CONTEXT SinterklaasTest IN DUTCH - -RULE toBeOrNotToBe : -'Sinterklaas'[Persoon] -MEANING "De persoon 'Sinterklaas' bestaat niet." - -ENDCONTEXT - -{- This test is all about the question of what is in the initial population. -Are singletons, mentioned in expressions only, part of that population? - -Currently, a singleton is part of the initial population. In this case, a prototype cannot be generated, -It gives the following error message: - -Checking on rule violations... -Violations of rule "toBeOrNotToBe": -- [("Sinterklaas","Sinterklaas")] - -Signals for initial population: -Conjunct: -'Sinterklaas'[Persoon] -- [("Sinterklaas","Sinterklaas")] - -ERROR: No prototype generated because of rule violations. - --} \ No newline at end of file diff --git a/testing/Travis/testcases/Simple/Issue166.adl b/testing/Travis/testcases/Simple/Issue166.adl new file mode 100644 index 0000000000..4b163a10c3 --- /dev/null +++ b/testing/Travis/testcases/Simple/Issue166.adl @@ -0,0 +1,13 @@ +CONTEXT SinterklaasTest IN DUTCH + +RULE toBeOrNotToBe : -"Sinterklaas"[Persoon] +MEANING "De persoon 'Sinterklaas' bestaat niet." + +ENDCONTEXT + +{- This test is all about the question of what is in the initial population. +Are singletons, mentioned in expressions only, part of that population? + +Singletons are NOT automatically part of the initial population. This is intentional. + +-} \ No newline at end of file diff --git a/testing/Sentinel/Tests/ShouldSucceed/Issue853.adl b/testing/Travis/testcases/Simple/Issue853.adl similarity index 100% rename from testing/Sentinel/Tests/ShouldSucceed/Issue853.adl rename to testing/Travis/testcases/Simple/Issue853.adl From 672907dfcf6614cce859d354a59552edd69a110b Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 30 Dec 2018 20:43:22 +0100 Subject: [PATCH 056/131] more refactoring --- src/Ampersand/ADL1/P2A_Converters.hs | 1 + src/Ampersand/Basics/Auxiliaries.hs | 2 -- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 63bea75ae2..a7167afcec 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -22,6 +22,7 @@ import Data.Char(toUpper,toLower) import Data.Either import Data.Foldable (toList) import Data.Function +import Data.Graph (stronglyConnComp, SCC(CyclicSCC)) import Data.Hashable import Data.List as Lst import qualified Data.List.NonEmpty as NEL --(NonEmpty(..),nonEmpty) diff --git a/src/Ampersand/Basics/Auxiliaries.hs b/src/Ampersand/Basics/Auxiliaries.hs index 3356639c1b..3248901df4 100644 --- a/src/Ampersand/Basics/Auxiliaries.hs +++ b/src/Ampersand/Basics/Auxiliaries.hs @@ -12,9 +12,7 @@ module Ampersand.Basics.Auxiliaries ) where import Ampersand.Basics.Prelude -import Data.Graph (stronglyConnComp, SCC(CyclicSCC)) import Data.List -import Data.Maybe (fromMaybe) import qualified Data.Map as Map import qualified Data.Set as Set From 1471eb3605edf216f6039a231f9c157426841fd4 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink <> Date: Sun, 30 Dec 2018 21:03:25 +0100 Subject: [PATCH 057/131] Add missing TType 'Object' to parser. Fixes #616 --- ReleaseNotes.md | 1 + src/Ampersand/Core/AbstractSyntaxTree.hs | 4 ++-- src/Ampersand/Input/ADL1/Lexer.hs | 1 + src/Ampersand/Input/ADL1/Parser.hs | 1 + 4 files changed, 5 insertions(+), 2 deletions(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 2df5387d3b..e785101bc0 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,6 +1,7 @@ # Release notes of Ampersand ## Unreleased changes +* [Issue #616](https://github.com/AmpersandTarski/Ampersand/issues/616) Add missing TType 'Object' to parser ## v3.12.0 (21 december 2018) diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs index 582d7f5e7a..8a8aa0f4a2 100644 --- a/src/Ampersand/Core/AbstractSyntaxTree.hs +++ b/src/Ampersand/Core/AbstractSyntaxTree.hs @@ -1052,11 +1052,10 @@ unsafePAtomVal2AtomValue' typ mCpt pav , "Found: `"++show x++"`," , "as representation of an atom in concept `"++name c++"`." , "However, the representation-type of that concept is "++implicitly - , "defined as "++show expected++". The found value does not match that type." + , "defined as "++show typ++". The found value does not match that type." ]++ example where c = fromMaybe (fatal "Representation mismatch without concept known should not happen.") mCpt - expected = if typ == Object then Alphanumeric else typ implicitly = if typ == Object then "(implicitly) " else "" example :: [String] example = case typ of @@ -1069,6 +1068,7 @@ unsafePAtomVal2AtomValue' typ mCpt pav HugeAlphanumeric -> ["HUGEALPHANUMERIC types are texts (max 16M chars) surrounded with double quotes (\"-characters)."] Integer -> ["INTEGER types are decimal numbers (max 20 positions), e.g. 4711 or -4711 (without surrounding quotes)"] Password -> ["PASSWORD types are texts (max 255 chars) surrounded with double quotes (\"-characters)."] + Object -> ["OBJECT types are non-scalar atoms represented by an identifier (max 255 chars) surrounded with double quotes (\"-characters)."] _ -> fatal $ "There is no example denotational syntax for a value of type `"++show typ++"`." dayZeroExcel = addDays (-2) (fromGregorian 1900 1 1) -- Excel documentation tells that counting starts a jan 1st, however, that isn't totally true. maybeRead :: Read a => String -> Maybe a diff --git a/src/Ampersand/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index 6b2a3e1907..767b6b3101 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -67,6 +67,7 @@ keywords = nub [ "CONTEXT", "ENDCONTEXT" , "ALPHANUMERIC", "BIGALPHANUMERIC", "HUGEALPHANUMERIC", "PASSWORD" , "BINARY", "BIGBINARY", "HUGEBINARY" , "DATE", "DATETIME", "BOOLEAN", "INTEGER", "FLOAT", "AUTOINCREMENT" + , "OBJECT" -- Keywords for values of atoms: , "TRUE", "FALSE" --for booleans -- Experimental stuff: diff --git a/src/Ampersand/Input/ADL1/Parser.hs b/src/Ampersand/Input/ADL1/Parser.hs index 48cab9f6ff..b4a4911d49 100644 --- a/src/Ampersand/Input/ADL1/Parser.hs +++ b/src/Ampersand/Input/ADL1/Parser.hs @@ -337,6 +337,7 @@ pAdlTType <|> k Boolean "BOOLEAN" <|> k Integer "INTEGER" <|> k Float "FLOAT" + <|> k Object "OBJECT" where k tt str = f <$> pKey str where f _ = tt From b1466ca699c6eb99855e04f1e71e609de8eaa81d Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 30 Dec 2018 21:13:15 +0100 Subject: [PATCH 058/131] more refactoring and cleaning up --- src/Ampersand/Basics/Auxiliaries.hs | 18 +++--------------- src/Ampersand/Prototype/GenFrontend.hs | 2 +- src/Ampersand/Prototype/PHP.hs | 2 +- 3 files changed, 5 insertions(+), 17 deletions(-) diff --git a/src/Ampersand/Basics/Auxiliaries.hs b/src/Ampersand/Basics/Auxiliaries.hs index 3248901df4..813bffdb58 100644 --- a/src/Ampersand/Basics/Auxiliaries.hs +++ b/src/Ampersand/Basics/Auxiliaries.hs @@ -6,9 +6,7 @@ module Ampersand.Basics.Auxiliaries converse, commaEng, commaNL, Flippable(..), - showTrace, - showTraceTag, - indent + indent' ) where import Ampersand.Basics.Prelude @@ -74,17 +72,7 @@ commaNL _ [] = "" class Flippable a where flp :: a -> a - --- Trace shorthands - -showTrace :: Show a => a -> a -showTrace = traceShowId - -showTraceTag :: Show a => String -> a -> a -showTraceTag tag x = trace (tag ++ ": " ++ show x) x - - -- Code formatting utils -indent :: Int -> [String] -> [String] -indent n = map (replicate n ' ' ++) +indent' :: Int -> [String] -> [String] +indent' n = map (replicate n ' ' ++) diff --git a/src/Ampersand/Prototype/GenFrontend.hs b/src/Ampersand/Prototype/GenFrontend.hs index 61c8cb59f2..1a5a8c6238 100644 --- a/src/Ampersand/Prototype/GenFrontend.hs +++ b/src/Ampersand/Prototype/GenFrontend.hs @@ -358,7 +358,7 @@ genViewObject fSpec depth obj@FEObjE{} = } where indentation :: [String] -> [String] - indentation = indent (if depth == 0 then 4 else 16) + indentation = map ( (replicate (if depth == 0 then 4 else 16) ' ') ++) genView_SubObject :: FEObject2 -> IO SubObjectAttr2 genView_SubObject subObj = case subObj of diff --git a/src/Ampersand/Prototype/PHP.hs b/src/Ampersand/Prototype/PHP.hs index c309a83c62..fef4c7ee9d 100644 --- a/src/Ampersand/Prototype/PHP.hs +++ b/src/Ampersand/Prototype/PHP.hs @@ -57,7 +57,7 @@ performQuery fSpec dbNm queryStr = fatal ("PHP/SQL problem: "<>queryResult) else case reads queryResult of [(pairs,"")] -> return pairs - _ -> fatal ("Parse error on php result: \n"<>(unlines . indent 5 . lines $ queryResult)) + _ -> fatal ("Parse error on php result: \n"<>(unlines . map (" " ++) . lines $ queryResult)) } where opts = getOpts fSpec From b8dfddf81996a1ee7464b05a0cbdc0d6599b24b0 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 30 Dec 2018 20:34:34 +0100 Subject: [PATCH 059/131] Revert "move test files" This reverts commit 1a430487b2cbf290a47806dd02b7e02b73d76ed7. --- .../Sentinel/Tests/ShouldSucceed/Issue166.adl | 24 +++++++++++++++++++ .../Tests/ShouldSucceed}/Issue853.adl | 0 testing/Travis/testcases/Simple/Issue166.adl | 13 ---------- 3 files changed, 24 insertions(+), 13 deletions(-) create mode 100644 testing/Sentinel/Tests/ShouldSucceed/Issue166.adl rename testing/{Travis/testcases/Simple => Sentinel/Tests/ShouldSucceed}/Issue853.adl (100%) delete mode 100644 testing/Travis/testcases/Simple/Issue166.adl diff --git a/testing/Sentinel/Tests/ShouldSucceed/Issue166.adl b/testing/Sentinel/Tests/ShouldSucceed/Issue166.adl new file mode 100644 index 0000000000..7a1e4bb1fa --- /dev/null +++ b/testing/Sentinel/Tests/ShouldSucceed/Issue166.adl @@ -0,0 +1,24 @@ +CONTEXT SinterklaasTest IN DUTCH + +RULE toBeOrNotToBe : -'Sinterklaas'[Persoon] +MEANING "De persoon 'Sinterklaas' bestaat niet." + +ENDCONTEXT + +{- This test is all about the question of what is in the initial population. +Are singletons, mentioned in expressions only, part of that population? + +Currently, a singleton is part of the initial population. In this case, a prototype cannot be generated, +It gives the following error message: + +Checking on rule violations... +Violations of rule "toBeOrNotToBe": +- [("Sinterklaas","Sinterklaas")] + +Signals for initial population: +Conjunct: -'Sinterklaas'[Persoon] +- [("Sinterklaas","Sinterklaas")] + +ERROR: No prototype generated because of rule violations. + +-} \ No newline at end of file diff --git a/testing/Travis/testcases/Simple/Issue853.adl b/testing/Sentinel/Tests/ShouldSucceed/Issue853.adl similarity index 100% rename from testing/Travis/testcases/Simple/Issue853.adl rename to testing/Sentinel/Tests/ShouldSucceed/Issue853.adl diff --git a/testing/Travis/testcases/Simple/Issue166.adl b/testing/Travis/testcases/Simple/Issue166.adl deleted file mode 100644 index 4b163a10c3..0000000000 --- a/testing/Travis/testcases/Simple/Issue166.adl +++ /dev/null @@ -1,13 +0,0 @@ -CONTEXT SinterklaasTest IN DUTCH - -RULE toBeOrNotToBe : -"Sinterklaas"[Persoon] -MEANING "De persoon 'Sinterklaas' bestaat niet." - -ENDCONTEXT - -{- This test is all about the question of what is in the initial population. -Are singletons, mentioned in expressions only, part of that population? - -Singletons are NOT automatically part of the initial population. This is intentional. - --} \ No newline at end of file From db1baf348af8ac9dbfe106a5898473658684f9ab Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 30 Dec 2018 21:50:22 +0100 Subject: [PATCH 060/131] Remove dead code --- src/Ampersand/Basics/Auxiliaries.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Ampersand/Basics/Auxiliaries.hs b/src/Ampersand/Basics/Auxiliaries.hs index 813bffdb58..205f232d07 100644 --- a/src/Ampersand/Basics/Auxiliaries.hs +++ b/src/Ampersand/Basics/Auxiliaries.hs @@ -6,7 +6,6 @@ module Ampersand.Basics.Auxiliaries converse, commaEng, commaNL, Flippable(..), - indent' ) where import Ampersand.Basics.Prelude @@ -72,7 +71,3 @@ commaNL _ [] = "" class Flippable a where flp :: a -> a --- Code formatting utils - -indent' :: Int -> [String] -> [String] -indent' n = map (replicate n ' ' ++) From 802f483d57ae3222e11f019f83298d5aca89e7ba Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink <> Date: Tue, 1 Jan 2019 13:28:03 +0100 Subject: [PATCH 061/131] Add Object as allowed TType in parser test --- src/Ampersand/Test/Parser/ArbitraryTree.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Ampersand/Test/Parser/ArbitraryTree.hs b/src/Ampersand/Test/Parser/ArbitraryTree.hs index 7d0ee88f2c..e1a0888ea8 100644 --- a/src/Ampersand/Test/Parser/ArbitraryTree.hs +++ b/src/Ampersand/Test/Parser/ArbitraryTree.hs @@ -125,11 +125,12 @@ instance Arbitrary P_RoleRule where instance Arbitrary Representation where arbitrary = Repr <$> arbitrary <*> listOf1 upperId <*> arbitrary -instance Arbitrary TType where -- Not allowed are: [ Object , TypeOfOne] - arbitrary = elements [Alphanumeric, BigAlphanumeric, HugeAlphanumeric, Password +instance Arbitrary TType where -- Not allowed are: [ TypeOfOne] + arbitrary = elements [ Alphanumeric, BigAlphanumeric, HugeAlphanumeric, Password , Binary, BigBinary, HugeBinary , Date, DateTime , Boolean, Integer, Float + , Object ] instance Arbitrary Role where From cdb6d00bc8c610b25b44225746dc410c074a3e6e Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Tue, 1 Jan 2019 16:45:33 +0100 Subject: [PATCH 062/131] Make more use of minBound where possible --- src/Ampersand/ADL1/PrettyPrinters.hs | 24 +++---------- src/Ampersand/Basics/Languages.hs | 5 +-- src/Ampersand/Basics/PandocExtended.hs | 2 +- src/Ampersand/Core/ParseTree.hs | 5 ++- src/Ampersand/Input/ADL1/Lexer.hs | 42 ++++++++++++++-------- src/Ampersand/Test/Parser/ArbitraryTree.hs | 15 +++----- 6 files changed, 40 insertions(+), 53 deletions(-) diff --git a/src/Ampersand/ADL1/PrettyPrinters.hs b/src/Ampersand/ADL1/PrettyPrinters.hs index b65f9c9840..97a2916fd7 100644 --- a/src/Ampersand/ADL1/PrettyPrinters.hs +++ b/src/Ampersand/ADL1/PrettyPrinters.hs @@ -206,8 +206,7 @@ instance Pretty (PairViewSegment (Term TermPrim)) where pretty (PairViewExp _ srcTgt term) = pretty srcTgt <~> term instance Pretty SrcOrTgt where - pretty Src = text "SRC" - pretty Tgt = text "TGT" + pretty = text . map toUpper . show instance Pretty (P_Rule TermPrim) where pretty (P_Ru _ nm expr mean msg viol) = @@ -359,32 +358,17 @@ instance Pretty PClassify where else text "IS" <+> separate "/\\" (NEL.toList gen) ) instance Pretty Lang where - pretty Dutch = text "IN DUTCH" - pretty English = text "IN ENGLISH" + pretty x = text "IN" <+> (text . map toUpper . show $ x) instance Pretty P_Markup where pretty (P_Markup lang format str) = pretty lang <~> format <+\> quotePurpose str instance Pretty PandocFormat where - pretty p = case p of - ReST -> text "REST" - HTML -> text "HTML" - LaTeX -> text "LATEX" - Markdown -> text "MARKDOWN" + pretty = text . map toUpper . show instance Pretty Prop where - pretty p = text $ case p of - Uni -> "UNI" - Inj -> "INJ" - Sur -> "SUR" - Tot -> "TOT" - Sym -> "SYM" - Asy -> "ASY" - Trn -> "TRN" - Rfx -> "RFX" - Irf -> "IRF" - Prop -> "PROP" + pretty = text . map toUpper . show instance Pretty PAtomPair where pretty (PPair _ l r) = text "(" <+> pretty l diff --git a/src/Ampersand/Basics/Languages.hs b/src/Ampersand/Basics/Languages.hs index 672ea046e8..90d60e9b27 100644 --- a/src/Ampersand/Basics/Languages.hs +++ b/src/Ampersand/Basics/Languages.hs @@ -9,10 +9,7 @@ import Data.Char (toLower) import Data.Data import Data.List (isSuffixOf) -data Lang = Dutch | English deriving (Show, Eq, Ord,Typeable, Data) - -allLangs :: [Lang] -allLangs = [Dutch,English] -- All supported natural languages in Ampersand +data Lang = Dutch | English deriving (Show, Eq, Ord,Typeable, Data, Enum, Bounded) -- | Returns the plural of a given word based on a specific language plural :: Lang -> String -> String diff --git a/src/Ampersand/Basics/PandocExtended.hs b/src/Ampersand/Basics/PandocExtended.hs index d74c65a8ff..1814a35bc5 100644 --- a/src/Ampersand/Basics/PandocExtended.hs +++ b/src/Ampersand/Basics/PandocExtended.hs @@ -15,7 +15,7 @@ import Data.Data import qualified Data.Text as Text import Text.Pandoc hiding (Meta) -data PandocFormat = HTML | ReST | LaTeX | Markdown deriving (Eq, Show, Ord) +data PandocFormat = HTML | ReST | LaTeX | Markdown deriving (Eq, Show, Ord, Enum, Bounded) data Markup = Markup { amLang :: Lang -- No Maybe here! In the A-structure, it will be defined by the default if the P-structure does not define it. In the P-structure, the language is optional. diff --git a/src/Ampersand/Core/ParseTree.hs b/src/Ampersand/Core/ParseTree.hs index e9b5306803..34cee4db58 100644 --- a/src/Ampersand/Core/ParseTree.hs +++ b/src/Ampersand/Core/ParseTree.hs @@ -172,7 +172,7 @@ data TType | Date | DateTime | Boolean | Integer | Float | Object | TypeOfOne --special type for the special concept ONE. - deriving (Eq, Ord, Typeable) + deriving (Eq, Ord, Typeable, Enum, Bounded) instance Unique TType where showUnique = show instance Show TType where @@ -460,7 +460,7 @@ instance Traced a => Traced (Term a) where PCpl orig _ -> orig PBrk orig _ -> orig -data SrcOrTgt = Src | Tgt deriving (Show, Eq, Ord, Generic) +data SrcOrTgt = Src | Tgt deriving (Show, Eq, Ord, Generic, Enum, Bounded) instance Hashable SrcOrTgt instance Flippable SrcOrTgt where flp Src = Tgt @@ -599,7 +599,6 @@ data P_SubIfc a , si_str :: String -- Name of the interface that is reffered to } deriving (Show) - type P_BoxItemTermPrim = P_BoxItem TermPrim data P_BoxItem a = P_BxExpr { obj_nm :: String -- ^ view name of the object definition. The label has no meaning in the Compliant Service Layer, but is used in the generated user interface if it is not an empty string. diff --git a/src/Ampersand/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index 767b6b3101..f8d73e8c38 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +{-# LANGUAGE ScopedTypeVariables #-} module Ampersand.Input.ADL1.Lexer ( keywords , operators @@ -21,6 +22,7 @@ module Ampersand.Input.ADL1.Lexer ) where import Ampersand.Basics +import Ampersand.Core.ParseTree import Ampersand.Input.ADL1.FilePos(updatePos) import Ampersand.Input.ADL1.LexerMessage import Ampersand.Input.ADL1.LexerMonad @@ -36,24 +38,34 @@ import Numeric -- | Retrieves a list of keywords accepted by the ampersand language keywords :: [String] -- ^ The keywords keywords = nub [ "CONTEXT", "ENDCONTEXT" - , "IN", "ENGLISH", "DUTCH" - , "INCLUDE" + , "IN" + ] ++ + [map toUpper $ show x | x::Lang <- [minBound..] + ] ++ + [ "INCLUDE" , "META" , "PATTERN", "ENDPATTERN" , "CONCEPT" -- Keywords for Relation-statements , "RELATION", "PRAGMA", "MEANING" - , "UNI", "INJ", "SUR", "TOT", "SYM", "ASY", "TRN", "RFX", "IRF", "PROP" - , "POPULATION", "CONTAINS" + ] ++ + [map toUpper $ show x | x::Prop <-[minBound..] + ] ++ + [ "POPULATION", "CONTAINS" -- Keywords for rules - , "RULE", "MESSAGE", "VIOLATION", "TXT", "SRC", "TGT" - , "I", "V", "ONE" + , "RULE", "MESSAGE", "VIOLATION", "TXT" + ] ++ + [map toUpper $ show x | x::SrcOrTgt <-[minBound..] + ] ++ + [ "I", "V", "ONE" , "ROLE", "MAINTAINS" -- Keywords for purposes , "PURPOSE", "REF" - , "REST", "HTML", "LATEX", "MARKDOWN" + ] ++ + [map toUpper $ show x | x::PandocFormat <-[minBound..] + ] ++ -- Keywords for interfaces - , "INTERFACE", "FOR", "LINKTO", "API" + [ "INTERFACE", "FOR", "LINKTO", "API" , "BOX", "ROWS", "TABS", "COLS" -- Keywords for identitys , "IDENT" @@ -64,12 +76,12 @@ keywords = nub [ "CONTEXT", "ENDCONTEXT" , "CLASSIFY", "ISA", "IS" -- Keywords for TType: , "REPRESENT", "TYPE" - , "ALPHANUMERIC", "BIGALPHANUMERIC", "HUGEALPHANUMERIC", "PASSWORD" - , "BINARY", "BIGBINARY", "HUGEBINARY" - , "DATE", "DATETIME", "BOOLEAN", "INTEGER", "FLOAT", "AUTOINCREMENT" - , "OBJECT" + ]++ + [map toUpper $ show tt | tt::TType <- [minBound..] + , tt /= TypeOfOne + ]++ -- Keywords for values of atoms: - , "TRUE", "FALSE" --for booleans + [ "TRUE", "FALSE" --for booleans -- Experimental stuff: , "SERVICE", "EDITS" -- Depreciated keywords: @@ -419,7 +431,7 @@ getEscChar s@(x:xs) | isDigit x = case readDec s of ----------------------------------------------------------- returnToken :: Lexeme -> FilePos -> Lexer -> Lexer -returnToken lx pos continue posi input = do - let token = Tok lx pos +returnToken lx fpos continue posi input = do + let token = Tok lx fpos tokens <- continue posi input return (token:tokens) diff --git a/src/Ampersand/Test/Parser/ArbitraryTree.hs b/src/Ampersand/Test/Parser/ArbitraryTree.hs index e1a0888ea8..741f6de579 100644 --- a/src/Ampersand/Test/Parser/ArbitraryTree.hs +++ b/src/Ampersand/Test/Parser/ArbitraryTree.hs @@ -125,13 +125,8 @@ instance Arbitrary P_RoleRule where instance Arbitrary Representation where arbitrary = Repr <$> arbitrary <*> listOf1 upperId <*> arbitrary -instance Arbitrary TType where -- Not allowed are: [ TypeOfOne] - arbitrary = elements [ Alphanumeric, BigAlphanumeric, HugeAlphanumeric, Password - , Binary, BigBinary, HugeBinary - , Date, DateTime - , Boolean, Integer, Float - , Object - ] +instance Arbitrary TType where + arbitrary = elements [ tt | tt <- [minBound..] , tt /= TypeOfOne] instance Arbitrary Role where arbitrary = @@ -226,7 +221,7 @@ instance Arbitrary a => Arbitrary (PairViewSegmentTerm a) where arbitrary = PairViewSegmentTerm <$> arbitrary -- should be only PairViewSegment (Term a) instance Arbitrary SrcOrTgt where - arbitrary = elements[Src, Tgt] + arbitrary = elements [minBound..] instance Arbitrary a => Arbitrary (P_Rule a) where arbitrary = P_Ru <$> arbitrary <*> safeStr <*> ruleTerm <*> arbitrary <*> arbitrary @@ -334,7 +329,7 @@ instance Arbitrary PClassify where fun p s g = PClassify p s (NEL.fromList g) instance Arbitrary Lang where - arbitrary = elements [Dutch, English] + arbitrary = elements [minBound..] instance Arbitrary P_Markup where arbitrary = P_Markup <$> arbitrary <*> arbitrary <*> safeStr `suchThat` noEndMarkup @@ -343,7 +338,7 @@ instance Arbitrary P_Markup where noEndMarkup = not . isInfixOf "+}" instance Arbitrary PandocFormat where - arbitrary = elements [HTML, ReST, LaTeX, Markdown] + arbitrary = elements [minBound..] instance Arbitrary Prop where arbitrary = elements [minBound..] From db9bd2845b326d9c97c590ca525701414ac5c099 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Tue, 1 Jan 2019 19:02:18 +0100 Subject: [PATCH 063/131] fix broken columname. --- src/Ampersand/FSpec/SQL.hs | 59 +++++++++++++++++++------------------- 1 file changed, 30 insertions(+), 29 deletions(-) diff --git a/src/Ampersand/FSpec/SQL.hs b/src/Ampersand/FSpec/SQL.hs index b26099caef..079af87a75 100644 --- a/src/Ampersand/FSpec/SQL.hs +++ b/src/Ampersand/FSpec/SQL.hs @@ -378,7 +378,7 @@ nonSpecialSelectExpr fSpec expr= esR = mapMaybe isR exprs where isR :: Expression -> Maybe (Expression,Name) - isR e = case isInBroadQuery fSpec (source . head $ exprs) e of + isR e = case attInBroadQuery fSpec (source . head $ exprs) e of Nothing -> Nothing Just att -> Just (e, QName . name $ att) esRest :: [Expression] -- all other conjuctions @@ -1173,16 +1173,16 @@ broadQuery fSpec obj = Nothing -> toSQL baseBinExpr Just InterfaceRef{} -> toSQL baseBinExpr Just Box{siObjs=sObjs} -> - case mapMaybe (isInBroadQuery fSpec . target . objExpression $ obj) [objExpression x | BxExpr x <- sObjs] of + case filter (isInBroadQuery fSpec (target . objExpression $ obj)) [x | BxExpr x <- sObjs] of [] -> toSQL baseBinExpr xs -> extendWithCols xs baseBinExpr where baseBinExpr = getBinQueryExprPlaceholder fSpec . objExpression $ obj - extendWithCols :: [SqlAttribute] -> BinQueryExpr -> QueryExpr - extendWithCols atts bqe - | null atts = plainQE + extendWithCols :: [ObjectDef] -> BinQueryExpr -> QueryExpr + extendWithCols objs bqe + | null objs = plainQE | otherwise = case bqe of BSE{} -> newSelect (newSelectList,newFrom,newWhere) @@ -1191,14 +1191,14 @@ broadQuery fSpec obj = case qeFrom plainQE of [TRSimple [n]] -> if n == sqlConcept fSpec tableCpt - then ( qeSelectList plainQE ++ map (makeCol Nothing) atts + then ( qeSelectList plainQE ++ map (makeCol Nothing) objs , qeFrom plainQE , qeWhere plainQE ) else subThings _ -> subThings BCQE{} -> newSelect subThings - BQEComment _ x -> extendWithCols atts x + BQEComment _ x -> extendWithCols objs x where newSelect (sl,f,w) = Select { qeSetQuantifier = Distinct @@ -1212,27 +1212,29 @@ broadQuery fSpec obj = , qeFetchFirst = Nothing } plainQE = toSQL bqe - makeCol :: Maybe Name -> SqlAttribute -> (ValueExpr, Maybe Name) - makeCol tableName att = - ( Iden ( case tableName of - Nothing -> [QName (name att)] - Just tab -> [tab,QName (name att)] - ) - , Just ( QName $ -- The name is not sufficient for two reasons: - -- 1) the columname must be unique. For that reason, it is prefixed: - "ifc_"++ - -- 2) It must be injective. Because SQL deletes trailing spaces, - -- we have to cope with that: - escapeIdentifier (name att) - ) - ) + makeCol :: Maybe Name -> ObjectDef -> (ValueExpr, Maybe Name) + makeCol tableName col = + case attInBroadQuery fSpec (target . objExpression $ obj) (objExpression col) of + Nothing -> fatal ("this is unexpected behaviour. "++show col) + Just att -> ( Iden ( case tableName of + Nothing -> [QName (name att)] + Just tab -> [tab,QName (name att)] + ) + , Just ( QName $ -- The name is not sufficient for two reasons: + -- 1) the columname must be unique. For that reason, it is prefixed: + "ifc_"++ + -- 2) It must be injective. Because SQL deletes trailing spaces, + -- we have to cope with that: + escapeIdentifier (name col) + ) + ) subThings :: ( [(ValueExpr, Maybe Name)] , [TableRef] , Maybe ValueExpr ) subThings = ( [ (Iden [org,sourceAlias] , Just sourceAlias) , (Iden [org,targetAlias] , Just targetAlias) - ]++ map (makeCol . Just $ ct) atts + ]++ map (makeCol . Just $ ct) objs , [ TRQueryExpr plainQE `as` org , sqlConceptTable fSpec tableCpt `as` ct ] @@ -1244,13 +1246,13 @@ broadQuery fSpec obj = where org = Name "org" ct = Name "cptTbl" - tableCpt = source . attExpr . head $ atts + tableCpt = source . objExpression . head $ objs -- Iff the expression is implemented in the concepttable of the given concept -- AND can be read from the same row, the implementing -- attribute is returnd -isInBroadQuery :: FSpec -> A_Concept -> Expression -> Maybe SqlAttribute -isInBroadQuery fSpec cpt = get +attInBroadQuery :: FSpec -> A_Concept -> Expression -> Maybe SqlAttribute +attInBroadQuery fSpec cpt = get where get expr = case expr of @@ -1276,12 +1278,11 @@ isInBroadQuery fSpec cpt = get EFlp (EBrk e) -> get (EFlp e) _ -> Nothing --- (isUni subExpr) && False --- && (isJust . attThatisInTableOf (target subExpr) $ sObj) --- && (source ctxExpr /= target ctxExpr || null (primitives ctxExpr)) --this is required to prevent conflicts in rows of the same broad table. See explanation in issue #627 --- && (target ctxExpr /= target subExpr || (not . isFlipped $ subExpr)) -- see issue #760 for motivation of this line. (broadTable, _) = getConceptTableInfo fSpec cpt +isInBroadQuery :: FSpec -> A_Concept -> ObjectDef -> Bool +isInBroadQuery fSpec cpt obj = isJust $ attInBroadQuery fSpec cpt (objExpression obj) + theONESingleton :: Col theONESingleton = Col { cTable = [] , cCol = [] From b26f1162ab8aaf61108e5abc5813316373a795ea Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink <> Date: Tue, 1 Jan 2019 21:55:08 +0100 Subject: [PATCH 064/131] Haskell part of solution for #866 Automatically reload javascript resources when needed --- src/Ampersand/Prototype/GenFrontend.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Ampersand/Prototype/GenFrontend.hs b/src/Ampersand/Prototype/GenFrontend.hs index 48c3b4114c..829d164b20 100644 --- a/src/Ampersand/Prototype/GenFrontend.hs +++ b/src/Ampersand/Prototype/GenFrontend.hs @@ -17,6 +17,7 @@ import Data.Char import Data.Data import Data.List import Data.Maybe +import Data.Time.Clock.POSIX import Network.HTTP.Simple import System.Directory import System.FilePath @@ -68,19 +69,23 @@ getTemplateDir fSpec = dirPrototype (getOpts fSpec) "templates" doGenFrontend :: FSpec -> IO () doGenFrontend fSpec = do { putStrLn "Generating frontend.." - ; isCleanInstall <- downloadPrototypeFramework (getOpts fSpec) + ; isCleanInstall <- downloadPrototypeFramework options ; copyTemplates fSpec ; feInterfaces <- buildInterfaces fSpec ; genViewInterfaces fSpec feInterfaces ; genControllerInterfaces fSpec feInterfaces ; genRouteProvider fSpec feInterfaces + ; timestamp <- getPOSIXTime >>= return . show . round + ; writePrototypeAppFile options ".timestamp" timestamp -- this file is used by the prototype framework to prevent browser from using the wrong files from cache ; copyCustomizations fSpec -- ; deleteTemplateDir fSpec -- don't delete template dir anymore, because it is required the next time the frontend is generated ; when isCleanInstall $ do putStrLn "Installing dependencies.." - installComposerLibs (getOpts fSpec) + installComposerLibs options ; putStrLn "Frontend generated." } + where + options = getOpts fSpec copyTemplates :: FSpec -> IO () copyTemplates fSpec = @@ -479,7 +484,7 @@ downloadPrototypeFramework opts = [OptVerbose | verboseP opts] ++ [OptDestination destination] extractFilesFromArchive zipoptions archive - writeFile (destination ".prototypeSHA") + writeFile (destination ".frameworkSHA") (show . zComment $ archive) return x else return x From 1a589f13563ffceb9982d4dbb32e2d61d783ceec Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Tue, 1 Jan 2019 23:51:04 +0100 Subject: [PATCH 065/131] Add possibility to add warnings to output --- app/Main.hs | 3 +- src/Ampersand/ADL1/P2A_Converters.hs | 2 +- src/Ampersand/FSpec/ShowMeatGrinder.hs | 24 ++++----- src/Ampersand/FSpec/ToFSpec/CreateFspec.hs | 8 +-- src/Ampersand/Input/ADL1/CtxError.hs | 57 ++++++++++++++++------ src/Ampersand/Input/Parsing.hs | 14 +++--- src/Ampersand/Input/PreProcessor.hs | 2 +- src/Ampersand/Input/Xslx/XLSX.hs | 8 +-- src/Ampersand/Test/Parser/ParserTest.hs | 19 ++++---- src/Ampersand/Test/Parser/QuickChecks.hs | 4 +- src/Ampersand/Test/RunAmpersand.hs | 2 +- 11 files changed, 89 insertions(+), 54 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 9d72024532..ab1d8b3795 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -20,7 +20,8 @@ main = Errors err -> exitWith . NoValidFSpec . intersperse (replicate 30 '=') . fmap showErr . NEL.toList $ err - Checked multi -> + Checked multi ws -> do + showWarnings ws generateAmpersandOutput multi } diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index a7167afcec..8a6ce72d6c 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -52,7 +52,7 @@ mustBeConceptBecauseMath tp = let fatalV :: (?loc :: CallStack) => a fatalV = fatal "A concept turned out to be a built-in type." in case getAsConcept fatalV tp of - Checked v -> v + Checked v _ -> v _ -> fatalV -- NOTE: Static checks like checkPurposes should ideally occur on the P-structure before type-checking, as it makes little diff --git a/src/Ampersand/FSpec/ShowMeatGrinder.hs b/src/Ampersand/FSpec/ShowMeatGrinder.hs index 18c53a2fd0..4ae0df32cf 100644 --- a/src/Ampersand/FSpec/ShowMeatGrinder.hs +++ b/src/Ampersand/FSpec/ShowMeatGrinder.hs @@ -65,17 +65,19 @@ extractFromPop formalAmpersand pop = tuples :: [PAtomPair] tuples = case string2AValue . unwords . words . show . popPairs $ pop of - Checked x -> case checkAtomValues (popRelation pop) x of - Checked _ -> x - Errors errs -> fatal . unlines $ - [ "ERROR in tupels that are generated in the meatgrinder for relation" - , " "++showRel (popRelation pop) - ] ++ (intersperse (replicate 30 '=') . fmap showErr . NEL.toList $ errs) - - Errors errs -> fatal . unlines $ - [ "ERROR in tupels that are generated in the meatgrinder for relation" - , " "++showRel (popRelation pop) - ] ++ (intersperse (replicate 30 '=') . fmap showErr . NEL.toList $ errs) + Checked x _ + -> case checkAtomValues (popRelation pop) x of + Checked _ _ -> x + Errors errs -> fatal . unlines $ + [ "ERROR in tupels that are generated in the meatgrinder for relation" + , " "++showRel (popRelation pop) + ] ++ (intersperse (replicate 30 '=') . fmap showErr . NEL.toList $ errs) + + Errors errs + -> fatal . unlines $ + [ "ERROR in tupels that are generated in the meatgrinder for relation" + , " "++showRel (popRelation pop) + ] ++ (intersperse (replicate 30 '=') . fmap showErr . NEL.toList $ errs) checkAtomValues :: Relation -> [PAtomPair] -> Guarded AAtomPairs checkAtomValues rel pps = Set.fromList <$> (sequence $ map fun pps) where diff --git a/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs b/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs index e2ca6441b0..8ec72b687d 100644 --- a/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs +++ b/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs @@ -47,7 +47,7 @@ createMulti opts = let fAmpFSpec :: FSpec fAmpFSpec = case pCtx2Fspec fAmpP_Ctx of - Checked f -> f + Checked f _ -> f Errors errs -> fatal . unlines $ "The FormalAmpersand ADL scripts are not type correct:" : (intersperse (replicate 30 '=') . fmap showErr . NEL.toList $ errs) @@ -82,7 +82,7 @@ createMulti opts = if genRapPopulationOnly opts then case userGFSpec of Errors err -> Errors err - Checked usrFSpec + Checked usrFSpec _ -> let grinded :: P_Context grinded = grind fAmpFSpec usrFSpec -- the user's sourcefile grinded, i.e. a P_Context containing population in terms of formalAmpersand. metaPopPCtx :: Guarded P_Context @@ -100,11 +100,11 @@ createMulti opts = writeMetaFile :: FSpec -> Guarded FSpec -> IO (Guarded ()) writeMetaFile faSpec userSpec = case makeMetaFile faSpec <$> userSpec of - Checked (filePath,metaContents) -> + Checked (filePath,metaContents) ws -> do verboseLn opts ("Generating meta file in path "++dirOutput opts) writeFile (dirOutput opts filePath) metaContents verboseLn opts ("\""++filePath++"\" written") - return (pure ()) + return $ Checked () ws Errors err -> return (Errors err) pCtx2Fspec :: Guarded P_Context -> Guarded FSpec diff --git a/src/Ampersand/Input/ADL1/CtxError.hs b/src/Ampersand/Input/ADL1/CtxError.hs index 9b1f1efa0e..4f06f304d9 100644 --- a/src/Ampersand/Input/ADL1/CtxError.hs +++ b/src/Ampersand/Input/ADL1/CtxError.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FunctionalDependencies #-} module Ampersand.Input.ADL1.CtxError ( CtxError(PE) + , Warning , showErr, makeError , cannotDisambiguate , mustBeOrdered, mustBeOrderedLst, mustBeOrderedConcLst @@ -24,6 +25,8 @@ module Ampersand.Input.ADL1.CtxError , mkTypeMismatchError , mkMultipleRootsError , mkCrudForRefInterfaceError + , addWarning + , showWarning, showWarnings , Guarded(..) -- If you use Guarded in a monad, make sure you use "ApplicativeDo" in order to get error messages in parallel. , whenCheckedIO, whenChecked, whenError ) @@ -34,6 +37,8 @@ module Ampersand.Input.ADL1.CtxError -- see `getOneExactly' / `GetOneGuarded' as a nice example -- Although I also consider it ill practice to export PE -- for the same reasons, I did this as a quick fix for the parse errors +-- HJO: I consider it ill practice to export any Warning constructors as well, for the same reasons as SJC stated above. + where import Ampersand.ADL1 @@ -56,7 +61,7 @@ instance Show CtxError where show (PE msg) = "PE " ++ messageString msg errors :: Guarded t -> Maybe (NEL.NonEmpty CtxError) -errors (Checked _) = Nothing +errors (Checked _ _) = Nothing errors (Errors lst) = Just lst makeError :: String -> Guarded a @@ -142,7 +147,7 @@ nonMatchingRepresentTypes orig wrongType rightType class GetOneGuarded a b | b -> a where {-# MINIMAL getOneExactly | hasNone #-} -- we don't want endless loops, do we? getOneExactly :: b -> [a] -> Guarded a - getOneExactly _ [a] = Checked a + getOneExactly _ [a] = pure a getOneExactly o [] = hasNone o getOneExactly o _ = case errors (hasNone o :: Guarded a) of @@ -158,7 +163,7 @@ instance Pretty a => GetOneGuarded SubInterface (P_SubIfc a) where CTXE (origin o)$ "Required: one A-subinterface in "++showP o instance GetOneGuarded Expression P_NamedRel where - getOneExactly _ [d] = Checked d + getOneExactly _ [d] = pure d getOneExactly o [] = Errors . pure $ CTXE (origin o) $ "No relation for "++showP o getOneExactly o lst = Errors . pure $ CTXE (origin o) $ @@ -383,19 +388,37 @@ writeBind (ECpl e) writeBind e = "("++showA e++") /\\ "++showA (EDcV (sign e)) -data Guarded a = Errors (NEL.NonEmpty CtxError) | Checked a deriving Show +data Warning = Warning Origin String +instance Show Warning where + show (Warning o s) = "Warning: " ++ show o ++ " " ++ show s + +addWarning :: Warning -> Guarded a -> Guarded a +addWarning _ (Errors a) = Errors a +addWarning w (Checked a ws) = Checked a (ws <> [w]) +addWarnings :: [Warning] -> Guarded a -> Guarded a +addWarnings ws ga = + case ga of + Checked a ws' -> Checked a (ws <> ws') + Errors a -> Errors a +showWarning :: Warning -> String +showWarning = show + +data Guarded a = + Errors (NEL.NonEmpty CtxError) + | Checked a [Warning] + deriving Show instance Functor Guarded where fmap _ (Errors a) = Errors a - fmap f (Checked a) = Checked (f a) + fmap f (Checked a ws) = Checked (f a) ws instance Applicative Guarded where - pure = Checked - (<*>) (Checked f) (Checked a) = Checked (f a) - (<*>) (Errors a) (Checked _) = Errors a - (<*>) (Checked _) (Errors b) = Errors b + pure x = Checked x [] + (<*>) (Checked f ws) (Checked a ws') = Checked (f a) (ws<>ws') + (<*>) (Errors a) (Checked _ _) = Errors a + (<*>) (Checked _ _) (Errors b) = Errors b (<*>) (Errors a) (Errors b) = Errors (a >> b) instance Monad Guarded where - (>>=) (Checked a) f = f a + (>>=) (Checked a ws) f = addWarnings ws (f a) (>>=) (Errors x) _ = Errors x -- Shorthand for working with Guarded in IO @@ -403,18 +426,19 @@ whenCheckedIO :: IO (Guarded a) -> (a -> IO (Guarded b)) -> IO (Guarded b) whenCheckedIO ioGA fIOGB = do gA <- ioGA case gA of - Errors err -> return (Errors err) - Checked a -> fIOGB a + Errors err -> return $ Errors err + Checked a ws1 -> do gb <- fIOGB a + return $ addWarnings ws1 gb whenChecked :: Guarded a -> (a -> Guarded b) -> Guarded b whenChecked ga fgb = case ga of - Checked a -> fgb a + Checked a ws -> addWarnings ws $ fgb a Errors err -> Errors err whenError :: Guarded a -> Guarded a -> Guarded a whenError (Errors _) a = a -whenError a@(Checked _) _ = a +whenError a@(Checked _ _) _ = a showErr :: CtxError -> String @@ -432,3 +456,8 @@ showFullOrig x = show x showMinorOrigin :: Origin -> String showMinorOrigin (FileLoc (FilePos _ line column) _) = "line " ++ show line ++" : "++show column showMinorOrigin v = show v + +showWarnings :: [Warning] -> IO () +showWarnings = mapM_ putStrLn + . L.intercalate [""] + . map (lines . showWarning) diff --git a/src/Ampersand/Input/Parsing.hs b/src/Ampersand/Input/Parsing.hs index 686af6afad..b413012f51 100644 --- a/src/Ampersand/Input/Parsing.hs +++ b/src/Ampersand/Input/Parsing.hs @@ -47,7 +47,7 @@ parseSystemContext opts = parseThing opts (ParseCandidate Nothing (Just $ Origin parseThing :: Options -> ParseCandidate -> IO (Guarded P_Context) parseThing opts pc = whenCheckedIO (parseADLs opts [] [pc] ) $ \ctxts -> - return $ Checked $ foldl1 mergeContexts ctxts + return . pure $ foldl1 mergeContexts ctxts -- | Parses several ADL files parseADLs :: Options -- ^ The options given through the command line @@ -56,7 +56,7 @@ parseADLs :: Options -- ^ The options given through the command -> IO (Guarded [P_Context]) -- ^ The resulting contexts parseADLs opts parsedFilePaths fpIncludes = case fpIncludes of - [] -> return $ Checked [] + [] -> return $ pure [] x:xs -> if x `elem` parsedFilePaths then parseADLs opts parsedFilePaths xs else whenCheckedIO (parseSingleADL opts x) parseTheRest @@ -113,7 +113,7 @@ parseSingleADL opts pc (return $ parseCtx filePath =<< (preProcess filePath (pcDefineds pc) fileContents)) $ \(ctxts, includes) -> do parseCandidates <- mapM include2ParseCandidate includes - return (Checked (ctxts, parseCandidates)) + return . pure $ (ctxts, parseCandidates) } where include2ParseCandidate :: Include -> IO ParseCandidate @@ -171,7 +171,7 @@ parse p fn ts = case runP p pos' fn ts of --TODO: Add language support to the parser errors Left err -> Errors $ parseErrors English err - Right a -> Checked a + Right a -> pure a where pos' | null ts = initPos fn | otherwise = tokPos (head ts) @@ -195,7 +195,7 @@ runParser parser filename input = in case lexed of Left err -> Errors . pure $ lexerError2CtxError err --TODO: Do something with the warnings. The warnings cannot be shown with the current Guarded data type - Right (tokens, _) -> whenChecked (parse parser filename tokens) Checked + Right (tokens, lexerWarnings) -> whenChecked (parse parser filename tokens) pure -- | Parses an isolated rule -- In order to read derivation rules, we use the Ampersand parser. @@ -204,8 +204,8 @@ parseRule :: String -- ^ The string to be parsed -> Term TermPrim -- ^ The resulting rule parseRule str = case runParser pRule "inside Haskell code" str of - Checked result -> result - Errors msg -> fatal ("Parse errors in "++str++":\n "++show msg) + Checked result _ -> result + Errors msg -> fatal ("Parse errors in "++str++":\n "++show msg) -- | Parses an Ampersand context parseCtx :: FilePath -- ^ The file name (used for error messages) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index d214f3fde5..8c59c96cde 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -28,7 +28,7 @@ preProcess :: String -- ^ filename, used only for error reporting -> Guarded String -- ^ result, The result of processing preProcess f d i = case preProcess' f d i of (Left err) -> Errors $ (PE . Message . show $ err) NEL.:| [] - (Right out) -> Checked out + (Right out) -> Checked out [] -- | Runs the preProcessor on input preProcess' :: String -- ^ filename, used only for error reporting diff --git a/src/Ampersand/Input/Xslx/XLSX.hs b/src/Ampersand/Input/Xslx/XLSX.hs index f5d9e8c0cb..ab312410ed 100644 --- a/src/Ampersand/Input/Xslx/XLSX.hs +++ b/src/Ampersand/Input/Xslx/XLSX.hs @@ -33,9 +33,11 @@ parseXlsxFile opts mFk file = return . xlsx2pContext . toXlsx $ bytestr where xlsx2pContext :: Xlsx -> Guarded [P_Population] - xlsx2pContext xlsx - = Checked $ concatMap (toPops opts file) $ - concatMap theSheetCellsForTable (xlsx ^. xlSheets) + xlsx2pContext xlsx = Checked pop [] + where + pop = concatMap (toPops opts file) + . concatMap theSheetCellsForTable + $ (xlsx ^. xlSheets) data SheetCellsForTable = Mapping{ theSheetName :: String diff --git a/src/Ampersand/Test/Parser/ParserTest.hs b/src/Ampersand/Test/Parser/ParserTest.hs index 92da9bc0eb..ec9b7f456a 100644 --- a/src/Ampersand/Test/Parser/ParserTest.hs +++ b/src/Ampersand/Test/Parser/ParserTest.hs @@ -3,13 +3,13 @@ module Ampersand.Test.Parser.ParserTest ( parseReparse, parseScripts, showErrors ) where -import Ampersand.ADL1.PrettyPrinters(prettyPrint) -import Ampersand.Basics -import Ampersand.Core.ParseTree -import Ampersand.Input.ADL1.CtxError (Guarded(..),whenChecked,CtxError) -import Ampersand.Input.ADL1.Parser -import Ampersand.Input.Parsing -import Ampersand.Misc +import Ampersand.ADL1.PrettyPrinters(prettyPrint) +import Ampersand.Basics +import Ampersand.Core.ParseTree +import Ampersand.Input.ADL1.CtxError (Guarded(..),whenChecked,CtxError,showWarnings) +import Ampersand.Input.ADL1.Parser +import Ampersand.Input.Parsing +import Ampersand.Misc import qualified Data.List.NonEmpty as NEL (toList) -- Tries to parse all the given files @@ -18,8 +18,9 @@ parseScripts _ [] = return True parseScripts opts (f:fs) = do parsed <- parseADL opts f case parsed of - Checked _ -> do + Checked _ ws -> do putStrLn ("Parsed: " ++ f) + showWarnings ws parseScripts opts fs Errors e -> do putStrLn ("Cannot parse: " ++ f) @@ -34,7 +35,7 @@ showErrors [] = return () showErrors (e:es) = do { printErrLn e; showErrors es } parse :: FilePath -> String -> Guarded P_Context -parse file txt = whenChecked (runParser pContext file txt) (Checked . fst) +parse file txt = whenChecked (runParser pContext file txt) (pure . fst) parseReparse :: FilePath -> String -> Guarded P_Context parseReparse file txt = whenChecked (parse file txt) reparse diff --git a/src/Ampersand/Test/Parser/QuickChecks.hs b/src/Ampersand/Test/Parser/QuickChecks.hs index 9d67beb081..59d7f0a4ba 100644 --- a/src/Ampersand/Test/Parser/QuickChecks.hs +++ b/src/Ampersand/Test/Parser/QuickChecks.hs @@ -14,8 +14,8 @@ import Test.QuickCheck(Args(..), quickCheckWithResult, Testable, Result(..)) -- Tries to parse a string, and if successful, tests the result with the given function testParse :: String -> (P_Context -> Bool) -> Bool testParse text check = case parseReparse "File generated by QuickCheck. When you see it in an error, there is something wrong with the parser!" text of - Checked a -> check a - Errors e -> trace (show e ++ "\n" ++ text) False + Checked a _ -> check a + Errors e -> trace (show e ++ "\n" ++ text) False -- TODO: Errors e -> do { showErrors e; return False } -- Tests whether the parsed context is equal to the original one diff --git a/src/Ampersand/Test/RunAmpersand.hs b/src/Ampersand/Test/RunAmpersand.hs index 41ade82514..76f38e24e9 100644 --- a/src/Ampersand/Test/RunAmpersand.hs +++ b/src/Ampersand/Test/RunAmpersand.hs @@ -19,4 +19,4 @@ runAmpersand opts file = case gFSpec of Errors err -> return $ NEL.toList err --TODO: Do something with the fSpec - Checked _ -> return [] + Checked _ _ -> return [] From 3b41a52f186ab7bd6c1005209c20a8a50536a90d Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Wed, 2 Jan 2019 09:33:34 +0100 Subject: [PATCH 066/131] minor fix --- src/Ampersand/Input.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/Input.hs b/src/Ampersand/Input.hs index 8c92fc7367..61fc7af6c2 100644 --- a/src/Ampersand/Input.hs +++ b/src/Ampersand/Input.hs @@ -2,6 +2,6 @@ module Ampersand.Input ( module Ampersand.Input.ADL1.CtxError , module Ampersand.Input.Parsing ) where -import Ampersand.Input.ADL1.CtxError (CtxError,Guarded(..),showErr) +import Ampersand.Input.ADL1.CtxError (CtxError,Warning,Guarded(..),showErr,showWarning,showWarnings) import Ampersand.Input.Parsing (parseADL,parseMeta,parseSystemContext,parseRule,runParser) \ No newline at end of file From f221f4df1c10d19724eb36bc46b054c93bcc2099 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Wed, 2 Jan 2019 10:18:14 +0100 Subject: [PATCH 067/131] remove warning --- src/Ampersand/FSpec/ShowHS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/FSpec/ShowHS.hs b/src/Ampersand/FSpec/ShowHS.hs index 021e74b59d..6956935e7c 100644 --- a/src/Ampersand/FSpec/ShowHS.hs +++ b/src/Ampersand/FSpec/ShowHS.hs @@ -2,7 +2,7 @@ module Ampersand.FSpec.ShowHS (ShowHS(..),ShowHSName(..),fSpec2Haskell,haskellIdentifier) where -import Ampersand.Basics hiding (indent) +import Ampersand.Basics import Ampersand.ADL1 import Ampersand.Core.ShowAStruct (AStruct(..)) -- for traceability, we generate comments in the Haskell code. import Ampersand.FSpec.FSpec From 69e87f1b2a489d1603f0cc020a5e552ac81b5606 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Wed, 2 Jan 2019 10:23:45 +0100 Subject: [PATCH 068/131] remove warnings --- src/Ampersand/FSpec/Motivations.hs | 1 - src/Ampersand/Output/FSpec2Pandoc.hs | 1 - src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs | 9 +++++---- 3 files changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Ampersand/FSpec/Motivations.hs b/src/Ampersand/FSpec/Motivations.hs index 46aa129a4e..e784d4d8a7 100644 --- a/src/Ampersand/FSpec/Motivations.hs +++ b/src/Ampersand/FSpec/Motivations.hs @@ -64,7 +64,6 @@ class Named a => HasMeaning a where [m] -> Just m _ -> fatal ("In the "++show l++" language, too many meanings given for "++name x ++".") meanings :: a -> [Meaning] - generatedMeaning :: Lang -> a -> Meaning {-# MINIMAL meanings #-} instance HasMeaning Rule where diff --git a/src/Ampersand/Output/FSpec2Pandoc.hs b/src/Ampersand/Output/FSpec2Pandoc.hs index 15cab451f6..16f54c65f2 100644 --- a/src/Ampersand/Output/FSpec2Pandoc.hs +++ b/src/Ampersand/Output/FSpec2Pandoc.hs @@ -57,7 +57,6 @@ fSpec2Pandoc fSpec = (thePandoc,thePictures) l :: LocalizedStr -> String l = localize (fsLang fSpec) - wrap' p = p wrap :: Pandoc -> Pandoc wrap (Pandoc meta blocks) = Pandoc meta $ runCrossRef m' Nothing crossRefBlocks blocks diff --git a/src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs b/src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs index a2a650a2d0..7c085dc7a5 100644 --- a/src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs +++ b/src/Ampersand/Output/ToPandoc/SharedAmongChapters.hs @@ -130,17 +130,17 @@ hyperTarget fSpec a = <>printMeaning (fsLang fSpec) r ) - XRefConceptualAnalysisRelation d + XRefConceptualAnalysisRelation _d -> Right $ spanWith (xSafeLabel a,[],[]) ( (text.l) (NL "Relatie ",EN "Relation ") -- <> (str . show . numberOf fSpec $ d) ) - XRefConceptualAnalysisRule r + XRefConceptualAnalysisRule _r -> Right $ spanWith (xSafeLabel a,[],[]) ( (text.l) (NL "Regel ",EN "Rule ") -- <> (str . show . numberOf fSpec $ r) ) - XRefConceptualAnalysisExpression r + XRefConceptualAnalysisExpression _r -> Right $ spanWith (xSafeLabel a,[],[]) ( (text.l) (NL "Regel ",EN "Rule ") -- <> (str . show . numberOf fSpec $ r) @@ -254,6 +254,7 @@ refStuff x = ("relation","rule" ,"expression","pattern","theme") +{- class NumberedThing a where numberOf :: FSpec -> a -> Int @@ -281,7 +282,7 @@ instance NumberedThing A_Concept where where ns = concatMap cptsOfTheme (orderingByTheme fSpec) isTheOne :: Numbered CptCont -> Bool isTheOne = (c ==) . cCpt . theLoad - +-} -- | This function orders the content to print by theme. It returns a list of -- tripples by theme. The last tripple might not have a theme, but will contain everything From 1519b10efedef82e5b8c85081af59713d63638b7 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Wed, 2 Jan 2019 10:49:26 +0100 Subject: [PATCH 069/131] use generation timestamp --- src/Ampersand/Prototype/GenFrontend.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Ampersand/Prototype/GenFrontend.hs b/src/Ampersand/Prototype/GenFrontend.hs index 829d164b20..1ef8188639 100644 --- a/src/Ampersand/Prototype/GenFrontend.hs +++ b/src/Ampersand/Prototype/GenFrontend.hs @@ -17,7 +17,6 @@ import Data.Char import Data.Data import Data.List import Data.Maybe -import Data.Time.Clock.POSIX import Network.HTTP.Simple import System.Directory import System.FilePath @@ -75,8 +74,7 @@ doGenFrontend fSpec = ; genViewInterfaces fSpec feInterfaces ; genControllerInterfaces fSpec feInterfaces ; genRouteProvider fSpec feInterfaces - ; timestamp <- getPOSIXTime >>= return . show . round - ; writePrototypeAppFile options ".timestamp" timestamp -- this file is used by the prototype framework to prevent browser from using the wrong files from cache + ; writePrototypeAppFile options ".timestamp" (show . genTime . getOpts $ fSpec) -- this file is used by the prototype framework to prevent browser from using the wrong files from cache ; copyCustomizations fSpec -- ; deleteTemplateDir fSpec -- don't delete template dir anymore, because it is required the next time the frontend is generated ; when isCleanInstall $ do From 1fedf704e4fed228f3f0e2773ad1ba6bd6ec97da Mon Sep 17 00:00:00 2001 From: bart Date: Wed, 2 Jan 2019 11:33:58 +0100 Subject: [PATCH 070/131] Fix bug: Preprocessor did not recognize --# The preprocessor dit not recognize lines starting with --# as preprocessor directives. Thus, it was nearly an identity function. All it did was strip --# between an include and the flags list. The issue was simple. The used 'whitespace' parser wanted 1 or more spaces rather than 0 or more. --- src/Ampersand/Input/PreProcessor.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index fb0174fbc5..5656b98c3a 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -131,7 +131,7 @@ ifEnd = (const EndIf) <$> (try(string "ENDIF") *> untilEOL) -- Helper Lexers whitespace :: Lexer () -whitespace = skipMany1 $ satisfy (\x -> isSpace x && not (x == '\n' || x == '\r')) +whitespace = skipMany $ satisfy (\x -> isSpace x && not (x == '\n' || x == '\r')) untilEOL :: Lexer String untilEOL = manyTill anyChar endOfLine From 61f4637f8feac00499c7ec2d73be25e52f51bfac Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Wed, 2 Jan 2019 14:11:18 +0100 Subject: [PATCH 071/131] Improve timestamp output #866 --- src/Ampersand/Prototype/GenFrontend.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Ampersand/Prototype/GenFrontend.hs b/src/Ampersand/Prototype/GenFrontend.hs index 1ef8188639..40bdcf074e 100644 --- a/src/Ampersand/Prototype/GenFrontend.hs +++ b/src/Ampersand/Prototype/GenFrontend.hs @@ -15,6 +15,7 @@ import Control.Monad import qualified Data.ByteString.Lazy as BL import Data.Char import Data.Data +import Data.Hashable (hash) import Data.List import Data.Maybe import Network.HTTP.Simple @@ -74,7 +75,7 @@ doGenFrontend fSpec = ; genViewInterfaces fSpec feInterfaces ; genControllerInterfaces fSpec feInterfaces ; genRouteProvider fSpec feInterfaces - ; writePrototypeAppFile options ".timestamp" (show . genTime . getOpts $ fSpec) -- this file is used by the prototype framework to prevent browser from using the wrong files from cache + ; writePrototypeAppFile options ".timestamp" (show . hash . show . genTime $ options) -- this hashed timestamp is used by the prototype framework to prevent browser from using the wrong files from cache ; copyCustomizations fSpec -- ; deleteTemplateDir fSpec -- don't delete template dir anymore, because it is required the next time the frontend is generated ; when isCleanInstall $ do From 5f6d582229c6fd8651a0c8c33aaa957ffde828bc Mon Sep 17 00:00:00 2001 From: bart Date: Wed, 2 Jan 2019 15:13:38 +0100 Subject: [PATCH 072/131] Feature: allow disabling preprocessor flags. When file A imports file B with flag FOO, then B can import file C with flag !FOO to ensure flag FOO is not enabled in file C. Before this change, imports of imports would unconditionally receive all flags of their parent imports. Note that technically, one can use the preprocessor to comment out imports. Because reading imports isn't done by the preprocessor. Hence, one could do: --# IF DISABLE_IMPORT IMPORT bar --# ["!FOO", "OTHERFLAG"] --# ELSE IMPORT bar --# ["OTHERFLAG"] --# ENDIF In support of this chance, we refactored aswell. In an import-candidate, we now use a ```Data.Set``` to store all enabled flags. This is conceptually better, because we only care about which flags are enabled, and not their order or multiplicity. Thus, this commit also touches ```Input/Parsing.hs```. --- ampersand.cabal | 1 + preProcApp/Main.hs | 3 ++- src/Ampersand/Input/Parsing.hs | 12 +++++++----- src/Ampersand/Input/PreProcessor.hs | 27 +++++++++++++++++++-------- 4 files changed, 29 insertions(+), 14 deletions(-) diff --git a/ampersand.cabal b/ampersand.cabal index 07cc2aba68..90c8dbad82 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -192,6 +192,7 @@ executable ampPreProc ghc-options: -Wall -threaded default-extensions:NoImplicitPrelude build-depends: base == 4.11.*, + containers == 0.5.*, ampersand Test-Suite regression-test diff --git a/preProcApp/Main.hs b/preProcApp/Main.hs index f6523eaf25..af3945b1ed 100644 --- a/preProcApp/Main.hs +++ b/preProcApp/Main.hs @@ -4,6 +4,7 @@ import Ampersand import System.Environment import Ampersand.Input.PreProcessor import Ampersand.Basics.UTF8 (readUTF8File) +import qualified Data.Set as Set main :: IO () main = @@ -11,4 +12,4 @@ main = filename:defs <- getArgs; input <- readUTF8File filename inputString <- return $ either id id input - putStr $ either show id (preProcess' filename defs inputString) ++ "\n" + putStr $ either show id (preProcess' filename (Set.fromList defs) inputString) ++ "\n" diff --git a/src/Ampersand/Input/Parsing.hs b/src/Ampersand/Input/Parsing.hs index 686af6afad..3d37bf3a32 100644 --- a/src/Ampersand/Input/Parsing.hs +++ b/src/Ampersand/Input/Parsing.hs @@ -24,6 +24,7 @@ import Control.Exception import Data.Char(toLower) import Data.List import qualified Data.List.NonEmpty as NEL (NonEmpty(..)) +import qualified Data.Set as Set import Data.Maybe import System.Directory import System.FilePath @@ -36,13 +37,13 @@ parseADL :: Options -- ^ The options given through the comman -> IO (Guarded P_Context) -- ^ The resulting context parseADL opts fp = do curDir <- getCurrentDirectory canonical <- canonicalizePath fp - parseThing opts (ParseCandidate (Just curDir) Nothing fp Nothing canonical []) + parseThing opts (ParseCandidate (Just curDir) Nothing fp Nothing canonical Set.empty) parseMeta :: Options -> IO (Guarded P_Context) -parseMeta opts = parseThing opts (ParseCandidate Nothing (Just $ Origin "Formal Ampersand specification") "AST.adl" (Just FormalAmpersand) "AST.adl" []) +parseMeta opts = parseThing opts (ParseCandidate Nothing (Just $ Origin "Formal Ampersand specification") "AST.adl" (Just FormalAmpersand) "AST.adl" Set.empty) parseSystemContext :: Options -> IO (Guarded P_Context) -parseSystemContext opts = parseThing opts (ParseCandidate Nothing (Just $ Origin "Ampersand specific system context") "SystemContext.adl" (Just SystemContext) "SystemContext.adl" []) +parseSystemContext opts = parseThing opts (ParseCandidate Nothing (Just $ Origin "Ampersand specific system context") "SystemContext.adl" (Just SystemContext) "SystemContext.adl" Set.empty) parseThing :: Options -> ParseCandidate -> IO (Guarded P_Context) parseThing opts pc = @@ -70,7 +71,7 @@ data ParseCandidate = ParseCandidate , pcFilePath :: FilePath -- The absolute or relative filename as found in the INCLUDE statement , pcFileKind :: Maybe FileKind -- In case the file is included into ampersand.exe, its FileKind. , pcCanonical :: FilePath -- The canonicalized path of the candicate - , pcDefineds :: [PreProcDefine] + , pcDefineds :: Set.Set PreProcDefine } instance Eq ParseCandidate where a == b = pcFileKind a == pcFileKind b && pcCanonical a `equalFilePath` pcCanonical b @@ -119,12 +120,13 @@ parseSingleADL opts pc include2ParseCandidate :: Include -> IO ParseCandidate include2ParseCandidate (Include org str defs) = do let canonical = myNormalise ( takeDirectory filePath str ) + defineds = processFlags (pcDefineds pc) defs return ParseCandidate { pcBasePath = Just filePath , pcOrigin = Just org , pcFilePath = str , pcFileKind = pcFileKind pc , pcCanonical = canonical - , pcDefineds = pcDefineds pc ++ defs + , pcDefineds = defineds } myNormalise :: FilePath -> FilePath -- see http://neilmitchell.blogspot.nl/2015/10/filepaths-are-subtle-symlinks-are-hard.html why System.Filepath doesn't support reduction of x/foo/../bar into x/bar. diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index 5656b98c3a..26f586cad2 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -2,10 +2,12 @@ module Ampersand.Input.PreProcessor ( preProcess , preProcess' , PreProcDefine + , processFlags ) where import Data.List import qualified Data.List.NonEmpty as NEL +import qualified Data.Set as Set import Data.String import Data.Maybe import Data.Bool @@ -21,10 +23,19 @@ import Ampersand.Input.ADL1.CtxError type PreProcDefine = String +-- | Remove and add flags to the set of enabled flags based on an import statement. +processFlags :: Set.Set PreProcDefine -- ^ Old set of preprocessor flags + -> [String] -- ^ List of preprocessor flags from an import + -> Set.Set PreProcDefine -- ^ Set of preprocessor flags after import +processFlags oldFlags importList = Set.difference (Set.union oldFlags addedDefines) removedDefines + where (addedDefines, removedDefines) = + (\(added, removed) -> (Set.fromList added, Set.fromList $ map (fromMaybe "" . stripPrefix "!") removed)) + (partition (isPrefixOf "!") importList) + -- Shim that changes our 'Either ParseError a' from preProcess' into 'Guarded a' -- | Runs the preProcessor on input preProcess :: String -- ^ filename, used only for error reporting - -> [PreProcDefine] -- ^ list of flags, The list of defined 'flags + -> Set.Set PreProcDefine -- ^ list of flags, The list of defined 'flags -> String -- ^ input, The actual string to processs -> Guarded String -- ^ result, The result of processing preProcess f d i = case preProcess' f d i of @@ -33,7 +44,7 @@ preProcess f d i = case preProcess' f d i of -- | Runs the preProcessor on input preProcess' :: String -- ^ filename, used only for error reporting - -> [PreProcDefine] -- ^ list of flags, The list of defined 'flags + -> Set.Set PreProcDefine -- ^ list of flags, The list of defined 'flags -> String -- ^ input, The actual string to process -> Either ParseError String -- ^ result, The result of processing -- We append "\n" because the parser cannot handle a final line not terminated by a newline. @@ -231,14 +242,14 @@ elseClauseStart = parserToken matchIfEnd -} -- | Renders a Block type back into a String, according to some context -block2file :: [PreProcDefine] -- ^ flags, List of defined flags +block2file :: Set.Set PreProcDefine -- ^ defs, List of defined flags -> Bool -- ^ showing, whether we are showing the current block, or it is hidden -> Block -- ^ block, the block we want to process -> String -block2file defs shown = concat . map (blockElem2string defs shown) +block2file defs showing = concat . map (blockElem2string defs showing) -- | Renders a single block element back into text -blockElem2string :: [PreProcDefine] -- ^ flags, the list of active flags +blockElem2string :: Set.Set PreProcDefine -- ^ flags, the list of active flags -> Bool -- ^ showing, whether we are showing the current block element, or it is hidden -> BlockElem -- ^ blockElem, the block element to render -> String @@ -251,13 +262,13 @@ blockElem2string defs showing (GuardedElem guardedElem) = showGuardedBlock defs -- | Renders a GuardedBlock -- This is where the rendering logic of IF and IFNOT is implemented -- Simplification of this function is why IF and IFNOT are both represented by the type GuardedBlock -showGuardedBlock :: [PreProcDefine] -- ^ flags, the list of active flags +showGuardedBlock :: Set.Set PreProcDefine -- ^ flags, the list of active flags -> Bool -- ^ showing, whether we are showing the current block element, or it is hidden -> GuardedBlock -- ^ guardedBlock, the element to render -> String showGuardedBlock defs showing (GuardedBlock ifType (Guard guard') block elseBlock) = -- The xor (not ifType) is a succinct way to express the difference between IF blocks and NOTIF blocks - let showMainBody = (xor (not ifType) (guard' `elem` defs)) in + let showMainBody = (xor (not ifType) (guard' `Set.member` defs)) in concat [ guardedBlockName ifType ++ guard' ++ "\n" , (block2file defs (showing && showMainBody) block ) , (showElse defs (showing && (not showMainBody)) elseBlock) @@ -268,7 +279,7 @@ showGuardedBlock defs showing (GuardedBlock ifType (Guard guard') block elseBloc guardedBlockName :: Bool -> String guardedBlockName ifType = (if ifType then "--#IF " else "--#IFNOT ") -showElse :: [PreProcDefine] -> Bool -> Maybe Block -> String +showElse :: Set.Set PreProcDefine -> Bool -> Maybe Block -> String showElse defs showing = maybe "" (("--#ELSE\n" ++) . block2file defs showing) xor :: Bool -> Bool -> Bool From 9028655c5403c00f4c021421a7eaa8f184ae9469 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Wed, 2 Jan 2019 16:48:54 +0100 Subject: [PATCH 073/131] Release notes --- ReleaseNotes.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 60ad0a0f8b..5ba7f1f713 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,10 +1,11 @@ # Release notes of Ampersand ## Unreleased changes -* [Issue #616](https://github.com/AmpersandTarski/Ampersand/issues/616) Add missing TType 'Object' to parser +* [Issue #616](https://github.com/AmpersandTarski/Ampersand/issues/616) Add missing TType 'Object' to parser * [Issue #862](https://github.com/AmpersandTarski/Ampersand/issues/862) Bugfix in generated SQL in several cases where CLASSIFY statements were involved in combination with relations with the INJ property. * [Issue #865](https://github.com/AmpersandTarski/Ampersand/issues/865) Another bugfix in the generated SQL +* It is now possible to provide warnings in the output while generating a script. Warnings as suggested in [issue #141](https://github.com/AmpersandTarski/Ampersand/issues/141) are now generated when appropriate ## v3.12.0 (21 december 2018) From 49f8825358f920e368c64a8cc467d2fd0639d32f Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Thu, 3 Jan 2019 11:21:24 +0100 Subject: [PATCH 074/131] cleaning --- src/Ampersand/Basics/Exit.hs | 12 +++++------- src/Ampersand/Output/FSpec2SQL.hs | 2 +- src/Ampersand/Output/Population2Xlsx.hs | 3 +-- 3 files changed, 7 insertions(+), 10 deletions(-) diff --git a/src/Ampersand/Basics/Exit.hs b/src/Ampersand/Basics/Exit.hs index c3fff6c990..e704a0bcfa 100644 --- a/src/Ampersand/Basics/Exit.hs +++ b/src/Ampersand/Basics/Exit.hs @@ -13,16 +13,14 @@ import System.IO.Unsafe(unsafePerformIO) {-# NOINLINE exitWith #-} exitWith :: AmpersandExit -> a exitWith x = unsafePerformIO $ do - exitIO message + mapM_ putStrLn message SE.exitWith exitcode where (exitcode,message) = info x -exitIO :: [String] -> IO() -exitIO = mapM_ putStrLn - data AmpersandExit - = Succes - | Fatal [String] + = --Succes [String] + -- | + Fatal [String] | NoValidFSpec [String] | ViolationsInDatabase [(String,[String])] | InvalidSQLExpression [String] @@ -35,7 +33,7 @@ data AmpersandExit info :: AmpersandExit -> (SE.ExitCode, [String]) info x = case x of - Succes -> (SE.ExitSuccess , []) + -- Succes msg -> (SE.ExitSuccess , msg) Fatal msg -> (SE.ExitFailure 2 , msg) -- These specific errors are due to some bug in the Ampersand code. Please report such bugs! NoValidFSpec msg -> (SE.ExitFailure 10 , case msg of diff --git a/src/Ampersand/Output/FSpec2SQL.hs b/src/Ampersand/Output/FSpec2SQL.hs index ad18213674..a41598d9f8 100644 --- a/src/Ampersand/Output/FSpec2SQL.hs +++ b/src/Ampersand/Output/FSpec2SQL.hs @@ -54,7 +54,7 @@ dumpSQLqueries multi <>concatMap showInterface y where y :: [Interface] - y = (\x -> trace (show x) x) (interfaceS fSpec <> interfaceG fSpec) + y = interfaceS fSpec <> interfaceG fSpec fSpec = userFSpec multi showInterface :: Interface -> [Text.Text] showInterface ifc diff --git a/src/Ampersand/Output/Population2Xlsx.hs b/src/Ampersand/Output/Population2Xlsx.hs index 55c57e5702..04e85e5dff 100644 --- a/src/Ampersand/Output/Population2Xlsx.hs +++ b/src/Ampersand/Output/Population2Xlsx.hs @@ -39,8 +39,7 @@ plugs2Sheets fSpec = mapMaybe plug2sheet $ plugInfos fSpec TblSQL{} -> if length (attributes plug) > 1 then Just $ headers ++ content else Nothing - BinSQL{} -> -- trace ("## Warning: Handling of link-tables isn't correct yet. Therefor, sheet`"++name plug++"` doesn't contain proper info") $ - Just $ headers ++ content + BinSQL{} -> Just $ headers ++ content where headers :: [[Cell]] headers = transpose (zipWith (curry f) (True : repeat False) (plugAttributes plug)) From b0553e12f45233e9caadc7dc511bdeb3574fd555 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Thu, 3 Jan 2019 11:21:39 +0100 Subject: [PATCH 075/131] releasenotes --- ReleaseNotes.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 5ba7f1f713..568ffa9e43 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -5,7 +5,7 @@ * [Issue #616](https://github.com/AmpersandTarski/Ampersand/issues/616) Add missing TType 'Object' to parser * [Issue #862](https://github.com/AmpersandTarski/Ampersand/issues/862) Bugfix in generated SQL in several cases where CLASSIFY statements were involved in combination with relations with the INJ property. * [Issue #865](https://github.com/AmpersandTarski/Ampersand/issues/865) Another bugfix in the generated SQL -* It is now possible to provide warnings in the output while generating a script. Warnings as suggested in [issue #141](https://github.com/AmpersandTarski/Ampersand/issues/141) are now generated when appropriate +* [Issue #873](https://github.com/AmpersandTarski/Ampersand/issues/873) It is now possible to provide warnings in the output while generating a script. Several warnings are now generated as well when appropriate. ## v3.12.0 (21 december 2018) From 6167359f3f0cd13ccc77aa402ce5c0709ad352b7 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Thu, 3 Jan 2019 11:22:26 +0100 Subject: [PATCH 076/131] Replace output message when succes --- app/Main.hs | 5 +++++ src/Ampersand/Components.hs | 3 ++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index ab1d8b3795..2967353c60 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -23,5 +23,10 @@ main = Checked multi ws -> do showWarnings ws generateAmpersandOutput multi + putStrLn . ("Your script has no errors " ++) $ + case ws of + [] -> "and no warnings." + [_] -> ", but one warning was found." + _ -> ", but "++show (length ws)++" warnings were found." } diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index 8916c2c9cd..cc01b67f02 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -53,7 +53,8 @@ generateAmpersandOutput multi = do , ( proofs , doGenProofs ) , ( validateSQL , doValidateSQLTest ) , ( genPrototype, doGenProto ) - , ( const True , putStrLn "Finished processing your model.")] + -- , ( const True , putStrLn "Finished processing your model.") + ] opts = getOpts fSpec fSpec = userFSpec multi doGenADL :: IO() From 47b25707766cb0981904743d85776d329d755692 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Thu, 3 Jan 2019 11:23:07 +0100 Subject: [PATCH 077/131] Add lexerwarnings --- src/Ampersand/Input/ADL1/CtxError.hs | 20 ++++++++++++-------- src/Ampersand/Input/ADL1/Lexer.hs | 8 ++++++-- src/Ampersand/Input/Parsing.hs | 4 +++- 3 files changed, 21 insertions(+), 11 deletions(-) diff --git a/src/Ampersand/Input/ADL1/CtxError.hs b/src/Ampersand/Input/ADL1/CtxError.hs index 4f06f304d9..86594935d7 100644 --- a/src/Ampersand/Input/ADL1/CtxError.hs +++ b/src/Ampersand/Input/ADL1/CtxError.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wall -Werror #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FunctionalDependencies #-} @@ -25,7 +24,8 @@ module Ampersand.Input.ADL1.CtxError , mkTypeMismatchError , mkMultipleRootsError , mkCrudForRefInterfaceError - , addWarning + , lexerWarning2Warning + , addWarning, addWarnings , showWarning, showWarnings , Guarded(..) -- If you use Guarded in a monad, make sure you use "ApplicativeDo" in order to get error messages in parallel. , whenCheckedIO, whenChecked, whenError @@ -42,6 +42,7 @@ module Ampersand.Input.ADL1.CtxError where import Ampersand.ADL1 +import Ampersand.Input.ADL1.LexerMessage import Ampersand.Basics import Ampersand.Core.ShowAStruct import Ampersand.Core.ShowPStruct @@ -388,9 +389,13 @@ writeBind (ECpl e) writeBind e = "("++showA e++") /\\ "++showA (EDcV (sign e)) +lexerWarning2Warning :: LexerWarning -> Warning +lexerWarning2Warning (LexerWarning a b) = + Warning (FileLoc a "") (L.intercalate "\n" $ showLexerWarningInfo b) + data Warning = Warning Origin String instance Show Warning where - show (Warning o s) = "Warning: " ++ show o ++ " " ++ show s + show (Warning o msg) = "Warning: " ++ show o ++ concatMap ("\n "++) (lines msg) addWarning :: Warning -> Guarded a -> Guarded a addWarning _ (Errors a) = Errors a @@ -400,8 +405,8 @@ addWarnings ws ga = case ga of Checked a ws' -> Checked a (ws <> ws') Errors a -> Errors a -showWarning :: Warning -> String -showWarning = show +showWarning :: Warning -> [String] +showWarning = lines . show data Guarded a = Errors (NEL.NonEmpty CtxError) @@ -458,6 +463,5 @@ showMinorOrigin (FileLoc (FilePos _ line column) _) = "line " ++ show line ++" : showMinorOrigin v = show v showWarnings :: [Warning] -> IO () -showWarnings = mapM_ putStrLn - . L.intercalate [""] - . map (lines . showWarning) +showWarnings = mapM_ putStrLn . concatMap showWarning + diff --git a/src/Ampersand/Input/ADL1/Lexer.hs b/src/Ampersand/Input/ADL1/Lexer.hs index f8d73e8c38..2829d62a41 100644 --- a/src/Ampersand/Input/ADL1/Lexer.hs +++ b/src/Ampersand/Input/ADL1/Lexer.hs @@ -28,6 +28,7 @@ import Ampersand.Input.ADL1.LexerMessage import Ampersand.Input.ADL1.LexerMonad import Ampersand.Input.ADL1.LexerToken import Ampersand.Misc +import Control.Monad (when) import Data.Char hiding(isSymbol) import Data.List (nub) import qualified Data.Set as Set -- (member, fromList) @@ -127,8 +128,11 @@ mainLexer _ [] = return [] mainLexer p ('-':'-':s) = mainLexer p (skipLine s) --TODO: Test if we should increase line number and reset the column number -mainLexer p (c:s) | isSpace c = let (spc,next) = span isSpace s - in mainLexer (foldl updatePos p (c:spc)) next +mainLexer p (c:s) | isSpace c = let (spc,next) = span isSpaceNoTab s + isSpaceNoTab x = isSpace x && (not . isTab) x + isTab = ('\t' ==) + in do when (isTab c) (lexerWarning TabCharacter p) + mainLexer (foldl updatePos p (c:spc)) next mainLexer p ('{':'-':s) = lexNestComment mainLexer (addPos 2 p) s mainLexer p ('{':'+':s) = lexMarkup mainLexer (addPos 2 p) s diff --git a/src/Ampersand/Input/Parsing.hs b/src/Ampersand/Input/Parsing.hs index 67c92aafca..e6f45d4076 100644 --- a/src/Ampersand/Input/Parsing.hs +++ b/src/Ampersand/Input/Parsing.hs @@ -197,7 +197,9 @@ runParser parser filename input = in case lexed of Left err -> Errors . pure $ lexerError2CtxError err --TODO: Do something with the warnings. The warnings cannot be shown with the current Guarded data type - Right (tokens, lexerWarnings) -> whenChecked (parse parser filename tokens) pure + Right (tokens, lexerWarnings) + -> addWarnings (map lexerWarning2Warning lexerWarnings) $ whenChecked (parse parser filename tokens) pure + -- | Parses an isolated rule -- In order to read derivation rules, we use the Ampersand parser. From 826f1935c41e581b19cf311c90a751bb58f26864 Mon Sep 17 00:00:00 2001 From: bart Date: Thu, 3 Jan 2019 15:05:21 +0100 Subject: [PATCH 078/131] Fix preProcessor set and unset flags were reversed Setting flags was treated as unsetting flags, and vice-versa. That is: ```INCLUDE "foo.adl" --# ["FLAG"]``` was treated like ```INCLUDE "foo.adl" --# ["!FLAG"]```. Notably this meant that almost all scripts were pre-processed as if no flags were set. The old test did not catch this. This commit modifies the test to fail if the pre-processor does not read any flags. --- src/Ampersand/Input/PreProcessor.hs | 2 +- testing/Travis/testcases/Preprocessor/Preprocessor.adl | 4 ++-- .../Travis/testcases/Preprocessor/includes/PreprocTest.adl | 4 +++- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Ampersand/Input/PreProcessor.hs b/src/Ampersand/Input/PreProcessor.hs index 26f586cad2..1cb3418ac3 100644 --- a/src/Ampersand/Input/PreProcessor.hs +++ b/src/Ampersand/Input/PreProcessor.hs @@ -29,7 +29,7 @@ processFlags :: Set.Set PreProcDefine -- ^ Old set of preprocessor flags -> Set.Set PreProcDefine -- ^ Set of preprocessor flags after import processFlags oldFlags importList = Set.difference (Set.union oldFlags addedDefines) removedDefines where (addedDefines, removedDefines) = - (\(added, removed) -> (Set.fromList added, Set.fromList $ map (fromMaybe "" . stripPrefix "!") removed)) + (\(removed, added) -> (Set.fromList added, Set.fromList $ map (fromMaybe "" . stripPrefix "!") removed)) (partition (isPrefixOf "!") importList) -- Shim that changes our 'Either ParseError a' from preProcess' into 'Guarded a' diff --git a/testing/Travis/testcases/Preprocessor/Preprocessor.adl b/testing/Travis/testcases/Preprocessor/Preprocessor.adl index e84df64e0c..7a6d899bab 100644 --- a/testing/Travis/testcases/Preprocessor/Preprocessor.adl +++ b/testing/Travis/testcases/Preprocessor/Preprocessor.adl @@ -59,6 +59,6 @@ Files in this project contain examples of the syntax that explain the use. -- This line should be treated as comment, and not as a --#preprocessor statement. -INCLUDE "./includes/PreprocTest.adl" --# [ "ShowR2", "DoNotShowR1", "EditableInterfaceA", "GenerateErrorIfThisVarIsSet" ] --dit is een test +INCLUDE "./includes/PreprocTest.adl" --# [ "ShowR2", "DoNotShowR1", "EditableInterfaceA", "GenerateErrorIfThisVarIsSet", "ErrorIfUnset" ] --dit is een test -ENDCONTEXT \ No newline at end of file +ENDCONTEXT diff --git a/testing/Travis/testcases/Preprocessor/includes/PreprocTest.adl b/testing/Travis/testcases/Preprocessor/includes/PreprocTest.adl index 91111856d2..971559fe46 100644 --- a/testing/Travis/testcases/Preprocessor/includes/PreprocTest.adl +++ b/testing/Travis/testcases/Preprocessor/includes/PreprocTest.adl @@ -29,4 +29,6 @@ INTERFACE "Test": I[SESSION] cRud BOX ] ] -ENDCONTEXT \ No newline at end of file +--#IF ErrorIfUnset +ENDCONTEXT +--#ENDIF From b7bc4e2916308067eccdc13bd17e84a7be84b2b4 Mon Sep 17 00:00:00 2001 From: Rieks Date: Fri, 4 Jan 2019 15:55:27 +0100 Subject: [PATCH 079/131] Bugfix wrong output of srcOrTgt for non-uni endo relations --- src/Ampersand/Output/ToJSON/Relations.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index 41cf0b3de7..86d3f45f94 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -73,7 +73,7 @@ instance JSON Relation RelTableInfo where (plugSrc,_) = getConceptTableInfo fSpec (source dcl) (plugTrg,_) = getConceptTableInfo fSpec (target dcl) srcOrtgt - | plugSrc == plugTrg = Just $ if rsStoredFlipped relstore then "tgt" else "src" + | (plug == plugSrc) && (plugSrc == plugTrg) = Just $ if rsStoredFlipped relstore then "tgt" else "src" | plug == plugSrc = Just "src" | plug == plugTrg = Just "tgt" | otherwise = Nothing From fd279f56eeff6476b26f5560415ef6fce67d4445 Mon Sep 17 00:00:00 2001 From: Rieks Date: Fri, 4 Jan 2019 15:56:22 +0100 Subject: [PATCH 080/131] Add comments to explain resolution --- src/Ampersand/Output/ToJSON/Relations.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Ampersand/Output/ToJSON/Relations.hs b/src/Ampersand/Output/ToJSON/Relations.hs index 86d3f45f94..19b89a80bb 100644 --- a/src/Ampersand/Output/ToJSON/Relations.hs +++ b/src/Ampersand/Output/ToJSON/Relations.hs @@ -73,10 +73,10 @@ instance JSON Relation RelTableInfo where (plugSrc,_) = getConceptTableInfo fSpec (source dcl) (plugTrg,_) = getConceptTableInfo fSpec (target dcl) srcOrtgt - | (plug == plugSrc) && (plugSrc == plugTrg) = Just $ if rsStoredFlipped relstore then "tgt" else "src" - | plug == plugSrc = Just "src" - | plug == plugTrg = Just "tgt" - | otherwise = Nothing + | (plug == plugSrc) && (plugSrc == plugTrg) = Just $ if rsStoredFlipped relstore then "tgt" else "src" -- relations where src and tgt concepts are in the same classification tree as well as relations that are UNI or INJ + | plug == plugSrc = Just "src" -- relation in same table as src concept (UNI relations) + | plug == plugTrg = Just "tgt" -- relation in same table as tgt concept (INJ relations that are not UNI) + | otherwise = Nothing -- relations in n-n table (not UNI and not INJ) instance JSON SqlAttribute TableCol where fromAmpersand _ att = TableCol { tcJSONname = attName att From cb16db348d45c8c51221fd8745db9bc263a00f38 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Fri, 4 Jan 2019 21:08:14 +0100 Subject: [PATCH 081/131] Remove --dev switch, which was an alias of --ignore-invariant-violations. The latter is self-explanatory. #728 --- src/Ampersand/Misc/Options.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/Misc/Options.hs b/src/Ampersand/Misc/Options.hs index 8304777317..3693a554fa 100644 --- a/src/Ampersand/Misc/Options.hs +++ b/src/Ampersand/Misc/Options.hs @@ -370,7 +370,7 @@ options = [ (Option ['v'] ["version"] ) "config.yaml") "config file (*.yaml) that contains the command line options of ampersand." , Public) - , (Option [] ["dev","ignore-invariant-violations"] + , (Option [] ["ignore-invariant-violations"] (NoArg (\opts -> opts{allowInvariantViolations = True})) "Allow to build a prototype, even if there are invariants that are being violated. (See https://github.com/AmpersandTarski/Ampersand/issues/728)" , Hidden) From 5036ad0ed38fd267765003ce96888522b62941a0 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Fri, 4 Jan 2019 21:28:43 +0100 Subject: [PATCH 082/131] Don't output invariant violations to stdout when --ignore-invariant-switch is set. Except with --verbose --- src/Ampersand/Components.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index 8916c2c9cd..de0b75f13b 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -180,8 +180,13 @@ generateAmpersandOutput multi = do reportViolations :: [(Rule,AAtomPairs)] -> IO() reportViolations [] = verboseLn opts "No violations found." reportViolations viols = - let ruleNamesAndViolStrings = [ (name r, showprs p) | (r,p) <- viols ] - in putStrLn $ + if (allowInvariantViolations opts) && not (verboseP opts) + then + -- TODO: this is a nice use case for outputting warnings + putStrLn "There are invariant violations that are ignored. Use --verbose to output the violations" + else + let ruleNamesAndViolStrings = [ (name r, showprs p) | (r,p) <- viols ] + in putStrLn $ intercalate "\n" [ "Violations of rule "++show r++":\n"++ concatMap (\(_,p) -> "- "++ p ++"\n") rps | rps@((r,_):_) <- groupBy (on (==) fst) $ sort ruleNamesAndViolStrings From 0c759f292966fdb07a50d03744bad39abadf6358 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Fri, 4 Jan 2019 21:30:59 +0100 Subject: [PATCH 083/131] Rename function --- src/Ampersand/Components.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index de0b75f13b..fb14c0ff22 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -146,7 +146,7 @@ generateAmpersandOutput multi = do doGenProto = sequence_ $ [ verboseLn opts "Checking for rule violations..." - , reportViolations violationsOfInvariants + , reportInvViolations violationsOfInvariants , reportSignals (initialConjunctSignals fSpec) ]++ (if null violationsOfInvariants || allowInvariantViolations opts @@ -177,9 +177,9 @@ generateAmpersandOutput multi = do , "TOT objExpression[BoxItem*Expression]" ] else False - reportViolations :: [(Rule,AAtomPairs)] -> IO() - reportViolations [] = verboseLn opts "No violations found." - reportViolations viols = + reportInvViolations :: [(Rule,AAtomPairs)] -> IO() + reportInvViolations [] = verboseLn opts "No invariant violations found for the initial population." + reportInvViolations viols = if (allowInvariantViolations opts) && not (verboseP opts) then -- TODO: this is a nice use case for outputting warnings From 44687f520a0c0dfe5990c53de4e798fcd507fa6d Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Fri, 4 Jan 2019 21:44:13 +0100 Subject: [PATCH 084/131] Indicate that there are signal rule violations when --verbose is not set (same as with ignored invariant violations) --- src/Ampersand/Components.hs | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index fb14c0ff22..ed86cdd936 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -178,7 +178,7 @@ generateAmpersandOutput multi = do ] else False reportInvViolations :: [(Rule,AAtomPairs)] -> IO() - reportInvViolations [] = verboseLn opts "No invariant violations found for the initial population." + reportInvViolations [] = verboseLn opts "No invariant violations found for the initial population" reportInvViolations viols = if (allowInvariantViolations opts) && not (verboseP opts) then @@ -196,13 +196,18 @@ generateAmpersandOutput multi = do showprs aprs = "["++intercalate ", " (Set.elems $ Set.map showA aprs)++"]" -- showpr :: AAtomPair -> String -- showpr apr = "( "++(showVal.apLeft) apr++", "++(showVal.apRight) apr++" )" - reportSignals [] = verboseLn opts "No signals for the initial population." - reportSignals conjViols = verboseLn opts $ "Signals for initial population:\n" ++ intercalate "\n" - [ "Rule(s): "++(show . map name . Set.elems . rc_orgRules) conj - ++"\n Conjunct : " ++ showA (rc_conjunct conj) - ++"\n Violations : " ++ showprs viols - | (conj, viols) <- conjViols - ] + reportSignals [] = verboseLn opts "No signals for the initial population" + reportSignals conjViols = + if verboseP opts + then + verboseLn opts $ "Signals for initial population:\n" ++ intercalate "\n" + [ "Rule(s): "++(show . map name . Set.elems . rc_orgRules) conj + ++"\n Conjunct : " ++ showA (rc_conjunct conj) + ++"\n Violations : " ++ showprs viols + | (conj, viols) <- conjViols + ] + else + putStrLn "There are signals for the initial population. Use --verbose to output the violations" ruleTest :: String -> IO () ruleTest ruleName = case [ rule | rule <- Set.elems $ grules fSpec `Set.union` vrules fSpec, name rule == ruleName ] of From 2e01aa45f8a02060dc9cfabad61dc18ad1e9d046 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Fri, 4 Jan 2019 22:08:27 +0100 Subject: [PATCH 085/131] Update release notes --- ReleaseNotes.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 60ad0a0f8b..d85c2a2d13 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -2,9 +2,10 @@ ## Unreleased changes * [Issue #616](https://github.com/AmpersandTarski/Ampersand/issues/616) Add missing TType 'Object' to parser - * [Issue #862](https://github.com/AmpersandTarski/Ampersand/issues/862) Bugfix in generated SQL in several cases where CLASSIFY statements were involved in combination with relations with the INJ property. * [Issue #865](https://github.com/AmpersandTarski/Ampersand/issues/865) Another bugfix in the generated SQL +* Removed --dev switch as alias of self-explanatory --ignore-invariant-violations +* Improved output of any invariant violations or signals for initial population ## v3.12.0 (21 december 2018) From 024a5f7e6697cc17a19f844f52ce985d55a60c8e Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sat, 5 Jan 2019 14:50:17 +0100 Subject: [PATCH 086/131] Due to (early) merge of PR #869 set zwolle version to developmen branch of prototype framework --- ReleaseNotes.md | 3 ++- src/Ampersand/Misc/Options.hs | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 777c36178f..4d442dd5bf 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,8 +1,9 @@ # Release notes of Ampersand ## Unreleased changes +**!!Before release, do a release of the prototype framework and set option zwolleVersion to this release tag** +* Update prototype framework. See [releases](https://github.com/AmpersandTarski/Prototype/releases) for more information * [Issue #616](https://github.com/AmpersandTarski/Ampersand/issues/616) Add missing TType 'Object' to parser -* Update to prototype framework v1.1.0 (was v1.0.1). See [releases](https://github.com/AmpersandTarski/Prototype/releases) for more information * Add 'public' folder in prototype directory to better distinguish between public and non-public scripts. If used, requires change in 'customizations' folder * [Issue #792](https://github.com/AmpersandTarski/Ampersand/issues/792) Add possibility to extend TXT in interfaces * [Issue #862](https://github.com/AmpersandTarski/Ampersand/issues/862) Bugfix in generated SQL in several cases where CLASSIFY statements were involved in combination with relations with the INJ property. diff --git a/src/Ampersand/Misc/Options.hs b/src/Ampersand/Misc/Options.hs index 0bf7e433f2..88c230fa46 100644 --- a/src/Ampersand/Misc/Options.hs +++ b/src/Ampersand/Misc/Options.hs @@ -207,7 +207,7 @@ getOptions' envOpts = , dirOutput = fromMaybe "." $ envDirOutput envOpts , outputfile = fatal "No monadic options available." , dirPrototype = fromMaybe "." (envDirPrototype envOpts) takeBaseName fName <.> ".proto" - , zwolleVersion = "v1.1.0" + , zwolleVersion = "development" , forceReinstallFramework = False , dirCustomizations = ["customizations"] , dbName = fmap toLower . fromMaybe ("ampersand_"++takeBaseName fName) $ envDbName envOpts From 0603694ceef66e20196d07a1fa2c1def2a71f1d5 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sat, 5 Jan 2019 15:31:59 +0100 Subject: [PATCH 087/131] Report invariant violations and signals also when no prototype is generated --- src/Ampersand/Components.hs | 137 ++++++++++++++++++------------------ 1 file changed, 67 insertions(+), 70 deletions(-) diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index ed86cdd936..cb9d9022c5 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -32,11 +32,14 @@ import Text.Pandoc.Builder -- | The FSpec is the datastructure that contains everything to generate the output. This monadic function -- takes the FSpec as its input, and spits out everything the user requested. generateAmpersandOutput :: MultiFSpecs -> IO () -generateAmpersandOutput multi = do - createDirectoryIfMissing True (dirOutput opts) - when (genPrototype opts) - (createDirectoryIfMissing True (dirPrototype opts)) - mapM_ doWhen conditionalActions +generateAmpersandOutput multi = + do { verboseLn opts "Checking for rule violations..." + ; reportInvViolations violationsOfInvariants + ; reportSignals (initialConjunctSignals fSpec) + ; createDirectoryIfMissing True (dirOutput opts) + ; when (genPrototype opts) (createDirectoryIfMissing True (dirPrototype opts)) + ; mapM_ doWhen conditionalActions + } where doWhen :: (Options -> Bool, IO ()) -> IO() doWhen (b,x) = when (b opts) x @@ -144,11 +147,7 @@ generateAmpersandOutput multi = do doGenProto :: IO () doGenProto = - sequence_ $ - [ verboseLn opts "Checking for rule violations..." - , reportInvViolations violationsOfInvariants - , reportSignals (initialConjunctSignals fSpec) - ]++ + sequence_ $ (if null violationsOfInvariants || allowInvariantViolations opts then if genRapPopulationOnly (getOpts fSpec) then [ generateJSONfiles multi] @@ -163,65 +162,63 @@ generateAmpersandOutput multi = do )++ maybeToList (fmap ruleTest (testRule opts)) - where violationsOfInvariants :: [(Rule,AAtomPairs)] - violationsOfInvariants - = [(r,vs) |(r,vs) <- allViolations fSpec - , not (isSignal r) - , not (elemOfTemporarilyBlocked r) - ] - where - elemOfTemporarilyBlocked rul = - if atlasWithoutExpressions opts - then name rul `elem` - [ "TOT formalExpression[Rule*Expression]" - , "TOT objExpression[BoxItem*Expression]" - ] - else False - reportInvViolations :: [(Rule,AAtomPairs)] -> IO() - reportInvViolations [] = verboseLn opts "No invariant violations found for the initial population" - reportInvViolations viols = - if (allowInvariantViolations opts) && not (verboseP opts) - then - -- TODO: this is a nice use case for outputting warnings - putStrLn "There are invariant violations that are ignored. Use --verbose to output the violations" - else - let ruleNamesAndViolStrings = [ (name r, showprs p) | (r,p) <- viols ] - in putStrLn $ - intercalate "\n" - [ "Violations of rule "++show r++":\n"++ concatMap (\(_,p) -> "- "++ p ++"\n") rps - | rps@((r,_):_) <- groupBy (on (==) fst) $ sort ruleNamesAndViolStrings - ] - - showprs :: AAtomPairs -> String - showprs aprs = "["++intercalate ", " (Set.elems $ Set.map showA aprs)++"]" - -- showpr :: AAtomPair -> String - -- showpr apr = "( "++(showVal.apLeft) apr++", "++(showVal.apRight) apr++" )" - reportSignals [] = verboseLn opts "No signals for the initial population" - reportSignals conjViols = - if verboseP opts - then - verboseLn opts $ "Signals for initial population:\n" ++ intercalate "\n" - [ "Rule(s): "++(show . map name . Set.elems . rc_orgRules) conj - ++"\n Conjunct : " ++ showA (rc_conjunct conj) - ++"\n Violations : " ++ showprs viols - | (conj, viols) <- conjViols - ] - else - putStrLn "There are signals for the initial population. Use --verbose to output the violations" - ruleTest :: String -> IO () - ruleTest ruleName = - case [ rule | rule <- Set.elems $ grules fSpec `Set.union` vrules fSpec, name rule == ruleName ] of - [] -> putStrLn $ "\nRule test error: rule "++show ruleName++" not found." - (rule:_) -> do { putStrLn $ "\nContents of rule "++show ruleName++ ": "++showA (formalExpression rule) - ; putStrLn $ showContents rule - ; let rExpr = formalExpression rule - ; let ruleComplement = rule { formalExpression = notCpl (EBrk rExpr) } - ; putStrLn $ "\nViolations of "++show ruleName++" (contents of "++showA (formalExpression ruleComplement)++"):" - ; putStrLn $ showContents ruleComplement - } - where showContents rule = "[" ++ intercalate ", " pairs ++ "]" - where pairs = [ "("++(show.showValADL.apLeft) v++"," ++(show.showValADL.apRight) v++")" - | (r,vs) <- allViolations fSpec, r == rule, v <- Set.elems vs] - + violationsOfInvariants :: [(Rule,AAtomPairs)] + violationsOfInvariants + = [(r,vs) |(r,vs) <- allViolations fSpec + , not (isSignal r) + , not (elemOfTemporarilyBlocked r) + ] + where + elemOfTemporarilyBlocked rul = + if atlasWithoutExpressions opts + then name rul `elem` + [ "TOT formalExpression[Rule*Expression]" + , "TOT objExpression[BoxItem*Expression]" + ] + else False + reportInvViolations :: [(Rule,AAtomPairs)] -> IO() + reportInvViolations [] = verboseLn opts "No invariant violations found for the initial population" + reportInvViolations viols = + if (allowInvariantViolations opts) && not (verboseP opts) + then + -- TODO: this is a nice use case for outputting warnings + putStrLn "There are invariant violations that are ignored. Use --verbose to output the violations" + else + let ruleNamesAndViolStrings = [ (name r, showprs p) | (r,p) <- viols ] + in putStrLn $ + intercalate "\n" + [ "Violations of rule "++show r++":\n"++ concatMap (\(_,p) -> "- "++ p ++"\n") rps + | rps@((r,_):_) <- groupBy (on (==) fst) $ sort ruleNamesAndViolStrings + ] + showprs :: AAtomPairs -> String + showprs aprs = "["++intercalate ", " (Set.elems $ Set.map showA aprs)++"]" + -- showpr :: AAtomPair -> String + -- showpr apr = "( "++(showVal.apLeft) apr++", "++(showVal.apRight) apr++" )" + reportSignals [] = verboseLn opts "No signals for the initial population" + reportSignals conjViols = + if verboseP opts + then + verboseLn opts $ "Signals for initial population:\n" ++ intercalate "\n" + [ "Rule(s): "++(show . map name . Set.elems . rc_orgRules) conj + ++"\n Conjunct : " ++ showA (rc_conjunct conj) + ++"\n Violations : " ++ showprs viols + | (conj, viols) <- conjViols + ] + else + putStrLn "There are signals for the initial population. Use --verbose to output the violations" + ruleTest :: String -> IO () + ruleTest ruleName = + case [ rule | rule <- Set.elems $ grules fSpec `Set.union` vrules fSpec, name rule == ruleName ] of + [] -> putStrLn $ "\nRule test error: rule "++show ruleName++" not found." + (rule:_) -> do { putStrLn $ "\nContents of rule "++show ruleName++ ": "++showA (formalExpression rule) + ; putStrLn $ showContents rule + ; let rExpr = formalExpression rule + ; let ruleComplement = rule { formalExpression = notCpl (EBrk rExpr) } + ; putStrLn $ "\nViolations of "++show ruleName++" (contents of "++showA (formalExpression ruleComplement)++"):" + ; putStrLn $ showContents ruleComplement + } + where showContents rule = "[" ++ intercalate ", " pairs ++ "]" + where pairs = [ "("++(show.showValADL.apLeft) v++"," ++(show.showValADL.apRight) v++")" + | (r,vs) <- allViolations fSpec, r == rule, v <- Set.elems vs] \ No newline at end of file From 1f99938a3f4d7d441edd4ac61547610e4eb6232f Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sat, 5 Jan 2019 15:52:54 +0100 Subject: [PATCH 088/131] Allow --testRule also when no prototype is generated --- src/Ampersand/Components.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index cb9d9022c5..25eb4ef622 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -23,7 +23,7 @@ import Data.Function (on) import Data.List import qualified Data.Set as Set import qualified Data.Text.IO as Text (writeFile)-- This should become the standard way to write all files as Text, not String. -import Data.Maybe (maybeToList) +import Data.Maybe (isJust, fromJust) import System.Directory import System.FilePath import Text.Pandoc @@ -56,6 +56,7 @@ generateAmpersandOutput multi = , ( proofs , doGenProofs ) , ( validateSQL , doValidateSQLTest ) , ( genPrototype, doGenProto ) + , ( isJust . testRule , ruleTest . fromJust . testRule $ opts ) , ( const True , putStrLn "Finished processing your model.")] opts = getOpts fSpec fSpec = userFSpec multi @@ -159,8 +160,7 @@ generateAmpersandOutput multi = , verboseLn opts $ "Prototype files have been written to " ++ dirPrototype opts ] else [exitWith NoPrototypeBecauseOfRuleViolations] - )++ - maybeToList (fmap ruleTest (testRule opts)) + ) violationsOfInvariants :: [(Rule,AAtomPairs)] violationsOfInvariants From 997b6b3e56c273ca214d186f6f9aa8677fd50f9f Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sat, 5 Jan 2019 19:27:05 +0100 Subject: [PATCH 089/131] Allow to generate rap population file (switch --gen-as-rap-model) when no prototype is generated --- src/Ampersand/Components.hs | 33 ++++++++++++++++++++------------- 1 file changed, 20 insertions(+), 13 deletions(-) diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index 25eb4ef622..ea55865a1c 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -56,6 +56,7 @@ generateAmpersandOutput multi = , ( proofs , doGenProofs ) , ( validateSQL , doValidateSQLTest ) , ( genPrototype, doGenProto ) + , ( genRapPopulationOnly, doGenRapPopulation) , ( isJust . testRule , ruleTest . fromJust . testRule $ opts ) , ( const True , putStrLn "Finished processing your model.")] opts = getOpts fSpec @@ -148,19 +149,25 @@ generateAmpersandOutput multi = doGenProto :: IO () doGenProto = - sequence_ $ - (if null violationsOfInvariants || allowInvariantViolations opts - then if genRapPopulationOnly (getOpts fSpec) - then [ generateJSONfiles multi] - else [ verboseLn opts "Generating prototype..." - , doGenFrontend fSpec - , generateDatabaseFile multi - , generateJSONfiles multi - , verboseLn opts "\n" - , verboseLn opts $ "Prototype files have been written to " ++ dirPrototype opts - ] - else [exitWith NoPrototypeBecauseOfRuleViolations] - ) + if null violationsOfInvariants || allowInvariantViolations opts + then sequence_ $ + [ verboseLn opts "Generating prototype..." + , doGenFrontend fSpec + , generateDatabaseFile multi + , generateJSONfiles multi + , verboseLn opts $ "Prototype files have been written to " ++ dirPrototype opts + ] + else do exitWith NoPrototypeBecauseOfRuleViolations + + doGenRapPopulation :: IO () + doGenRapPopulation = + if null violationsOfInvariants || allowInvariantViolations opts + then sequence_ $ + [ verboseLn opts "Generating RAP population..." + , generateJSONfiles multi + , verboseLn opts $ "RAP population file has been written to " ++ dirPrototype opts + ] + else do exitWith NoPrototypeBecauseOfRuleViolations violationsOfInvariants :: [(Rule,AAtomPairs)] violationsOfInvariants From ae820682d03694e746f2d412c2e321cd8656d562 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sat, 5 Jan 2019 19:29:09 +0100 Subject: [PATCH 090/131] Move finish message away from conditionalActions. Condition was True --- src/Ampersand/Components.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index ea55865a1c..abc4804da7 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -39,6 +39,7 @@ generateAmpersandOutput multi = ; createDirectoryIfMissing True (dirOutput opts) ; when (genPrototype opts) (createDirectoryIfMissing True (dirPrototype opts)) ; mapM_ doWhen conditionalActions + ; putStrLn "Finished processing your model" } where doWhen :: (Options -> Bool, IO ()) -> IO() @@ -58,7 +59,7 @@ generateAmpersandOutput multi = , ( genPrototype, doGenProto ) , ( genRapPopulationOnly, doGenRapPopulation) , ( isJust . testRule , ruleTest . fromJust . testRule $ opts ) - , ( const True , putStrLn "Finished processing your model.")] + ] opts = getOpts fSpec fSpec = userFSpec multi doGenADL :: IO() From d83e45e14d79b5805bbbae1d20031e7f913c3ef8 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sat, 5 Jan 2019 19:40:26 +0100 Subject: [PATCH 091/131] Move create proto dir to functions that require this --- src/Ampersand/Components.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index abc4804da7..e0f16bfe8c 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -37,7 +37,6 @@ generateAmpersandOutput multi = ; reportInvViolations violationsOfInvariants ; reportSignals (initialConjunctSignals fSpec) ; createDirectoryIfMissing True (dirOutput opts) - ; when (genPrototype opts) (createDirectoryIfMissing True (dirPrototype opts)) ; mapM_ doWhen conditionalActions ; putStrLn "Finished processing your model" } @@ -153,6 +152,7 @@ generateAmpersandOutput multi = if null violationsOfInvariants || allowInvariantViolations opts then sequence_ $ [ verboseLn opts "Generating prototype..." + , createDirectoryIfMissing True (dirPrototype opts) , doGenFrontend fSpec , generateDatabaseFile multi , generateJSONfiles multi @@ -165,6 +165,7 @@ generateAmpersandOutput multi = if null violationsOfInvariants || allowInvariantViolations opts then sequence_ $ [ verboseLn opts "Generating RAP population..." + , createDirectoryIfMissing True (dirPrototype opts) , generateJSONfiles multi , verboseLn opts $ "RAP population file has been written to " ++ dirPrototype opts ] From 6fd542e62608ad46fb095a70c3466b0fbf0c0b11 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sat, 5 Jan 2019 19:43:56 +0100 Subject: [PATCH 092/131] Fix layout --- src/Ampersand/Components.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index e0f16bfe8c..928b669067 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -45,19 +45,19 @@ generateAmpersandOutput multi = doWhen (b,x) = when (b opts) x conditionalActions :: [(Options -> Bool, IO())] conditionalActions = - [ ( genSampleConfigFile , doGenSampleConfigFile) - , ( genUML , doGenUML ) - , ( haskell , doGenHaskell ) - , ( sqlDump , doGenSQLdump ) - , ( export2adl , doGenADL ) - , ( genFSpec , doGenDocument ) - , ( genFPAExcel , doGenFPAExcel ) - , ( genPOPExcel , doGenPopsXLSX ) - , ( proofs , doGenProofs ) - , ( validateSQL , doValidateSQLTest ) - , ( genPrototype, doGenProto ) - , ( genRapPopulationOnly, doGenRapPopulation) - , ( isJust . testRule , ruleTest . fromJust . testRule $ opts ) + [ ( genSampleConfigFile , doGenSampleConfigFile ) + , ( genUML , doGenUML ) + , ( haskell , doGenHaskell ) + , ( sqlDump , doGenSQLdump ) + , ( export2adl , doGenADL ) + , ( genFSpec , doGenDocument ) + , ( genFPAExcel , doGenFPAExcel ) + , ( genPOPExcel , doGenPopsXLSX ) + , ( proofs , doGenProofs ) + , ( validateSQL , doValidateSQLTest ) + , ( genPrototype , doGenProto ) + , ( genRapPopulationOnly , doGenRapPopulation ) + , ( isJust . testRule , ruleTest . fromJust . testRule $ opts ) ] opts = getOpts fSpec fSpec = userFSpec multi From 26793ea61461d0b4836c67a9785e05c47a4540b1 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sat, 5 Jan 2019 20:18:19 +0100 Subject: [PATCH 093/131] Always output to the console what actions are being done. Furthermore unify this message for all actions --- app/Main.hs | 2 ++ src/Ampersand/Components.hs | 24 ++++++++++++------------ src/Ampersand/Prototype/GenFrontend.hs | 6 +++--- 3 files changed, 17 insertions(+), 15 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 9d72024532..f08c1afd25 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -15,6 +15,7 @@ main = -- be thought of. then mapM_ putStr (helpNVersionTexts ampersandVersionStr opts) else do { verboseLn opts $ ampersandVersionStr + ; putStrLn "Processing your model..." ; gMulti <- createMulti opts ; case gMulti of Errors err -> @@ -22,5 +23,6 @@ main = . fmap showErr . NEL.toList $ err Checked multi -> generateAmpersandOutput multi + ; putStrLn "Finished processing your model" } diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index 928b669067..b3d32b3e1a 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -38,7 +38,6 @@ generateAmpersandOutput multi = ; reportSignals (initialConjunctSignals fSpec) ; createDirectoryIfMissing True (dirOutput opts) ; mapM_ doWhen conditionalActions - ; putStrLn "Finished processing your model" } where doWhen :: (Options -> Bool, IO ()) -> IO() @@ -63,7 +62,8 @@ generateAmpersandOutput multi = fSpec = userFSpec multi doGenADL :: IO() doGenADL = - do { writeFile outputFile . showA . originalContext $ fSpec + do { putStrLn $ "Generating Ampersand script (ADL) for " ++ name fSpec ++ "..." + ; writeFile outputFile . showA . originalContext $ fSpec ; verboseLn opts $ ".adl-file written to " ++ outputFile ++ "." } where outputFile = dirOutput opts outputfile opts @@ -71,7 +71,7 @@ generateAmpersandOutput multi = doGenSampleConfigFile = writeConfigFile doGenProofs :: IO() doGenProofs = - do { verboseLn opts $ "Generating Proof for " ++ name fSpec ++ " into " ++ outputFile ++ "." + do { putStrLn $ "Generating Proof for " ++ name fSpec ++ " into " ++ outputFile ++ "..." -- ; verboseLn opts $ writeTextile def thePandoc ; content <- runIO (writeHtml5String def thePandoc) >>= handleError ; Text.writeFile outputFile content @@ -85,7 +85,7 @@ generateAmpersandOutput multi = doGenHaskell :: IO() doGenHaskell = - do { verboseLn opts $ "Generating Haskell source code for "++name fSpec + do { putStrLn $ "Generating Haskell source code for " ++ name fSpec ++ "..." -- ; verboseLn opts $ fSpec2Haskell fSpec -- switch this on to display the contents of Installer.php on the command line. May be useful for debugging. ; writeFile outputFile (fSpec2Haskell fSpec) ; verboseLn opts $ "Haskell written into " ++ outputFile ++ "." @@ -93,7 +93,7 @@ generateAmpersandOutput multi = where outputFile = dirOutput opts baseName opts -<.> ".hs" doGenSQLdump :: IO() doGenSQLdump = - do { verboseLn opts $ "Generating SQL queries dumpfile for "++name fSpec + do { putStrLn $ "Generating SQL queries dumpfile for " ++ name fSpec ++ "..." ; Text.writeFile outputFile (dumpSQLqueries multi) ; verboseLn opts $ "SQL queries dumpfile written into " ++ outputFile ++ "." } @@ -101,7 +101,7 @@ generateAmpersandOutput multi = doGenUML :: IO() doGenUML = - do { verboseLn opts "Generating UML..." + do { putStrLn "Generating UML..." ; writeFile outputFile $ generateUML fSpec ; verboseLn opts $ "Generated file: " ++ outputFile ++ "." } @@ -113,7 +113,7 @@ generateAmpersandOutput multi = -- This function generates a pandoc document, possibly with pictures from an fSpec. doGenDocument :: IO() doGenDocument = - do { verboseLn opts ("Processing "++name fSpec) + do { putStrLn $ "Generating functional design document for " ++ name fSpec ++ "..." ; -- First we need to output the pictures, because they should be present -- before the actual document is written when (not(noGraphics opts) && fspecFormat opts/=FPandoc) $ @@ -126,14 +126,14 @@ generateAmpersandOutput multi = -- | This function will generate an Excel workbook file, containing an extract from the FSpec doGenFPAExcel :: IO() doGenFPAExcel = - verboseLn opts "FPA analisys is discontinued. (It needs maintenance). Sorry. " -- See https://github.com/AmpersandTarski/Ampersand/issues/621 + putStrLn "Sorry, FPA analisys is discontinued. It needs maintenance." -- See https://github.com/AmpersandTarski/Ampersand/issues/621 -- ; writeFile outputFile $ fspec2FPA_Excel fSpec -- where outputFile = dirOutput opts "FPA_"++baseName opts -<.> ".xml" -- Do not use .xls here, because that generated document contains xml. doGenPopsXLSX :: IO() doGenPopsXLSX = - do { verboseLn opts "Generating .xlsx file containing the population " + do { putStrLn "Generating .xlsx file containing the population..." ; ct <- runIO getPOSIXTime >>= handleError ; L.writeFile outputFile $ fSpec2PopulationXlsx ct fSpec ; verboseLn opts $ "Generated file: " ++ outputFile @@ -142,7 +142,7 @@ generateAmpersandOutput multi = doValidateSQLTest :: IO () doValidateSQLTest = - do { verboseLn opts "Validating SQL expressions..." + do { putStrLn "Validating SQL expressions..." ; errMsg <- validateRulesSQL fSpec ; unless (null errMsg) (exitWith $ InvalidSQLExpression errMsg) } @@ -151,7 +151,7 @@ generateAmpersandOutput multi = doGenProto = if null violationsOfInvariants || allowInvariantViolations opts then sequence_ $ - [ verboseLn opts "Generating prototype..." + [ putStrLn "Generating prototype..." , createDirectoryIfMissing True (dirPrototype opts) , doGenFrontend fSpec , generateDatabaseFile multi @@ -164,7 +164,7 @@ generateAmpersandOutput multi = doGenRapPopulation = if null violationsOfInvariants || allowInvariantViolations opts then sequence_ $ - [ verboseLn opts "Generating RAP population..." + [ putStrLn "Generating RAP population..." , createDirectoryIfMissing True (dirPrototype opts) , generateJSONfiles multi , verboseLn opts $ "RAP population file has been written to " ++ dirPrototype opts diff --git a/src/Ampersand/Prototype/GenFrontend.hs b/src/Ampersand/Prototype/GenFrontend.hs index 40bdcf074e..6d8fb354d2 100644 --- a/src/Ampersand/Prototype/GenFrontend.hs +++ b/src/Ampersand/Prototype/GenFrontend.hs @@ -68,7 +68,7 @@ getTemplateDir fSpec = dirPrototype (getOpts fSpec) "templates" doGenFrontend :: FSpec -> IO () doGenFrontend fSpec = - do { putStrLn "Generating frontend.." + do { verboseLn options "Generating frontend..." ; isCleanInstall <- downloadPrototypeFramework options ; copyTemplates fSpec ; feInterfaces <- buildInterfaces fSpec @@ -79,9 +79,9 @@ doGenFrontend fSpec = ; copyCustomizations fSpec -- ; deleteTemplateDir fSpec -- don't delete template dir anymore, because it is required the next time the frontend is generated ; when isCleanInstall $ do - putStrLn "Installing dependencies.." + putStrLn "Installing dependencies..." -- don't use verboseLn here, because installing dependencies takes some time and we want the user to see this installComposerLibs options - ; putStrLn "Frontend generated." + ; verboseLn options "Frontend generated" } where options = getOpts fSpec From f600cc9f7d597ff13aa2b9f4c8b33ce0c67f6e39 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 6 Jan 2019 19:33:19 +0100 Subject: [PATCH 094/131] Update error message according to PR #877 --- src/Ampersand/Misc/Options.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/Misc/Options.hs b/src/Ampersand/Misc/Options.hs index 88c230fa46..e100b41c8a 100644 --- a/src/Ampersand/Misc/Options.hs +++ b/src/Ampersand/Misc/Options.hs @@ -185,7 +185,7 @@ getOptions' :: EnvironmentOptions -> Options getOptions' envOpts = case errors of [] | allowInvariantViolations opts && validateSQL opts - -> exitWith . WrongArgumentsGiven $ ["--dev and --validate must not be used at the same time."] --(Reason: see ticket #378)) + -> exitWith . WrongArgumentsGiven $ ["--ignore-invariant-violations and --validate must not be used at the same time."] --(Reason: see ticket #378)) | otherwise -> opts _ -> exitWith . WrongArgumentsGiven $ errors ++ [usage] From 0b1a6d0180e777d08f0e72c266a897cf64e0804b Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 6 Jan 2019 19:34:38 +0100 Subject: [PATCH 095/131] Implement generic approach for actions that don't need an ampersand script as input --- app/Main.hs | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index f08c1afd25..2043a72e5f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,19 +1,16 @@ module Main where import Ampersand +import Control.Monad import Data.List import qualified Data.List.NonEmpty as NEL (toList) main :: IO () main = do opts <- getOptions - if showVersion opts || showHelp opts --HJO 20161127 TODO: There are more commands that do not - -- need a single filename to be specified, - -- like --sampleConfigFile. Currently, this - -- does not work properly. A more generic - -- approach for handling those options should - -- be thought of. - then mapM_ putStr (helpNVersionTexts ampersandVersionStr opts) + mapM_ doWhen (actionsWithoutScript opts) -- There are commands that do not need a single filename to be speciied + if orList (map fst $ actionsWithoutScript opts) + then do { verboseLn opts $ "Skipping model processing because special action is requested"} else do { verboseLn opts $ ampersandVersionStr ; putStrLn "Processing your model..." ; gMulti <- createMulti opts @@ -25,4 +22,15 @@ main = generateAmpersandOutput multi ; putStrLn "Finished processing your model" } + where + doWhen :: (Bool, IO ()) -> IO() + doWhen (b,x) = when (b) x + + orList :: [Bool] -> Bool + orList bools = foldr (||) False bools + + actionsWithoutScript :: Options -> [(Bool, IO())] + actionsWithoutScript options = + [ ( showVersion options || showHelp options , mapM_ putStr (helpNVersionTexts ampersandVersionStr options) ) + ] From 1f9bbb82b098df09a41c209236ce50144218b2d5 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 6 Jan 2019 19:45:03 +0100 Subject: [PATCH 096/131] Move genSampleConfigFile (switch --sampleConfigFile) to list of actions that don't require an ampersand script --- app/Main.hs | 2 +- src/Ampersand/Components.hs | 6 ++---- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 2043a72e5f..add74454f3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -32,5 +32,5 @@ main = actionsWithoutScript :: Options -> [(Bool, IO())] actionsWithoutScript options = [ ( showVersion options || showHelp options , mapM_ putStr (helpNVersionTexts ampersandVersionStr options) ) + , ( genSampleConfigFile options , writeConfigFile) ] - diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index b3d32b3e1a..0831cb1017 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -44,8 +44,7 @@ generateAmpersandOutput multi = doWhen (b,x) = when (b opts) x conditionalActions :: [(Options -> Bool, IO())] conditionalActions = - [ ( genSampleConfigFile , doGenSampleConfigFile ) - , ( genUML , doGenUML ) + [ ( genUML , doGenUML ) , ( haskell , doGenHaskell ) , ( sqlDump , doGenSQLdump ) , ( export2adl , doGenADL ) @@ -67,8 +66,7 @@ generateAmpersandOutput multi = ; verboseLn opts $ ".adl-file written to " ++ outputFile ++ "." } where outputFile = dirOutput opts outputfile opts - doGenSampleConfigFile :: IO() - doGenSampleConfigFile = writeConfigFile + doGenProofs :: IO() doGenProofs = do { putStrLn $ "Generating Proof for " ++ name fSpec ++ " into " ++ outputFile ++ "..." From 1d6f40574ae434adf27268220ec71bb23490f129 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 6 Jan 2019 20:11:09 +0100 Subject: [PATCH 097/131] Move add extension --- src/Ampersand/Misc/Options.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Ampersand/Misc/Options.hs b/src/Ampersand/Misc/Options.hs index e100b41c8a..f27989e8dc 100644 --- a/src/Ampersand/Misc/Options.hs +++ b/src/Ampersand/Misc/Options.hs @@ -197,7 +197,7 @@ getOptions' envOpts = (actions, fNames, errors) = getOpt Permute (map fst options) $ envArgsFromConfigFile envOpts ++ envArgsCommandLine envOpts fName = case fNames of [] -> exitWith . WrongArgumentsGiven $ "Please supply the name of an ampersand file" : [usage] - [n] -> n + [n] -> if hasExtension n then n else addExtension n "adl" _ -> exitWith . WrongArgumentsGiven $ ("Too many files: "++ intercalate ", " fNames) : [usage] usage = "Type '"++envProgName envOpts++" --help' for usage info." startOptions :: Options @@ -245,9 +245,7 @@ getOptions' envOpts = , genPOPExcel = False , language = Nothing , progrName = envProgName envOpts - , fileName = if hasExtension fName - then fName - else addExtension fName "adl" + , fileName = fName , baseName = takeBaseName fName , export2adl = False , test = False From e310f7d53b61dabf458799fc8974111d3e2d694d Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 6 Jan 2019 21:24:29 +0100 Subject: [PATCH 098/131] Process model when a file is provided --- app/Main.hs | 11 ++++++++--- src/Ampersand/FSpec/ToFSpec/CreateFspec.hs | 5 ++++- src/Ampersand/Misc/Options.hs | 14 ++++++++------ src/Ampersand/Prototype/GenFrontend.hs | 6 ++---- src/Ampersand/Test/RunAmpersand.hs | 2 +- 5 files changed, 23 insertions(+), 15 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index add74454f3..c65954b02d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -9,9 +9,9 @@ main :: IO () main = do opts <- getOptions mapM_ doWhen (actionsWithoutScript opts) -- There are commands that do not need a single filename to be speciied - if orList (map fst $ actionsWithoutScript opts) - then do { verboseLn opts $ "Skipping model processing because special action is requested"} - else do { verboseLn opts $ ampersandVersionStr + case fileName opts of + Just _ -> do + { verboseLn opts $ ampersandVersionStr ; putStrLn "Processing your model..." ; gMulti <- createMulti opts ; case gMulti of @@ -22,6 +22,11 @@ main = generateAmpersandOutput multi ; putStrLn "Finished processing your model" } + Nothing -> + if orList (map fst $ actionsWithoutScript opts) + then verboseLn opts $ "No further actions, because no ampersand script is provided" + else putStrLn "No ampersand script provided. Use --help for usage information" + where doWhen :: (Bool, IO ()) -> IO() doWhen (b,x) = when (b) x diff --git a/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs b/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs index e2ca6441b0..dd3c49cde8 100644 --- a/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs +++ b/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs @@ -42,7 +42,10 @@ createMulti opts = else return --Not very nice way to do this, but effective. Don't try to remove the return, otherwise the fatal could be evaluated... $ fatal "With the given switches, the formal ampersand model is not supposed to play any part." userP_Ctx:: Guarded P_Context <- - parseADL opts (fileName opts) -- the P_Context of the user's sourceFile + case fileName opts of + Just x -> parseADL opts x -- the P_Context of the user's sourceFile + Nothing -> exitWith . WrongArgumentsGiven $ ["Please supply the name of an ampersand file"] + systemP_Ctx:: Guarded P_Context <- parseSystemContext opts let fAmpFSpec :: FSpec diff --git a/src/Ampersand/Misc/Options.hs b/src/Ampersand/Misc/Options.hs index f27989e8dc..8818ff4b1f 100644 --- a/src/Ampersand/Misc/Options.hs +++ b/src/Ampersand/Misc/Options.hs @@ -38,6 +38,7 @@ data Options = Options { environment :: EnvironmentOptions , genSampleConfigFile :: Bool -- generate a sample configuration file (yaml) , genPrototype :: Bool , dirPrototype :: String -- the directory to generate the prototype in. + , dirSource :: FilePath -- the directory of the script that is being compiled , zwolleVersion :: String -- the version in github of the prototypeFramework. can be a tagname, a branchname or a SHA , forceReinstallFramework :: Bool -- when true, an existing prototype directory will be destroyed and re-installed , dirCustomizations :: [FilePath] -- the directory that is copied after generating the prototype @@ -69,7 +70,7 @@ data Options = Options { environment :: EnvironmentOptions , language :: Maybe Lang -- The language in which the user wants the documentation to be printed. , dirExec :: String --the base for relative paths to input files , progrName :: String --The name of the adl executable - , fileName :: FilePath --the file with the Ampersand context + , fileName :: Maybe FilePath --the file with the Ampersand context , baseName :: String , genTime :: LocalTime , export2adl :: Bool @@ -196,8 +197,8 @@ getOptions' envOpts = where f a b = b a (actions, fNames, errors) = getOpt Permute (map fst options) $ envArgsFromConfigFile envOpts ++ envArgsCommandLine envOpts fName = case fNames of - [] -> exitWith . WrongArgumentsGiven $ "Please supply the name of an ampersand file" : [usage] - [n] -> if hasExtension n then n else addExtension n "adl" + [] -> Nothing + [n] -> if hasExtension n then Just n else Just $ addExtension n "adl" _ -> exitWith . WrongArgumentsGiven $ ("Too many files: "++ intercalate ", " fNames) : [usage] usage = "Type '"++envProgName envOpts++" --help' for usage info." startOptions :: Options @@ -206,11 +207,12 @@ getOptions' envOpts = , genTime = envLocalTime envOpts , dirOutput = fromMaybe "." $ envDirOutput envOpts , outputfile = fatal "No monadic options available." - , dirPrototype = fromMaybe "." (envDirPrototype envOpts) takeBaseName fName <.> ".proto" + , dirPrototype = fromMaybe "." (envDirPrototype envOpts) (takeBaseName (fromMaybe "" fName)) <.> ".proto" + , dirSource = takeDirectory $ fromMaybe "/" fName , zwolleVersion = "development" , forceReinstallFramework = False , dirCustomizations = ["customizations"] - , dbName = fmap toLower . fromMaybe ("ampersand_"++takeBaseName fName) $ envDbName envOpts + , dbName = fmap toLower . fromMaybe ("ampersand_" ++ takeBaseName (fromMaybe "prototype" fName)) $ envDbName envOpts , dirExec = takeDirectory (envExePath envOpts) , preVersion = fromMaybe "" $ envPreVersion envOpts , postVersion = fromMaybe "" $ envPostVersion envOpts @@ -246,7 +248,7 @@ getOptions' envOpts = , language = Nothing , progrName = envProgName envOpts , fileName = fName - , baseName = takeBaseName fName + , baseName = takeBaseName $ fromMaybe "unknown" fName , export2adl = False , test = False , genMetaFile = False diff --git a/src/Ampersand/Prototype/GenFrontend.hs b/src/Ampersand/Prototype/GenFrontend.hs index 6d8fb354d2..e8ade258c3 100644 --- a/src/Ampersand/Prototype/GenFrontend.hs +++ b/src/Ampersand/Prototype/GenFrontend.hs @@ -88,8 +88,7 @@ doGenFrontend fSpec = copyTemplates :: FSpec -> IO () copyTemplates fSpec = - do { let adlSourceDir = takeDirectory $ fileName (getOpts fSpec) - tempDir = adlSourceDir "templates" + do { let tempDir = dirSource (getOpts fSpec) "templates" toDir = dirPrototype (getOpts fSpec) "templates" ; tempDirExists <- doesDirectoryExist tempDir ; if tempDirExists then @@ -104,8 +103,7 @@ copyCustomizations :: FSpec -> IO () copyCustomizations fSpec = mapM_ (copyDir protoDir) custDirs where - adlSourceDir = takeDirectory $ fileName opts - custDirs = map (adlSourceDir ) (dirCustomizations opts) + custDirs = map (dirSource opts ) (dirCustomizations opts) protoDir = dirPrototype opts opts = getOpts fSpec copyDir :: FilePath -> FilePath -> IO() diff --git a/src/Ampersand/Test/RunAmpersand.hs b/src/Ampersand/Test/RunAmpersand.hs index 41ade82514..d6cf33527e 100644 --- a/src/Ampersand/Test/RunAmpersand.hs +++ b/src/Ampersand/Test/RunAmpersand.hs @@ -15,7 +15,7 @@ ampersand files = runAmpersand :: Options -> FilePath -> IO [CtxError] runAmpersand opts file = - do gFSpec <- createMulti opts{ fileName = file } + do gFSpec <- createMulti opts{ fileName = Just file } case gFSpec of Errors err -> return $ NEL.toList err --TODO: Do something with the fSpec From e501f1230c7c81f0a7c22f928f53d8ae8bbb0686 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 6 Jan 2019 21:29:52 +0100 Subject: [PATCH 099/131] Move version string output up --- app/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c65954b02d..e7e165f02d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,11 +8,11 @@ import qualified Data.List.NonEmpty as NEL (toList) main :: IO () main = do opts <- getOptions + verboseLn opts ampersandVersionStr mapM_ doWhen (actionsWithoutScript opts) -- There are commands that do not need a single filename to be speciied case fileName opts of Just _ -> do - { verboseLn opts $ ampersandVersionStr - ; putStrLn "Processing your model..." + { putStrLn "Processing your model..." ; gMulti <- createMulti opts ; case gMulti of Errors err -> From f57bc59ad6f757affddf14c195010cb049f95888 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 6 Jan 2019 21:30:08 +0100 Subject: [PATCH 100/131] Add comments --- app/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index e7e165f02d..74747c7b8b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,7 +11,7 @@ main = verboseLn opts ampersandVersionStr mapM_ doWhen (actionsWithoutScript opts) -- There are commands that do not need a single filename to be speciied case fileName opts of - Just _ -> do + Just _ -> do -- An Ampersand script is provided that can be processed { putStrLn "Processing your model..." ; gMulti <- createMulti opts ; case gMulti of @@ -22,7 +22,7 @@ main = generateAmpersandOutput multi ; putStrLn "Finished processing your model" } - Nothing -> + Nothing -> -- No Ampersand script is provided if orList (map fst $ actionsWithoutScript opts) then verboseLn opts $ "No further actions, because no ampersand script is provided" else putStrLn "No ampersand script provided. Use --help for usage information" From 2997fe944b09722c90619c17174ad96da7054796 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 6 Jan 2019 22:06:01 +0100 Subject: [PATCH 101/131] Split function helpNVersionTexts and move to actionsWithoutScript list --- app/Main.hs | 9 +++++++-- src/Ampersand/Misc.hs | 2 +- src/Ampersand/Misc/Options.hs | 7 +------ 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 74747c7b8b..ec8f5cd2bc 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -36,6 +36,11 @@ main = actionsWithoutScript :: Options -> [(Bool, IO())] actionsWithoutScript options = - [ ( showVersion options || showHelp options , mapM_ putStr (helpNVersionTexts ampersandVersionStr options) ) - , ( genSampleConfigFile options , writeConfigFile) + [ ( test options , putStrLn $ "Executable: " ++ show (dirExec options) ) + , ( showVersion options , putStrLn $ versionText options ) + , ( genSampleConfigFile options , writeConfigFile ) + , ( showHelp options , putStrLn $ usageInfo' options ) ] + + versionText :: Options -> String + versionText opts = preVersion opts ++ ampersandVersionStr ++ postVersion opts diff --git a/src/Ampersand/Misc.hs b/src/Ampersand/Misc.hs index 9d26d9ac72..0975444e50 100644 --- a/src/Ampersand/Misc.hs +++ b/src/Ampersand/Misc.hs @@ -8,6 +8,6 @@ import Ampersand.Misc.Options , verboseLn , verbose , showFormat - , helpNVersionTexts + , usageInfo' , writeConfigFile ) diff --git a/src/Ampersand/Misc/Options.hs b/src/Ampersand/Misc/Options.hs index 8818ff4b1f..a26ec6f51d 100644 --- a/src/Ampersand/Misc/Options.hs +++ b/src/Ampersand/Misc/Options.hs @@ -8,7 +8,7 @@ module Ampersand.Misc.Options , verboseLn , verbose , showFormat - , helpNVersionTexts + , usageInfo' , writeConfigFile ) where @@ -649,8 +649,3 @@ verboseLn opts x do hSetBuffering stdout NoBuffering mapM_ putStrLn (lines x) | otherwise = return () -helpNVersionTexts :: String -> Options -> [String] -helpNVersionTexts vs opts = ["Executable: "++show (dirExec opts)++"\n" | test opts ]++ - [preVersion opts++vs++postVersion opts++"\n" | showVersion opts]++ - [usageInfo' opts | showHelp opts] - From d44c259e0c5b84d6072f99ee40629fd5d10e54d2 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 6 Jan 2019 22:11:47 +0100 Subject: [PATCH 102/131] Update release notes --- ReleaseNotes.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 4d442dd5bf..fa3b493879 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -11,6 +11,8 @@ * Only run composer install when clean install of prototype framework is downloaded * Removed --dev switch as alias of self-explanatory --ignore-invariant-violations * Improved output of any invariant violations or signals for initial population +* Improved use of compiler when no prototype is requested (reporting violations, testing specific rules and rap population output are possible) +* Improved use of compiler when no script is provided (e.g. for --sampleConfigFile) ## v3.12.0 (21 december 2018) From 5ec10df9d8c63a77db51f8cc038d62402ab683bd Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Mon, 7 Jan 2019 16:40:55 +0100 Subject: [PATCH 103/131] Replace orList by or function --- app/Main.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index ec8f5cd2bc..126a343b7b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -23,7 +23,7 @@ main = ; putStrLn "Finished processing your model" } Nothing -> -- No Ampersand script is provided - if orList (map fst $ actionsWithoutScript opts) + if or (map fst $ actionsWithoutScript opts) then verboseLn opts $ "No further actions, because no ampersand script is provided" else putStrLn "No ampersand script provided. Use --help for usage information" @@ -31,9 +31,6 @@ main = doWhen :: (Bool, IO ()) -> IO() doWhen (b,x) = when (b) x - orList :: [Bool] -> Bool - orList bools = foldr (||) False bools - actionsWithoutScript :: Options -> [(Bool, IO())] actionsWithoutScript options = [ ( test options , putStrLn $ "Executable: " ++ show (dirExec options) ) From a72fc7b8cf0e92dbb2059b27925e4e9fa6fcae9c Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Mon, 7 Jan 2019 16:42:47 +0100 Subject: [PATCH 104/131] Use sequence_ instead of monadic mapM_ --- app/Main.hs | 6 +----- src/Ampersand/Components.hs | 4 +--- 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 126a343b7b..32897f36a4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,6 @@ module Main where import Ampersand -import Control.Monad import Data.List import qualified Data.List.NonEmpty as NEL (toList) @@ -9,7 +8,7 @@ main :: IO () main = do opts <- getOptions verboseLn opts ampersandVersionStr - mapM_ doWhen (actionsWithoutScript opts) -- There are commands that do not need a single filename to be speciied + sequence_ . map snd . filter fst $ actionsWithoutScript opts -- There are commands that do not need a single filename to be speciied case fileName opts of Just _ -> do -- An Ampersand script is provided that can be processed { putStrLn "Processing your model..." @@ -28,9 +27,6 @@ main = else putStrLn "No ampersand script provided. Use --help for usage information" where - doWhen :: (Bool, IO ()) -> IO() - doWhen (b,x) = when (b) x - actionsWithoutScript :: Options -> [(Bool, IO())] actionsWithoutScript options = [ ( test options , putStrLn $ "Executable: " ++ show (dirExec options) ) diff --git a/src/Ampersand/Components.hs b/src/Ampersand/Components.hs index 0831cb1017..f1a21a8007 100644 --- a/src/Ampersand/Components.hs +++ b/src/Ampersand/Components.hs @@ -37,11 +37,9 @@ generateAmpersandOutput multi = ; reportInvViolations violationsOfInvariants ; reportSignals (initialConjunctSignals fSpec) ; createDirectoryIfMissing True (dirOutput opts) - ; mapM_ doWhen conditionalActions + ; sequence_ . map snd $ filter (\action -> (fst action) opts) conditionalActions } where - doWhen :: (Options -> Bool, IO ()) -> IO() - doWhen (b,x) = when (b opts) x conditionalActions :: [(Options -> Bool, IO())] conditionalActions = [ ( genUML , doGenUML ) From a2174de5ea311e5cef3b52d8b96f85cb1bddb66b Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Mon, 7 Jan 2019 16:44:50 +0100 Subject: [PATCH 105/131] Prevent double print of version text when --version and --verbose options are provided --- app/Main.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 32897f36a4..378d4a9a3d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,7 +7,6 @@ import qualified Data.List.NonEmpty as NEL (toList) main :: IO () main = do opts <- getOptions - verboseLn opts ampersandVersionStr sequence_ . map snd . filter fst $ actionsWithoutScript opts -- There are commands that do not need a single filename to be speciied case fileName opts of Just _ -> do -- An Ampersand script is provided that can be processed @@ -30,7 +29,7 @@ main = actionsWithoutScript :: Options -> [(Bool, IO())] actionsWithoutScript options = [ ( test options , putStrLn $ "Executable: " ++ show (dirExec options) ) - , ( showVersion options , putStrLn $ versionText options ) + , ( showVersion options || verboseP options , putStrLn $ versionText options ) , ( genSampleConfigFile options , writeConfigFile ) , ( showHelp options , putStrLn $ usageInfo' options ) ] From 648e93a29fc7f61ad357387f0a6c1aa4d9fff9b1 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Mon, 7 Jan 2019 16:45:14 +0100 Subject: [PATCH 106/131] Layout --- app/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 378d4a9a3d..81b1a70c01 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -28,10 +28,10 @@ main = where actionsWithoutScript :: Options -> [(Bool, IO())] actionsWithoutScript options = - [ ( test options , putStrLn $ "Executable: " ++ show (dirExec options) ) + [ ( test options , putStrLn $ "Executable: " ++ show (dirExec options) ) , ( showVersion options || verboseP options , putStrLn $ versionText options ) - , ( genSampleConfigFile options , writeConfigFile ) - , ( showHelp options , putStrLn $ usageInfo' options ) + , ( genSampleConfigFile options , writeConfigFile ) + , ( showHelp options , putStrLn $ usageInfo' options ) ] versionText :: Options -> String From e287ce57c6cbac2ee38107cad99f8374cffa2f97 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Tue, 8 Jan 2019 10:26:46 +0100 Subject: [PATCH 107/131] clean --- src/Ampersand/Input/Parsing.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Ampersand/Input/Parsing.hs b/src/Ampersand/Input/Parsing.hs index e6f45d4076..4583f17c4b 100644 --- a/src/Ampersand/Input/Parsing.hs +++ b/src/Ampersand/Input/Parsing.hs @@ -196,10 +196,9 @@ runParser parser filename input = let lexed = lexer [] filename input in case lexed of Left err -> Errors . pure $ lexerError2CtxError err - --TODO: Do something with the warnings. The warnings cannot be shown with the current Guarded data type Right (tokens, lexerWarnings) - -> addWarnings (map lexerWarning2Warning lexerWarnings) $ whenChecked (parse parser filename tokens) pure - + -> addWarnings (map lexerWarning2Warning lexerWarnings) $ + whenChecked (parse parser filename tokens) pure -- | Parses an isolated rule -- In order to read derivation rules, we use the Ampersand parser. From 66c8944748eb71f29a10df28ee4d11761d73a23a Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Tue, 8 Jan 2019 10:07:57 +0100 Subject: [PATCH 108/131] minor refactor --- src/Ampersand/ADL1/P2A_Converters.hs | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 8a6ce72d6c..78d9b9be97 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -541,7 +541,7 @@ pCtx2aCtx opts , obj_crud = mCrud , obj_mView = mView , obj_msub = subs - } -> do checkCrudForRefInterface + } -> do checkCrud (objExpr,(srcBounded,tgtBounded)) <- typecheckTerm declMap ctx crud <- pCruds2aCruds mCrud maybeObj <- case subs of @@ -556,12 +556,18 @@ pCtx2aCtx opts [] -> Nothing vd:_ -> Just vd -- return the first one, if there are more, this is caught later on by uniqueness static check - checkCrudForRefInterface :: Guarded() - checkCrudForRefInterface = - case (mCrud, subs) of - (Just _ , Just P_InterfaceRef{si_isLink=False}) - -> Errors . pure $ mkCrudForRefInterfaceError orig - _ -> pure () + checkCrud :: Guarded() + checkCrud = + case mCrud of -- , subs) of + Nothing -> pure() + Just (P_Cruds o crd) -> + case subs of + Nothing -> pure() + Just P_InterfaceRef{si_isLink=True} + -> pure() -- fatal $ "TODO: Is it allowed to use `"++crd++"` after an interface reference as at "++show o + Just P_InterfaceRef{si_isLink=False} + -> Errors . pure $ mkCrudForRefInterfaceError orig + Just P_Box{} -> pure() typeCheckViewAnnotation :: Expression -> Maybe String -> Guarded () typeCheckViewAnnotation _ Nothing = pure () typeCheckViewAnnotation objExpr (Just viewId) = From f6fba5669ffa39d4221b60a198e8a1d9c2869fe9 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Tue, 8 Jan 2019 10:17:59 +0100 Subject: [PATCH 109/131] remove -Werror at two places --- src/Ampersand/ADL1/P2A_Converters.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 78d9b9be97..7a28465d9e 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wall -Werror #-} {-# LANGUAGE LambdaCase, ImplicitParams #-} {-# LANGUAGE ApplicativeDo, DuplicateRecordFields,OverloadedLabels #-} module Ampersand.ADL1.P2A_Converters From 8dd9ae52090f2283ef62b69b2b202578ac5a0e03 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Wed, 9 Jan 2019 00:40:23 +0100 Subject: [PATCH 110/131] Added warnings and errors for CRUD --- src/Ampersand/ADL1.hs | 2 +- src/Ampersand/ADL1/Expression.hs | 15 ++++++++- src/Ampersand/ADL1/P2A_Converters.hs | 48 +++++++++++++++++++++++----- src/Ampersand/Input/ADL1/CtxError.hs | 13 +++++++- src/Ampersand/Input/Parsing.hs | 4 +-- 5 files changed, 69 insertions(+), 13 deletions(-) diff --git a/src/Ampersand/ADL1.hs b/src/Ampersand/ADL1.hs index adfbc22683..086457c151 100644 --- a/src/Ampersand/ADL1.hs +++ b/src/Ampersand/ADL1.hs @@ -71,7 +71,7 @@ import Ampersand.Core.AbstractSyntaxTree ( ) import Ampersand.ADL1.Expression ( primitives,subExpressions,Expressions - , notCpl, isCpl, isEEps, isMp1, isFlipped + , notCpl, isCpl, isEEps, isMp1, isFlipped, isRelation , isPos, isNeg , deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc , exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list diff --git a/src/Ampersand/ADL1/Expression.hs b/src/Ampersand/ADL1/Expression.hs index 2a5a5703e5..843f880b0b 100644 --- a/src/Ampersand/ADL1/Expression.hs +++ b/src/Ampersand/ADL1/Expression.hs @@ -3,7 +3,7 @@ module Ampersand.ADL1.Expression ( Expressions ,subst ,primitives, subExpressions, isMp1, isEEps, isEDcD - ,isPos,isNeg, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc, notCpl, isCpl, isFlipped + ,isPos,isNeg, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc, notCpl, isCpl, isFlipped, isRelation ,exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list ,insParentheses) where @@ -147,6 +147,19 @@ isFlipped EFlp{} = True isFlipped (EBrk e) = isFlipped e isFlipped _ = False +-- | Function to determine that the expression is simple, that it +-- could be used to edit its population +isRelation :: Expression -> Bool +isRelation expr = + case expr of + EDcD{} -> True + EFlp e -> isRelation e + EBrk e -> isRelation e + EEps{} -> True + EDcI{} -> True + EMp1{} -> False + EDcV{} -> False + _ -> False exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list :: Expression -> [Expression] exprIsc2list (EIsc (l,r)) = exprIsc2list l++exprIsc2list r diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 7a28465d9e..31bab7aa81 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -7,6 +7,7 @@ module Ampersand.ADL1.P2A_Converters where import Ampersand.ADL1.Disambiguate import Ampersand.ADL1.Lattices -- used for type-checking +import Ampersand.ADL1.Expression import Ampersand.Basics import Ampersand.Classes import Ampersand.Core.ParseTree @@ -17,7 +18,7 @@ import Ampersand.Input.ADL1.CtxError import Ampersand.Misc import Control.Arrow(first) import Control.Monad (join) -import Data.Char(toUpper,toLower) +import Data.Char(toUpper,toLower,isUpper) import Data.Either import Data.Foldable (toList) import Data.Function @@ -540,8 +541,8 @@ pCtx2aCtx opts , obj_crud = mCrud , obj_mView = mView , obj_msub = subs - } -> do checkCrud - (objExpr,(srcBounded,tgtBounded)) <- typecheckTerm declMap ctx + } -> do (objExpr,(srcBounded,tgtBounded)) <- typecheckTerm declMap ctx + checkCrud objExpr crud <- pCruds2aCruds mCrud maybeObj <- case subs of Just P_Box{si_box=[]} -> pure Nothing @@ -555,18 +556,49 @@ pCtx2aCtx opts [] -> Nothing vd:_ -> Just vd -- return the first one, if there are more, this is caught later on by uniqueness static check - checkCrud :: Guarded() - checkCrud = + checkCrud :: Expression -> Guarded() + checkCrud e = case mCrud of -- , subs) of - Nothing -> pure() - Just (P_Cruds o crd) -> + Nothing -> pure() + Just (pc@(P_Cruds _ crd)) -> + let caps = filter isUpper crd + in do + addWarnings ( [mkCrudWarning pc + ["C(reate) for an atom of TYPE "++(show . ttype. target) e++" is not possible. " + ," HINT: You might want to use U(pdate), which updates the pair in the relation."] + | ttype (target e) /= Object + , 'C' `elem` crd + ]++ + [mkCrudWarning pc + ["D(elete) for an atom of TYPE "++(show . ttype. target) e++" is not possible. " + ," HINT: You might want to use U(pdate), which updates the pair in the relation."] + | ttype (target e) /= Object + , 'D' `elem` crd + ]++ + [mkCrudWarning pc + ["R(ead) is required to do "++intercalate ", " (transpose [caps])++"."] + | 'r' `elem` crd && not (null caps) + ] + ) + (mustBeRelationToModify caps) case subs of Nothing -> pure() Just P_InterfaceRef{si_isLink=True} - -> pure() -- fatal $ "TODO: Is it allowed to use `"++crd++"` after an interface reference as at "++show o + -> pure() Just P_InterfaceRef{si_isLink=False} -> Errors . pure $ mkCrudForRefInterfaceError orig Just P_Box{} -> pure() + where + mustBeRelationToModify :: String -> Guarded() + mustBeRelationToModify caps = + case caps of + [] -> pure() + "R" -> pure() + _ -> if isRelation e + then pure() + else Errors $ (mkMustBeEditableExpression pc e NEL.:| []) + ttype :: A_Concept -> TType + ttype = representationOf declMap typeCheckViewAnnotation :: Expression -> Maybe String -> Guarded () typeCheckViewAnnotation _ Nothing = pure () typeCheckViewAnnotation objExpr (Just viewId) = diff --git a/src/Ampersand/Input/ADL1/CtxError.hs b/src/Ampersand/Input/ADL1/CtxError.hs index 86594935d7..4252575d3e 100644 --- a/src/Ampersand/Input/ADL1/CtxError.hs +++ b/src/Ampersand/Input/ADL1/CtxError.hs @@ -24,9 +24,11 @@ module Ampersand.Input.ADL1.CtxError , mkTypeMismatchError , mkMultipleRootsError , mkCrudForRefInterfaceError + , mkMustBeEditableExpression , lexerWarning2Warning , addWarning, addWarnings , showWarning, showWarnings + , mkCrudWarning , Guarded(..) -- If you use Guarded in a monad, make sure you use "ApplicativeDo" in order to get error messages in parallel. , whenCheckedIO, whenChecked, whenError ) @@ -307,6 +309,14 @@ mkOtherTupleInSessionError :: Relation -> AAtomPair -> CtxError mkOtherTupleInSessionError r pr = CTXE OriginUnknown $ "The special concept `SESSION` cannot contain an initial population. However it is populated with `"++showA pr++"` by populating the relation `"++showA r++"`." +mkMustBeEditableExpression :: P_Cruds -> Expression -> CtxError +mkMustBeEditableExpression (P_Cruds o crud) e = + CTXE o . L.intercalate "\n " $ + ["Non editable expression while modification specified:" + ,"In order to modify this field, the expression should be an editable expression. However," + ,"the expression " ++ showA e + ,"in not editable, but you specified `"++crud++"` for it." + ] class ErrorConcept a where showEC :: a -> String @@ -396,7 +406,8 @@ lexerWarning2Warning (LexerWarning a b) = data Warning = Warning Origin String instance Show Warning where show (Warning o msg) = "Warning: " ++ show o ++ concatMap ("\n "++) (lines msg) - +mkCrudWarning :: P_Cruds -> [String] -> Warning +mkCrudWarning (P_Cruds o _ ) msg = Warning o (unlines msg) addWarning :: Warning -> Guarded a -> Guarded a addWarning _ (Errors a) = Errors a addWarning w (Checked a ws) = Checked a (ws <> [w]) diff --git a/src/Ampersand/Input/Parsing.hs b/src/Ampersand/Input/Parsing.hs index 4583f17c4b..3633536b1f 100644 --- a/src/Ampersand/Input/Parsing.hs +++ b/src/Ampersand/Input/Parsing.hs @@ -197,8 +197,8 @@ runParser parser filename input = in case lexed of Left err -> Errors . pure $ lexerError2CtxError err Right (tokens, lexerWarnings) - -> addWarnings (map lexerWarning2Warning lexerWarnings) $ - whenChecked (parse parser filename tokens) pure + -> addWarnings (map lexerWarning2Warning lexerWarnings) + (parse parser filename tokens) -- | Parses an isolated rule -- In order to read derivation rules, we use the Ampersand parser. From e0d467b59777c4f4aece1757d675892d2009aa9d Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Wed, 9 Jan 2019 11:00:13 +0100 Subject: [PATCH 111/131] introduction of isFitForCrud[CRUD] functions --- src/Ampersand/ADL1.hs | 3 +- src/Ampersand/ADL1/Expression.hs | 79 +++++++++++++++++++++++----- src/Ampersand/ADL1/P2A_Converters.hs | 8 +-- 3 files changed, 72 insertions(+), 18 deletions(-) diff --git a/src/Ampersand/ADL1.hs b/src/Ampersand/ADL1.hs index 086457c151..bac4f69993 100644 --- a/src/Ampersand/ADL1.hs +++ b/src/Ampersand/ADL1.hs @@ -71,8 +71,9 @@ import Ampersand.Core.AbstractSyntaxTree ( ) import Ampersand.ADL1.Expression ( primitives,subExpressions,Expressions - , notCpl, isCpl, isEEps, isMp1, isFlipped, isRelation + , notCpl, isCpl, isEEps, isMp1, isFlipped , isPos, isNeg + , isFitForCrudC ,isFitForCrudR ,isFitForCrudU ,isFitForCrudD , deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc , exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list , insParentheses) diff --git a/src/Ampersand/ADL1/Expression.hs b/src/Ampersand/ADL1/Expression.hs index 843f880b0b..d66b8f14ab 100644 --- a/src/Ampersand/ADL1/Expression.hs +++ b/src/Ampersand/ADL1/Expression.hs @@ -3,7 +3,8 @@ module Ampersand.ADL1.Expression ( Expressions ,subst ,primitives, subExpressions, isMp1, isEEps, isEDcD - ,isPos,isNeg, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc, notCpl, isCpl, isFlipped, isRelation + ,isPos,isNeg, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc, notCpl, isCpl, isFlipped + ,isFitForCrudC ,isFitForCrudR ,isFitForCrudU ,isFitForCrudD ,exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list ,insParentheses) where @@ -147,19 +148,71 @@ isFlipped EFlp{} = True isFlipped (EBrk e) = isFlipped e isFlipped _ = False --- | Function to determine that the expression is simple, that it --- could be used to edit its population -isRelation :: Expression -> Bool -isRelation expr = +-- | Function to determine that the expression +-- could be used to create a new atom in its target concept +isFitForCrudC :: Expression -> Bool +isFitForCrudC expr = + case expr of + EDcD{} -> True + EFlp e -> isFitForCrudC e + EBrk e -> isFitForCrudC e + EEps _ _ -> False + EDcI{} -> False + EMp1{} -> False + EDcV{} -> True + ECps ( (EEps _ _), e ) -> isFitForCrudC e + ECps ( e , (EEps _ _)) -> isFitForCrudC e + ECps ( _ , _ ) -> False + EEqu{} -> True + EInc{} -> True + EIsc{} -> True + EUni{} -> True + EDif{} -> True + ELrs{} -> True + ERrs{} -> True + EDia{} -> True + ERad{} -> True + EPrd{} -> True + EKl0{} -> True + EKl1{} -> True + ECpl{} -> True +-- | Function to determine that the expression +-- could be used to read the population of its target concept +isFitForCrudR :: Expression -> Bool +isFitForCrudR expr = True +-- | Function to determine that the expression +-- could be used to insert or delete a pair in the population of a relation +isFitForCrudU :: Expression -> Bool +isFitForCrudU expr = case expr of - EDcD{} -> True - EFlp e -> isRelation e - EBrk e -> isRelation e - EEps{} -> True - EDcI{} -> True - EMp1{} -> False - EDcV{} -> False - _ -> False + EDcD{} -> True + EFlp e -> isFitForCrudU e + EBrk e -> isFitForCrudU e + EEps _ _ -> False + EDcI{} -> False + EMp1{} -> False + EDcV{} -> False + ECps ( (EEps _ _), e ) -> isFitForCrudU e + ECps ( e , (EEps _ _)) -> isFitForCrudU e + ECps ( _ , _ ) -> False + EEqu{} -> False + EInc{} -> False + EIsc{} -> False + EUni{} -> False + EDif{} -> False + ELrs{} -> False + ERrs{} -> False + EDia{} -> False + ERad{} -> False + EPrd{} -> False + EKl0{} -> False + EKl1{} -> False + ECpl{} -> False +-- | Function to determine that the expression is simple, that it +-- could be used to update the population of a relation +isFitForCrudD :: Expression -> Bool +isFitForCrudD expr = True + exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list :: Expression -> [Expression] exprIsc2list (EIsc (l,r)) = exprIsc2list l++exprIsc2list r diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 31bab7aa81..6d072deb9e 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -543,7 +543,7 @@ pCtx2aCtx opts , obj_msub = subs } -> do (objExpr,(srcBounded,tgtBounded)) <- typecheckTerm declMap ctx checkCrud objExpr - crud <- pCruds2aCruds mCrud + crud <- pCruds2aCruds objExpr mCrud maybeObj <- case subs of Just P_Box{si_box=[]} -> pure Nothing _ -> maybeOverGuarded (pSubi2aSubi declMap objExpr tgtBounded objDef) subs <* typeCheckViewAnnotation objExpr mView @@ -594,7 +594,7 @@ pCtx2aCtx opts case caps of [] -> pure() "R" -> pure() - _ -> if isRelation e + _ -> if isFitForCrudU e then pure() else Errors $ (mkMustBeEditableExpression pc e NEL.:| []) ttype :: A_Concept -> TType @@ -629,8 +629,8 @@ pCtx2aCtx opts , objtxt = str },True) - pCruds2aCruds :: Maybe P_Cruds -> Guarded Cruds - pCruds2aCruds mCrud = + pCruds2aCruds :: Expression -> Maybe P_Cruds -> Guarded Cruds + pCruds2aCruds expr mCrud = --TODO: Use expr to determine which default Cruds to return. Make sure that the default is as liberal as can be, but doesn't cause run time errors. case mCrud of Nothing -> build (Origin "default for Cruds") "" Just (P_Cruds org str ) -> if (length . nub . map toUpper) str == length str && all (`elem` "cCrRuUdD") str From 0a3799c41dc555c2236c08df087492673a7f21bf Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Thu, 10 Jan 2019 17:26:02 +0100 Subject: [PATCH 112/131] WIP --- src/Ampersand/ADL1/Expression.hs | 4 +- src/Ampersand/ADL1/P2A_Converters.hs | 93 ++++++++++++++++++---------- 2 files changed, 63 insertions(+), 34 deletions(-) diff --git a/src/Ampersand/ADL1/Expression.hs b/src/Ampersand/ADL1/Expression.hs index d66b8f14ab..0d7dd59801 100644 --- a/src/Ampersand/ADL1/Expression.hs +++ b/src/Ampersand/ADL1/Expression.hs @@ -179,7 +179,7 @@ isFitForCrudC expr = -- | Function to determine that the expression -- could be used to read the population of its target concept isFitForCrudR :: Expression -> Bool -isFitForCrudR expr = True +isFitForCrudR _ = True -- | Function to determine that the expression -- could be used to insert or delete a pair in the population of a relation isFitForCrudU :: Expression -> Bool @@ -211,7 +211,7 @@ isFitForCrudU expr = -- | Function to determine that the expression is simple, that it -- could be used to update the population of a relation isFitForCrudD :: Expression -> Bool -isFitForCrudD expr = True +isFitForCrudD _ = True exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list :: Expression -> [Expression] diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 6d072deb9e..2af70eb7bd 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -10,9 +10,10 @@ import Ampersand.ADL1.Lattices -- used for type-checking import Ampersand.ADL1.Expression import Ampersand.Basics import Ampersand.Classes -import Ampersand.Core.ParseTree import Ampersand.Core.A2P_Converters import Ampersand.Core.AbstractSyntaxTree +import Ampersand.Core.ParseTree +import Ampersand.Core.ShowAStruct import Ampersand.FSpec.ToFSpec.Populated(sortSpecific2Generic) import Ampersand.Input.ADL1.CtxError import Ampersand.Misc @@ -563,24 +564,7 @@ pCtx2aCtx opts Just (pc@(P_Cruds _ crd)) -> let caps = filter isUpper crd in do - addWarnings ( [mkCrudWarning pc - ["C(reate) for an atom of TYPE "++(show . ttype. target) e++" is not possible. " - ," HINT: You might want to use U(pdate), which updates the pair in the relation."] - | ttype (target e) /= Object - , 'C' `elem` crd - ]++ - [mkCrudWarning pc - ["D(elete) for an atom of TYPE "++(show . ttype. target) e++" is not possible. " - ," HINT: You might want to use U(pdate), which updates the pair in the relation."] - | ttype (target e) /= Object - , 'D' `elem` crd - ]++ - [mkCrudWarning pc - ["R(ead) is required to do "++intercalate ", " (transpose [caps])++"."] - | 'r' `elem` crd && not (null caps) - ] - ) - (mustBeRelationToModify caps) + (mustBeRelationToModify caps) case subs of Nothing -> pure() Just P_InterfaceRef{si_isLink=True} @@ -630,26 +614,71 @@ pCtx2aCtx opts },True) pCruds2aCruds :: Expression -> Maybe P_Cruds -> Guarded Cruds - pCruds2aCruds expr mCrud = --TODO: Use expr to determine which default Cruds to return. Make sure that the default is as liberal as can be, but doesn't cause run time errors. + pCruds2aCruds expr mCrud = case mCrud of - Nothing -> build (Origin "default for Cruds") "" - Just (P_Cruds org str ) -> if (length . nub . map toUpper) str == length str && all (`elem` "cCrRuUdD") str - then build org str - else Errors . pure $ mkInvalidCRUDError org str + Nothing -> mostLiberalCruds (Origin "Default for Cruds") "" + Just pc@(P_Cruds org userCrudString ) + | (length . nub . map toUpper) userCrudString == length userCrudString && + all (`elem` "cCrRuUdD") userCrudString + -> warnings pc $ mostLiberalCruds org userCrudString + | otherwise -> Errors . pure $ mkInvalidCRUDError org userCrudString where (defC, defR, defU, defD) = defaultCrud opts - build org str - = pure Cruds { crudOrig = org - , crudC = f 'C' defC - , crudR = f 'R' defR - , crudU = f 'U' defU - , crudD = f 'D' defD + mostLiberalCruds :: Origin -> String -> Guarded Cruds + mostLiberalCruds o str + = pure Cruds { crudOrig = o + , crudC = isFitForCrudC expr && f 'C' defC + , crudR = isFitForCrudR expr && f 'R' defR + , crudU = isFitForCrudU expr && f 'U' defU + , crudD = isFitForCrudD expr && f 'D' defD } - where f :: Char -> Bool -> Bool + where + f :: Char -> Bool -> Bool f c def' | toUpper c `elem` str = True | toLower c `elem` str = False | otherwise = def' - + warnings :: P_Cruds -> Guarded Cruds -> Guarded Cruds + warnings pc@(P_Cruds _ crd) aCruds = addWarnings warns aCruds + where + caps = filter isUpper crd + warns :: [Warning] + warns = map (mkCrudWarning pc) $ + [ + ( + [ "'C' was specified, but the expression " + , " "++showA expr + , " doesn't allow for creation of a new atom at its target concept ("++name (target expr)++") " + ] + ) + -- ++ + -- [ " HINT: You might want to use U(pdate), which updates the pair in the relation." + -- | isFitForCrudU expr + -- ] + | 'C' `elem` crd && not (isFitForCrudC expr) + ]++ + [ [ "'R' was specified, but the expression " + , " "++showA expr + , " doesn't allow for read of the pairs in that expression." + ] + | 'R' `elem` crd && not (isFitForCrudR expr) + ]++ + [ [ "'U' was specified, but the expression " + , " "++showA expr + , " doesn't allow to insert or delete pairs in it." + ] + | 'U' `elem` crd && not (isFitForCrudU expr) + ]++ + [ [ "'D' was specified, but the expression " + , " "++showA expr + , " doesn't allow for deletion of an atom from its target concept ("++name (target expr)++") " + ] + | 'D' `elem` crd && not (isFitForCrudD expr) + ]++ + [ [ "R(ead) is required to do "++intercalate ", " (transpose [caps])++"." + , " however, you explicitly specified 'r'." + ] + | 'r' `elem` crd && not (null caps) + ] pSubi2aSubi :: ContextInfo -> Expression -- Expression of the surrounding -> Bool -- Whether the surrounding is bounded From 97abeb13702ebc3353e2df93de61909622afd2fe Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Fri, 11 Jan 2019 19:36:46 +0100 Subject: [PATCH 113/131] Warnings in place --- src/Ampersand/ADL1/P2A_Converters.hs | 96 +++++++++++----------------- src/Ampersand/Input/ADL1/CtxError.hs | 14 ++-- 2 files changed, 45 insertions(+), 65 deletions(-) diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 2af70eb7bd..225267cb29 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -543,7 +543,7 @@ pCtx2aCtx opts , obj_mView = mView , obj_msub = subs } -> do (objExpr,(srcBounded,tgtBounded)) <- typecheckTerm declMap ctx - checkCrud objExpr + checkCrud crud <- pCruds2aCruds objExpr mCrud maybeObj <- case subs of Just P_Box{si_box=[]} -> pure Nothing @@ -557,32 +557,12 @@ pCtx2aCtx opts [] -> Nothing vd:_ -> Just vd -- return the first one, if there are more, this is caught later on by uniqueness static check - checkCrud :: Expression -> Guarded() - checkCrud e = - case mCrud of -- , subs) of - Nothing -> pure() - Just (pc@(P_Cruds _ crd)) -> - let caps = filter isUpper crd - in do - (mustBeRelationToModify caps) - case subs of - Nothing -> pure() - Just P_InterfaceRef{si_isLink=True} - -> pure() - Just P_InterfaceRef{si_isLink=False} - -> Errors . pure $ mkCrudForRefInterfaceError orig - Just P_Box{} -> pure() - where - mustBeRelationToModify :: String -> Guarded() - mustBeRelationToModify caps = - case caps of - [] -> pure() - "R" -> pure() - _ -> if isFitForCrudU e - then pure() - else Errors $ (mkMustBeEditableExpression pc e NEL.:| []) - ttype :: A_Concept -> TType - ttype = representationOf declMap + checkCrud :: Guarded() + checkCrud = + case (mCrud, subs) of + (Just _ , Just P_InterfaceRef{si_isLink=False} ) + -> Errors . pure $ mkCrudForRefInterfaceError orig + _ -> pure() typeCheckViewAnnotation :: Expression -> Maybe String -> Guarded () typeCheckViewAnnotation _ Nothing = pure () typeCheckViewAnnotation objExpr (Just viewId) = @@ -644,38 +624,35 @@ pCtx2aCtx opts warns :: [Warning] warns = map (mkCrudWarning pc) $ [ - ( [ "'C' was specified, but the expression " , " "++showA expr - , " doesn't allow for creation of a new atom at its target concept ("++name (target expr)++") " + , "doesn't allow for the creation of a new atom at its target concept ("++name (target expr)++") " + ] ++ + [ " HINT: You might want to use U(pdate), which updates the pair in the relation." + | isFitForCrudU expr, 'U' `notElem` crd ] - ) - -- ++ - -- [ " HINT: You might want to use U(pdate), which updates the pair in the relation." - -- | isFitForCrudU expr - -- ] | 'C' `elem` crd && not (isFitForCrudC expr) ]++ [ [ "'R' was specified, but the expression " , " "++showA expr - , " doesn't allow for read of the pairs in that expression." + , "doesn't allow for read of the pairs in that expression." ] | 'R' `elem` crd && not (isFitForCrudR expr) ]++ [ [ "'U' was specified, but the expression " , " "++showA expr - , " doesn't allow to insert or delete pairs in it." + , "doesn't allow to insert or delete pairs in it." ] | 'U' `elem` crd && not (isFitForCrudU expr) ]++ [ [ "'D' was specified, but the expression " , " "++showA expr - , " doesn't allow for deletion of an atom from its target concept ("++name (target expr)++") " + , "doesn't allow for the deletion of an atom from its target concept ("++name (target expr)++") " ] | 'D' `elem` crd && not (isFitForCrudD expr) ]++ [ [ "R(ead) is required to do "++intercalate ", " (transpose [caps])++"." - , " however, you explicitly specified 'r'." + , "however, you explicitly specified 'r'." ] | 'r' `elem` crd && not (null caps) ] @@ -752,27 +729,32 @@ pCtx2aCtx opts disambNamedRel (PNamedRel _ r (Just s)) = findRelsTyped declMap r $ pSign2aSign s pIfc2aIfc :: ContextInfo -> (P_Interface, P_BoxItem (TermPrim, DisambPrim)) -> Guarded Interface - pIfc2aIfc ci - (P_Ifc { ifc_IsAPI = isAPI - , ifc_Name = nm - , ifc_Roles = rols - , ifc_Obj = _ - , pos = orig - , ifc_Prp = prp - }, objDisamb) - = (\ obj' - -> case obj' of + pIfc2aIfc declMap (pIfc, objDisamb) = + build $ pObjDefDisamb2aObjDef declMap objDisamb + where + build :: Guarded BoxItem -> Guarded Interface + build gb = + case gb of + Errors x -> Errors x + Checked obj' ws -> + addWarnings ws $ + case obj' of BxExpr o -> - Ifc { ifcIsAPI = isAPI - , ifcname = nm - , ifcRoles = rols - , ifcObj = o - , ifcControls = [] -- to be enriched in Adl2fSpec with rules to be checked - , ifcPos = orig - , ifcPrp = prp - } + case ttype . target . objExpression $ o of + Object -> + pure Ifc { ifcIsAPI = ifc_IsAPI pIfc + , ifcname = name pIfc + , ifcRoles = ifc_Roles pIfc + , ifcObj = o + , ifcControls = [] -- to be enriched in Adl2fSpec with rules to be checked + , ifcPos = origin pIfc + , ifcPrp = ifc_Prp pIfc + } + tt -> Errors . pure + . mkInterfaceMustBeDefinedOnObject pIfc (target . objExpression $ o) $ tt BxTxt _ -> fatal "Unexpected BxTxt" --Interface should not have TXT only. it should have an expression object. - ) <$> pObjDefDisamb2aObjDef ci objDisamb + ttype :: A_Concept -> TType + ttype = representationOf declMap pRoleRelation2aRoleRelation :: ContextInfo -> P_RoleRelation -> Guarded A_RoleRelation pRoleRelation2aRoleRelation ci prr diff --git a/src/Ampersand/Input/ADL1/CtxError.hs b/src/Ampersand/Input/ADL1/CtxError.hs index 4252575d3e..2b4c2a8482 100644 --- a/src/Ampersand/Input/ADL1/CtxError.hs +++ b/src/Ampersand/Input/ADL1/CtxError.hs @@ -24,7 +24,7 @@ module Ampersand.Input.ADL1.CtxError , mkTypeMismatchError , mkMultipleRootsError , mkCrudForRefInterfaceError - , mkMustBeEditableExpression + , mkInterfaceMustBeDefinedOnObject , lexerWarning2Warning , addWarning, addWarnings , showWarning, showWarnings @@ -309,13 +309,11 @@ mkOtherTupleInSessionError :: Relation -> AAtomPair -> CtxError mkOtherTupleInSessionError r pr = CTXE OriginUnknown $ "The special concept `SESSION` cannot contain an initial population. However it is populated with `"++showA pr++"` by populating the relation `"++showA r++"`." -mkMustBeEditableExpression :: P_Cruds -> Expression -> CtxError -mkMustBeEditableExpression (P_Cruds o crud) e = - CTXE o . L.intercalate "\n " $ - ["Non editable expression while modification specified:" - ,"In order to modify this field, the expression should be an editable expression. However," - ,"the expression " ++ showA e - ,"in not editable, but you specified `"++crud++"` for it." +mkInterfaceMustBeDefinedOnObject :: P_Interface -> A_Concept -> TType -> CtxError +mkInterfaceMustBeDefinedOnObject ifc cpt tt = + CTXE (origin ifc) . L.intercalate "\n " $ + ["The TYPE of the concept for wich an INTERFACE is defined should be OBJECT." + ,"The TYPE of the concept `"++name cpt++"`, for interface `"++name ifc++"`, however is "++show tt++"." ] class ErrorConcept a where showEC :: a -> String From 92347c1aa83e865809cdc13bf7b9192dadd22bf0 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sat, 12 Jan 2019 00:26:05 +0100 Subject: [PATCH 114/131] Move testcase from shouldsucceed to shouldfail --- .../InterfacesAndCruds}/Issue163.adl | 4 ++-- .../prototype/shouldFail/InterfacesAndCruds/testinfo.yaml | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) rename testing/Travis/testcases/prototype/{shouldSucceed => shouldFail/InterfacesAndCruds}/Issue163.adl (70%) create mode 100644 testing/Travis/testcases/prototype/shouldFail/InterfacesAndCruds/testinfo.yaml diff --git a/testing/Travis/testcases/prototype/shouldSucceed/Issue163.adl b/testing/Travis/testcases/prototype/shouldFail/InterfacesAndCruds/Issue163.adl similarity index 70% rename from testing/Travis/testcases/prototype/shouldSucceed/Issue163.adl rename to testing/Travis/testcases/prototype/shouldFail/InterfacesAndCruds/Issue163.adl index cbd9a67c62..5d555b6783 100644 --- a/testing/Travis/testcases/prototype/shouldSucceed/Issue163.adl +++ b/testing/Travis/testcases/prototype/shouldFail/InterfacesAndCruds/Issue163.adl @@ -4,9 +4,9 @@ RELATION r[A*A] RELATION s[B*B] POPULATION A CONTAINS [ 3, 6, 42 ] --- This example should fail, because A and B are in the same typology, however ther repersentation-types are different. +-- This example should fail, because A and B are in the same typology, and B has TYPE INTEGER. +-- The target concept of an INTERFACE's expresion must be of type OBJECT (which is the default) CLASSIFY B ISA A -REPRESENT A TYPE INTEGER REPRESENT B TYPE INTEGER INTERFACE Issue163 (r,s) : V[SESSION*A] diff --git a/testing/Travis/testcases/prototype/shouldFail/InterfacesAndCruds/testinfo.yaml b/testing/Travis/testcases/prototype/shouldFail/InterfacesAndCruds/testinfo.yaml new file mode 100644 index 0000000000..d5007824f6 --- /dev/null +++ b/testing/Travis/testcases/prototype/shouldFail/InterfacesAndCruds/testinfo.yaml @@ -0,0 +1 @@ +command : ampersand --proto --verbose From 065efc23f7fccc980b16b47a6d19c5b5f299f078 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sat, 12 Jan 2019 09:07:09 +0100 Subject: [PATCH 115/131] fix testinfo --- .../prototype/shouldFail/InterfacesAndCruds/testinfo.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/testing/Travis/testcases/prototype/shouldFail/InterfacesAndCruds/testinfo.yaml b/testing/Travis/testcases/prototype/shouldFail/InterfacesAndCruds/testinfo.yaml index d5007824f6..45b0d3dfba 100644 --- a/testing/Travis/testcases/prototype/shouldFail/InterfacesAndCruds/testinfo.yaml +++ b/testing/Travis/testcases/prototype/shouldFail/InterfacesAndCruds/testinfo.yaml @@ -1 +1,2 @@ command : ampersand --proto --verbose +shouldSucceed : false From 8524cbc7130f37ac64bcd59b4c3eda7fc310c6dc Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 13 Jan 2019 00:11:55 +0100 Subject: [PATCH 116/131] Move AmpPreProc.hs --- ampersand.cabal | 19 ++++++++++++++----- preProcApp/Main.hs => app/AmpPreProc.hs | 2 +- 2 files changed, 15 insertions(+), 6 deletions(-) rename preProcApp/Main.hs => app/AmpPreProc.hs (94%) diff --git a/ampersand.cabal b/ampersand.cabal index 90c8dbad82..1cedbf9572 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -19,6 +19,11 @@ bug-reports: https://github.com/AmpersandTarski/ampersand/issues data-files: LICENSE +Flag AmpPreProc + Description: Build the Ampersand Preprocessor `AmpPreProc`. + Default: False + Manual: True + custom-setup setup-depends: base == 4.11.*, bytestring == 0.10.*, @@ -186,14 +191,18 @@ executable ampersand ampersand executable ampPreProc - hs-source-dirs: preProcApp - main-is: Main.hs + hs-source-dirs: app + main-is: AmpPreProc.hs default-language: Haskell2010 ghc-options: -Wall -threaded default-extensions:NoImplicitPrelude - build-depends: base == 4.11.*, - containers == 0.5.*, - ampersand + if flag(AmpPreProc) + build-depends: base == 4.11.*, + containers == 0.5.*, + ampersand + buildable: True + else + buildable: False Test-Suite regression-test type: exitcode-stdio-1.0 diff --git a/preProcApp/Main.hs b/app/AmpPreProc.hs similarity index 94% rename from preProcApp/Main.hs rename to app/AmpPreProc.hs index af3945b1ed..d871273689 100644 --- a/preProcApp/Main.hs +++ b/app/AmpPreProc.hs @@ -1,4 +1,4 @@ -module Main where +module AmpPreProc where import Ampersand import System.Environment From c3ced053e9e20f7d78700df2ea1db7fcb6352dee Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 13 Jan 2019 00:47:40 +0100 Subject: [PATCH 117/131] Add flag `buildAll` to the cabal file --- ampersand.cabal | 6 +++--- app/AmpPreProc.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/ampersand.cabal b/ampersand.cabal index 1cedbf9572..741ac3a567 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -19,8 +19,8 @@ bug-reports: https://github.com/AmpersandTarski/ampersand/issues data-files: LICENSE -Flag AmpPreProc - Description: Build the Ampersand Preprocessor `AmpPreProc`. +Flag buildAll + Description: Build both ampersand and ampPreProc. Default: False Manual: True @@ -196,7 +196,7 @@ executable ampPreProc default-language: Haskell2010 ghc-options: -Wall -threaded default-extensions:NoImplicitPrelude - if flag(AmpPreProc) + if flag(buildAll) build-depends: base == 4.11.*, containers == 0.5.*, ampersand diff --git a/app/AmpPreProc.hs b/app/AmpPreProc.hs index d871273689..af3945b1ed 100644 --- a/app/AmpPreProc.hs +++ b/app/AmpPreProc.hs @@ -1,4 +1,4 @@ -module AmpPreProc where +module Main where import Ampersand import System.Environment From abbc1c5204114c064d114b75a554501a9828d436 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 13 Jan 2019 01:00:04 +0100 Subject: [PATCH 118/131] make travis build the preprocessor everytime --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 59d6ddabd0..9f73bad257 100644 --- a/.travis.yml +++ b/.travis.yml @@ -127,7 +127,7 @@ install: - | case "$BUILD" in stack) - stack --no-terminal --install-ghc $ARGS test --only-dependencies + stack --no-terminal --install-ghc $ARGS test --only-dependencies --flag ampersand:buildAll ;; cabal) cabal --version @@ -143,7 +143,7 @@ script: - | case "$BUILD" in stack) - ./travis_long stack --no-terminal --test --local-bin-path=dist --copy-bins $ARGS build + ./travis_long stack --no-terminal --test --local-bin-path=dist --copy-bins $ARGS build --flag ampersand:buildAll ;; cabal) ./travis_long cabal test From 0cf00d3898687c20790c88f7c68dd97f4926045a Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 13 Jan 2019 12:41:27 +0100 Subject: [PATCH 119/131] fix warning from cabal --- ampersand.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ampersand.cabal b/ampersand.cabal index 741ac3a567..056c39f360 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -7,7 +7,7 @@ description: You can define your business processes by means of rules, writte homepage: http://ampersandtarski.github.io/ category: Database Design stability: alpha -cabal-version: >= 2.0 +cabal-version: 2.0 tested-with: GHC == 8.4.3 build-type: Custom license: GPL From aa83ba56012a1174d76c70226de97307e4372760 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 13 Jan 2019 10:39:48 +0100 Subject: [PATCH 120/131] Consider r;I[cpt] to be editable --- src/Ampersand/ADL1/Expression.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Ampersand/ADL1/Expression.hs b/src/Ampersand/ADL1/Expression.hs index 0d7dd59801..a8fffad487 100644 --- a/src/Ampersand/ADL1/Expression.hs +++ b/src/Ampersand/ADL1/Expression.hs @@ -194,6 +194,7 @@ isFitForCrudU expr = EDcV{} -> False ECps ( (EEps _ _), e ) -> isFitForCrudU e ECps ( e , (EEps _ _)) -> isFitForCrudU e + ECps ( e , EDcI{} ) -> isFitForCrudU e ECps ( _ , _ ) -> False EEqu{} -> False EInc{} -> False From 9885c60638572dc0b3b46e78fe43b156f4c9228a Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 13 Jan 2019 13:30:35 +0100 Subject: [PATCH 121/131] Bugfix. Composition expr is fit for C --- src/Ampersand/ADL1/Expression.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/ADL1/Expression.hs b/src/Ampersand/ADL1/Expression.hs index a8fffad487..413f0dd345 100644 --- a/src/Ampersand/ADL1/Expression.hs +++ b/src/Ampersand/ADL1/Expression.hs @@ -162,7 +162,7 @@ isFitForCrudC expr = EDcV{} -> True ECps ( (EEps _ _), e ) -> isFitForCrudC e ECps ( e , (EEps _ _)) -> isFitForCrudC e - ECps ( _ , _ ) -> False + ECps ( _ , _ ) -> True EEqu{} -> True EInc{} -> True EIsc{} -> True From b3af21481bd6d2290e201886d6784f3fcad137bd Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 13 Jan 2019 13:41:40 +0100 Subject: [PATCH 122/131] Read is required for Update or Delete, not Create. --- src/Ampersand/ADL1/P2A_Converters.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Ampersand/ADL1/P2A_Converters.hs b/src/Ampersand/ADL1/P2A_Converters.hs index 225267cb29..1b63a1d987 100644 --- a/src/Ampersand/ADL1/P2A_Converters.hs +++ b/src/Ampersand/ADL1/P2A_Converters.hs @@ -19,7 +19,7 @@ import Ampersand.Input.ADL1.CtxError import Ampersand.Misc import Control.Arrow(first) import Control.Monad (join) -import Data.Char(toUpper,toLower,isUpper) +import Data.Char(toUpper,toLower) import Data.Either import Data.Foldable (toList) import Data.Function @@ -620,7 +620,6 @@ pCtx2aCtx opts warnings :: P_Cruds -> Guarded Cruds -> Guarded Cruds warnings pc@(P_Cruds _ crd) aCruds = addWarnings warns aCruds where - caps = filter isUpper crd warns :: [Warning] warns = map (mkCrudWarning pc) $ [ @@ -650,11 +649,12 @@ pCtx2aCtx opts , "doesn't allow for the deletion of an atom from its target concept ("++name (target expr)++") " ] | 'D' `elem` crd && not (isFitForCrudD expr) - ]++ - [ [ "R(ead) is required to do "++intercalate ", " (transpose [caps])++"." + ] + ++ + [ [ "R(ead) is required to do U(pdate) or D(elete) " , "however, you explicitly specified 'r'." ] - | 'r' `elem` crd && not (null caps) + | 'r' `elem` crd && ('U' `elem` crd || 'D' `elem` crd) ] pSubi2aSubi :: ContextInfo -> Expression -- Expression of the surrounding From 67dee791bc98f6a75190e2c7666bbb478e0581d1 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 13 Jan 2019 14:12:27 +0100 Subject: [PATCH 123/131] Temporary solution while waiting for #884 --- src/Ampersand/ADL1/Expression.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Ampersand/ADL1/Expression.hs b/src/Ampersand/ADL1/Expression.hs index 413f0dd345..131728a6b9 100644 --- a/src/Ampersand/ADL1/Expression.hs +++ b/src/Ampersand/ADL1/Expression.hs @@ -157,7 +157,7 @@ isFitForCrudC expr = EFlp e -> isFitForCrudC e EBrk e -> isFitForCrudC e EEps _ _ -> False - EDcI{} -> False + EDcI{} -> True -- TODO: set to False when functionality of +menu is adapted from I[Cpt] to V[SESSION*Cpt] expressions (see Issue #884) EMp1{} -> False EDcV{} -> True ECps ( (EEps _ _), e ) -> isFitForCrudC e From 45a888690d14551ec56ab8aed1c319a9c8eb48e6 Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Sun, 13 Jan 2019 14:13:23 +0100 Subject: [PATCH 124/131] Update output message --- app/Main.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index bab5c64170..a65cbb6eff 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -19,11 +19,12 @@ main = Checked multi ws -> do showWarnings ws generateAmpersandOutput multi + putStrLn "Finished processing your model" putStrLn . ("Your script has no errors " ++) $ case ws of - [] -> "and no warnings." - [_] -> ", but one warning was found." - _ -> ", but "++show (length ws)++" warnings were found." + [] -> "and no warnings" + [_] -> ", but one warning was found" + _ -> ", but "++show (length ws)++" warnings were found" } Nothing -> -- No Ampersand script is provided if or (map fst $ actionsWithoutScript opts) From da12cc5d6f67d05770b1d6f8276a3ecfc4033516 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Sun, 13 Jan 2019 13:11:39 +0100 Subject: [PATCH 125/131] replace tab chars by spaces. --- AmpersandData/FormalAmpersand/AST.ifc | 52 +++++++++++++-------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/AmpersandData/FormalAmpersand/AST.ifc b/AmpersandData/FormalAmpersand/AST.ifc index aa2c436fb7..80e41a85b0 100644 --- a/AmpersandData/FormalAmpersand/AST.ifc +++ b/AmpersandData/FormalAmpersand/AST.ifc @@ -130,9 +130,9 @@ BOX [ Signature: I[Signature] INTERFACE PropertyRule FOR Ampersand : I[PropertyRule] BOX [ "declaredthrough": declaredthrough[PropertyRule*Property] - , "propertyRule~" : propertyRule[Relation*PropertyRule]~ LINKTO INTERFACE "Relation" - ] - + , "propertyRule~" : propertyRule[Relation*PropertyRule]~ LINKTO INTERFACE "Relation" + ] + INTERFACE Isa FOR Ampersand : I[Isa] @@ -143,29 +143,29 @@ BOX [ "gens~" : gens[Context*Isa]~ INTERFACE Relation FOR Ampersand : I[Relation] BOX [ "declared in context" : declaredIn[Relation*Context] - , "decMean" : decMean[Relation*Meaning] - , "decprL" : decprL[Relation*String] - , "decprM" : decprM[Relation*String] - , "decprR" : decprR[Relation*String] - , "propertyRule" : propertyRule[Relation*PropertyRule] - , "purpose" : purpose[Relation*Purpose] - , "name" : name[Relation*RelationName] - , "prop" : prop[Relation*Property] - , "sign" : sign[Relation*Signature] - , "source" : source[Relation*Concept] --- , "srcAtt" : srcAtt[Relation*SqlAttribute] - , "target" : target[Relation*Concept] --- , "tgtAtt" : tgtAtt[Relation*SqlAttribute] - , "bind~" : bind[BindedRelation*Relation]~ - , "declared in pattern" : declaredIn[Relation*Pattern] - , "declared in context (outside a pattern)" : ctxds[Relation*Context] --- , "in~" : in[Pair*Relation]~ --- BOX --- [ lAtom : lAtom --- , rAtom : rAtom --- ] - , "valid in (context)" : valid[Relation*Context] --- , "relsInPlug~" : relsInPlug[Plug*Relation]~ + , "decMean" : decMean[Relation*Meaning] + , "decprL" : decprL[Relation*String] + , "decprM" : decprM[Relation*String] + , "decprR" : decprR[Relation*String] + , "propertyRule" : propertyRule[Relation*PropertyRule] + , "purpose" : purpose[Relation*Purpose] + , "name" : name[Relation*RelationName] + , "prop" : prop[Relation*Property] + , "sign" : sign[Relation*Signature] + , "source" : source[Relation*Concept] +-- , "srcAtt" : srcAtt[Relation*SqlAttribute] + , "target" : target[Relation*Concept] +-- , "tgtAtt" : tgtAtt[Relation*SqlAttribute] + , "bind~" : bind[BindedRelation*Relation]~ + , "declared in pattern" : declaredIn[Relation*Pattern] + , "declared in context (outside a pattern)" : ctxds[Relation*Context] +-- , "in~" : in[Pair*Relation]~ +-- BOX +-- [ lAtom : lAtom +-- , rAtom : rAtom +-- ] + , "valid in (context)" : valid[Relation*Context] +-- , "relsInPlug~" : relsInPlug[Plug*Relation]~ ] {- From f10906286943afeb661b32d8725547b80fc0bb25 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Tue, 15 Jan 2019 08:41:50 +0100 Subject: [PATCH 126/131] Refactor of Transformers using Data.Set instead of lists. --- src/Ampersand/Core/AbstractSyntaxTree.hs | 20 +- src/Ampersand/FSpec/ShowMeatGrinder.hs | 63 +- src/Ampersand/FSpec/ToFSpec/CreateFspec.hs | 9 +- src/Ampersand/FSpec/Transformers.hs | 699 ++++++++++++--------- 4 files changed, 462 insertions(+), 329 deletions(-) diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs index 8a8aa0f4a2..fbe126627a 100644 --- a/src/Ampersand/Core/AbstractSyntaxTree.hs +++ b/src/Ampersand/Core/AbstractSyntaxTree.hs @@ -138,7 +138,8 @@ instance Eq Pattern where p==p' = ptnm p==ptnm p' instance Unique Pattern where showUnique = optionalQuote . name - +instance Ord Pattern where + a `compare` b = name a `compare` name b instance Named Pattern where name = ptnm instance Traced Pattern where @@ -266,7 +267,8 @@ instance Traced IdentityDef where origin = idPos instance Unique IdentityDef where showUnique = idLbl - +instance Ord IdentityDef where + compare a b = name a `compare` name b data IdentitySegment = IdentityExp ObjectDef deriving (Eq, Show) -- TODO: refactor to a list of terms data ViewDef = Vd { vdpos :: Origin -- ^ position of this definition in the text of the Ampersand source file (filename, line number and column number). @@ -284,7 +286,9 @@ instance Traced ViewDef where instance Unique ViewDef where showUnique vd = vdlbl vd++"_"++name (vdcpt vd) instance Eq ViewDef where - a == b = vdlbl a == vdlbl b && vdcpt a == vdcpt b + a == b = vdlbl a == vdlbl b && vdcpt a == vdcpt b +instance Ord ViewDef where + a `compare` b = (vdlbl a,vdcpt a) `compare` (vdlbl b, vdcpt b) data ViewSegment = ViewSegment { vsmpos :: Origin , vsmlabel :: Maybe String @@ -310,7 +314,7 @@ data AClassify = Isa { genpos :: Origin | IsE { genpos :: Origin , genspc :: A_Concept -- ^ specific concept , genrhs :: [A_Concept] -- ^ concepts of which the conjunction is equivalent to the specific concept - } deriving (Typeable, Eq) + } deriving (Typeable, Eq,Ord) instance Traced AClassify where origin = genpos instance Unique AClassify where @@ -343,6 +347,8 @@ data Interface = Ifc { ifcIsAPI :: Bool -- is this interface of type instance Eq Interface where s==s' = name s==name s' +instance Ord Interface where + compare a b = compare (name a) (name b) instance Named Interface where name = ifcname instance Traced Interface where @@ -401,6 +407,8 @@ instance Traced ObjectDef where origin = objpos instance Unique ObjectDef where showUnique = showUnique . origin +instance Ord ObjectDef where + a `compare` b = name a `compare` name b instance Named BoxTxt where name = objnm instance Traced BoxTxt where @@ -436,6 +444,8 @@ instance Eq Purpose where x0 == x1 = explObj x0 == explObj x1 && origin x0 == origin x1 && (amLang . explMarkup) x0 == (amLang . explMarkup) x1 +instance Ord Purpose where + compare a b = compare (explObj a, origin a) (explObj b, origin b) instance Unique Purpose where showUnique p = showUnique (explMarkup p) ++ uniqueShow True (explPos p) @@ -541,7 +551,7 @@ data ExplObj = ExplConceptDef ConceptDef | ExplPattern String | ExplInterface String | ExplContext String - deriving (Show ,Eq, Typeable) + deriving (Show ,Eq, Typeable, Ord) instance Unique ExplObj where showUnique e = "Explanation of "++ case e of diff --git a/src/Ampersand/FSpec/ShowMeatGrinder.hs b/src/Ampersand/FSpec/ShowMeatGrinder.hs index 4ae0df32cf..541810bae9 100644 --- a/src/Ampersand/FSpec/ShowMeatGrinder.hs +++ b/src/Ampersand/FSpec/ShowMeatGrinder.hs @@ -35,24 +35,24 @@ grind formalAmpersand userFspec = , ctx_markup = Nothing , ctx_pats = [] , ctx_rs = [] - , ctx_ds = mapMaybe (extractFromPop formalAmpersand) metaPops2 + , ctx_ds = mapMaybe (extractFromPop formalAmpersand) . Set.toList $ metaPops2 , ctx_cs = [] , ctx_ks = [] , ctx_rrules = [] , ctx_rrels = [] , ctx_reprs = [] , ctx_vs = [] - , ctx_gs = map aClassify2pClassify (instances formalAmpersand) + , ctx_gs = map aClassify2pClassify . Set.toList . instances $ formalAmpersand , ctx_ifcs = [] , ctx_ps = [] , ctx_pops = [] , ctx_metas = [] } where - metaPops2 :: [Pop] - metaPops2 = concatMap (grindedPops formalAmpersand userFspec) - . instances $ formalAmpersand - + metaPops2 :: Set.Set Pop + metaPops2 = Set.fromList + . concatMap (Set.toList . grindedPops formalAmpersand userFspec) + . Set.toList . instances $ formalAmpersand extractFromPop :: MetaFSpec -> Pop -> Maybe P_Relation extractFromPop formalAmpersand pop = @@ -95,7 +95,7 @@ extractFromPop formalAmpersand pop = string2AValue :: String -> Guarded [PAtomPair] string2AValue = runParser pContent "Somewhere in formalAmpersand files" -data Pop = Pop { popPairs :: [(PopAtom,PopAtom)] +data Pop = Pop { popPairs :: Set.Set (PopAtom,PopAtom) , popRelation :: Relation } | Comment { comment :: [String] -- Not-so-nice way to get comments in a list of populations. Since it is local to this module, it is not so bad, I guess... @@ -104,7 +104,7 @@ data Pop = Pop { popPairs :: [(PopAtom,PopAtom)] showPop :: Pop -> String showPop pop = case pop of - Pop{} -> showP ((aRelation2pRelation (popRelation pop)) {dec_popu = map foo . sortShow $ popPairs pop} ) + Pop{} -> showP ((aRelation2pRelation (popRelation pop)) {dec_popu = map foo . sortShow . Set.toList $ popPairs pop} ) Comment{} -> intercalate "\n" . map ("-- " ++) . comment $ pop where sortShow :: [(PopAtom,PopAtom)] -> [(PopAtom,PopAtom)] sortShow = sortOn x @@ -158,36 +158,40 @@ makeMetaFile formalAmpersand userFspec intercalate [""] . sort . map (lines . showPop ) - . concatMap popsOfRelation + . concatMap (Set.toList . popsOfRelation) . sortOn showRel - . instances $ formalAmpersand + . Set.toList . instances $ formalAmpersand listOfConcepts :: [String] listOfConcepts = map ("-- "++) . intercalate [""] . - map showCpt $ cpts + map showCpt . sortOn name . Set.toList . instances $ formalAmpersand where showCpt :: A_Concept -> [String] showCpt cpt = [name cpt] ++ ( map (" "++) . sort . map show + . Set.toList $ pAtomsOfConcept cpt ) - cpts::[A_Concept] = sortOn name . instances $ formalAmpersand - popsOfRelation :: Relation -> [Pop] - popsOfRelation = sort . grindedPops formalAmpersand userFspec - pAtomsOfConcept :: A_Concept -> [PopAtom] - pAtomsOfConcept cpt = - nub $ - (nub . map fst . concatMap popPairs . concatMap popsOfRelation . filter isForSource . instances $ formalAmpersand) - ++ - (nub . map snd . concatMap popPairs . concatMap popsOfRelation . filter isForTarget . instances $ formalAmpersand) - where isForSource :: Relation -> Bool - isForSource rel = source rel == cpt - isForTarget :: Relation -> Bool - isForTarget rel = target rel == cpt + popsOfRelation :: Relation -> Set.Set Pop + popsOfRelation = grindedPops formalAmpersand userFspec + pAtomsOfConcept :: A_Concept -> Set.Set PopAtom + pAtomsOfConcept cpt = getPopsSet Src `Set.union` getPopsSet Tgt + where getPopsSet :: SrcOrTgt -> Set.Set PopAtom + getPopsSet x = Set.fromList . map (case x of + Src -> fst + Tgt -> snd + ) + . Set.toList . Set.unions. map popPairs + . Set.toList . Set.unions . map popsOfRelation + . Set.toList . Set.filter (\rel-> case x of + Src -> source rel == cpt + Tgt -> target rel == cpt + ) + . instances $ formalAmpersand -grindedPops :: FSpec -> FSpec -> Relation -> [Pop] +grindedPops :: FSpec -> FSpec -> Relation -> Set.Set Pop grindedPops formalAmpersand userFspec rel = case filter (isForRel rel) (transformers userFspec) of [] -> fatal . unlines $ @@ -196,17 +200,18 @@ grindedPops formalAmpersand userFspec rel = ] ++ map (" "++) viols where viols = map showRelOrigin - . filter hasNoTransformer + . Set.toList + . Set.filter hasNoTransformer . instances $ formalAmpersand hasNoTransformer :: Relation -> Bool hasNoTransformer d = null (filter (isForRel d) (transformers userFspec)) showRelOrigin :: Relation -> String showRelOrigin r = showRel r++" ( "++show (origin r)++" )." - ts -> map transformer2Pop $ ts + ts -> Set.fromList . map transformer2Pop $ ts where transformer2Pop :: Transformer -> Pop transformer2Pop (Transformer n s t ps) - | not ( all (ttypeOf (source rel)) (map fst ps) ) = + | not ( all (ttypeOf (source rel)) (map fst . Set.toList $ ps) ) = fatal . unlines $ [ "The TType of the population produced by the meatgrinder must" , " match the TType of the concept as specified in formalampersand.adl." @@ -214,7 +219,7 @@ grindedPops formalAmpersand userFspec rel = , " violates this rule for concept `"++s++"`. In formalAmpersand.adl " , " the TType of this concept is "++(show . cptTType formalAmpersand $ source rel)++"." ] - | not ( all (ttypeOf (target rel)) (map snd ps) ) = + | not ( all (ttypeOf (target rel)) (map snd . Set.toList $ ps) ) = fatal . unlines $ [ "The TType of the population produced by the meatgrinder must" , " match the TType of the concept as specified in formalampersand.adl." diff --git a/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs b/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs index dd34ddc7e9..d177d132db 100644 --- a/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs +++ b/src/Ampersand/FSpec/ToFSpec/CreateFspec.hs @@ -16,6 +16,7 @@ import Ampersand.Misc import Control.Monad import Data.List import qualified Data.List.NonEmpty as NEL (toList) +import qualified Data.Set as Set import System.FilePath -- | create an FSpec, based on the provided command-line options. @@ -66,10 +67,10 @@ createMulti opts = -- in an implicit way. We want other things, like Idents, Views and REPRESENTs available too. addSemanticModel :: P_Context -> P_Context addSemanticModel pCtx - = pCtx {ctx_ds = ctx_ds pCtx ++ map (noPopulation . aRelation2pRelation) (instances fAmpFSpec) - ,ctx_gs = ctx_gs pCtx ++ map aClassify2pClassify (instances fAmpFSpec) - ,ctx_vs = ctx_vs pCtx ++ map aViewDef2pViewDef (instances fAmpFSpec) - ,ctx_ks = ctx_ks pCtx ++ map aIdentityDef2pIdentityDef (instances fAmpFSpec) + = pCtx {ctx_ds = ctx_ds pCtx ++ map (noPopulation . aRelation2pRelation) (Set.toList . instances $ fAmpFSpec) + ,ctx_gs = ctx_gs pCtx ++ map aClassify2pClassify (Set.toList . instances $ fAmpFSpec) + ,ctx_vs = ctx_vs pCtx ++ map aViewDef2pViewDef (Set.toList . instances $ fAmpFSpec) + ,ctx_ks = ctx_ks pCtx ++ map aIdentityDef2pIdentityDef (Set.toList . instances $ fAmpFSpec) ,ctx_reprs = ctx_reprs pCtx ++ (reprList . fcontextInfo $ fAmpFSpec) } noPopulation :: P_Relation -> P_Relation diff --git a/src/Ampersand/FSpec/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs index efae38db35..f3670c8058 100644 --- a/src/Ampersand/FSpec/Transformers.hs +++ b/src/Ampersand/FSpec/Transformers.hs @@ -16,7 +16,6 @@ import Ampersand.FSpec.FSpec import Ampersand.FSpec.Motivations import Ampersand.Misc import Data.Hashable -import Data.List import qualified Data.Set as Set import Data.Typeable @@ -28,7 +27,7 @@ data Transformer = Transformer { tRel :: String -- name of relation , tSrc :: String -- name of source , tTrg :: String -- name of target - , tPairs :: [(PopAtom,PopAtom)] -- the population of this relation from the user's script. + , tPairs :: Set.Set (PopAtom,PopAtom)-- the population of this relation from the user's script. } -- | This datatype reflects the nature of an atom. It is use to construct @@ -47,687 +46,778 @@ instance Show PopAtom where PopInt i -> show i -toTransformer :: (String, String, String, [(PopAtom,PopAtom)]) -> Transformer -toTransformer (rel, sCpt, tCpt, fun) = Transformer rel sCpt tCpt fun +toTransformer :: (String, String, String, Set.Set (PopAtom,PopAtom) ) -> Transformer +toTransformer (rel, sCpt, tCpt, set) = Transformer rel sCpt tCpt set -- | The list of all transformers, one for each and every relation in Formal Ampersand. transformers :: FSpec -> [Transformer] transformers fSpec = map toTransformer [ ("allConjuncts" , "Context" , "Conjunct" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList $ [(dirtyId ctx, dirtyId conj ) - | ctx::A_Context <- instances fSpec - , conj::Conjunct <- instances fSpec + | ctx::A_Context <- instanceList fSpec + , conj::Conjunct <- instanceList fSpec ] ) ,("allRoles" , "Context" , "Role" - , [(dirtyId ctx, dirtyId rol ) - | ctx::A_Context <- instances fSpec - , rol::Role <- instances fSpec + , Set.fromList $ + [(dirtyId ctx, dirtyId rol ) + | ctx::A_Context <- instanceList fSpec + , rol::Role <- instanceList fSpec ] ) ,("allRules" , "Context" , "Rule" - , [(dirtyId ctx, dirtyId rul) - | ctx::A_Context <- instances fSpec + , Set.fromList $ + [(dirtyId ctx, dirtyId rul) + | ctx::A_Context <- instanceList fSpec , rul::Rule <- Set.elems $ allRules ctx ] ) ,("allRules" , "Pattern" , "Rule" - , [(dirtyId pat, dirtyId rul) - | pat::Pattern <- instances fSpec + , Set.fromList $ + [(dirtyId pat, dirtyId rul) + | pat::Pattern <- instanceList fSpec , rul::Rule <- Set.elems $ allRules pat ] ) ,("arg" , "UnaryTerm" , "Expression" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList $ [(dirtyId expr, dirtyId x) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec , Just x <- [arg expr] ] ) ,("asMarkdown" , "Markup" , "Text" - , [] --TODO + , Set.empty --TODO ) ,("attIn" , "Attribute" , "ObjectDef" - , [] --TODO + , Set.empty --TODO ) ,("attObj" , "Attribute" , "ObjectDef" - , [] --TODO + , Set.empty --TODO ) ,("bind" , "BindedRelation" , "Relation" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList $ [(dirtyId expr, dirtyId x) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec , Just x <- [bindedRel expr] ] ) ,("changes" , "Act" , "Relation" - , [] --TODO + , Set.empty --TODO ) ,("concepts" , "Pattern" , "Concept" - , [(dirtyId pat, dirtyId cpt) - | pat::Pattern <- instances fSpec + , Set.fromList $ + [(dirtyId pat, dirtyId cpt) + | pat::Pattern <- instanceList fSpec , cpt <- Set.elems $ concs pat ] ) ,("conjunct" , "Conjunct" , "Expression" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList $ [(dirtyId conj, dirtyId (rc_conjunct conj)) - | conj::Conjunct <- instances fSpec + | conj::Conjunct <- instanceList fSpec ] ) ,("context" , "Concept" , "Context" - , [(dirtyId cpt, dirtyId ctx) - | ctx::A_Context <- instances fSpec - , cpt::A_Concept <- instances fSpec + , Set.fromList $ + [(dirtyId cpt, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec + , cpt::A_Concept <- instanceList fSpec ] ) ,("context" , "IdentityDef" , "Context" - , [(dirtyId idf, dirtyId ctx) - | ctx::A_Context <- instances fSpec - , idf::IdentityDef <- instances fSpec + , Set.fromList $ + [(dirtyId idf, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec + , idf::IdentityDef <- instanceList fSpec ] ) ,("context" , "Pattern" , "Context" - , [(dirtyId pat, dirtyId ctx) - | ctx::A_Context <- instances fSpec - , pat::Pattern <- instances fSpec + , Set.fromList $ + [(dirtyId pat, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec + , pat::Pattern <- instanceList fSpec ] ) ,("context" , "Population" , "Context" - , [(dirtyId pop, dirtyId ctx) - | ctx::A_Context <- instances fSpec - , pop::Population <- instances fSpec + , Set.fromList $ + [(dirtyId pop, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec + , pop::Population <- instanceList fSpec ] ) ,("context" , "Relation" , "Context" - , [(dirtyId rel, dirtyId ctx) - | ctx::A_Context <- instances fSpec - , rel::Relation <- instances fSpec + , Set.fromList $ + [(dirtyId rel, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec + , rel::Relation <- instanceList fSpec ] ) ,("ctxds" , "Relation" , "Context" - , [(dirtyId rel, dirtyId ctx) - | ctx::A_Context <- instances fSpec + , Set.fromList $ + [(dirtyId rel, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec , rel::Relation <- Set.elems $ ctxds ctx ] ) ,("ctxrs" , "Rule" , "Context" - , [(dirtyId rul, dirtyId ctx) - | ctx::A_Context <- instances fSpec - , rul::Rule <- instances fSpec + , Set.fromList $ + [(dirtyId rul, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec + , rul::Rule <- instanceList fSpec ] ) ,("dbName" , "Context" , "DatabaseName" - , [] --TODO + , Set.empty --TODO ) ,("declaredIn" , "Relation" , "Context" - , [(dirtyId rel, dirtyId ctx) - | ctx::A_Context <- instances fSpec + , Set.fromList $ + [(dirtyId rel, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec , rel::Relation <- Set.elems $ relsDefdIn ctx ] ) ,("declaredIn" , "Relation" , "Pattern" - , [(dirtyId rel, dirtyId pat) - | pat::Pattern <- instances fSpec + , Set.fromList $ + [(dirtyId rel, dirtyId pat) + | pat::Pattern <- instanceList fSpec , rel::Relation <- Set.elems $ relsDefdIn pat ] ) ,("declaredthrough" , "PropertyRule" , "Property" - , [(dirtyId rul, PopAlphaNumeric . show $ prop) - | rul::Rule <- instances fSpec + , Set.fromList $ + [(dirtyId rul, PopAlphaNumeric . show $ prop) + | rul::Rule <- instanceList fSpec , Just(prop,_) <- [rrdcl rul] ] ) ,("decMean" , "Relation" , "Meaning" - , [] --TODO + , Set.empty --TODO ) ,("decprL" , "Relation" , "String" - , [(dirtyId rel, (PopAlphaNumeric . decprL) rel) - | rel::Relation <- instances fSpec + , Set.fromList $ + [(dirtyId rel, (PopAlphaNumeric . decprL) rel) + | rel::Relation <- instanceList fSpec ] ) ,("decprM" , "Relation" , "String" - , [(dirtyId rel, (PopAlphaNumeric . decprM) rel) - | rel::Relation <- instances fSpec + , Set.fromList $ + [(dirtyId rel, (PopAlphaNumeric . decprM) rel) + | rel::Relation <- instanceList fSpec ] ) ,("decprR" , "Relation" , "String" - , [(dirtyId rel, (PopAlphaNumeric . decprR) rel) - | rel::Relation <- instances fSpec + , Set.fromList $ + [(dirtyId rel, (PopAlphaNumeric . decprR) rel) + | rel::Relation <- instanceList fSpec ] ) ,("default" , "View" , "Concept" - , [] --TODO + , Set.empty --TODO ) ,("delta" , "Act" , "Pair" - , [] --TODO + , Set.empty --TODO ) ,("expSQL" , "PairViewSegment" , "MySQLQuery" - , [] --TODO + , Set.empty --TODO ) ,("expTgt" , "PairViewSegment" , "Concept" - , [] --TODO + , Set.empty --TODO ) ,("first" , "BinaryTerm" , "Expression" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList $ [(dirtyId expr, dirtyId x) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec , Just x <- [first expr] ] ) ,("formalExpression" , "Rule" , "Expression" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList $ [(dirtyId rul, dirtyId (formalExpression rul)) - | rul::Rule <- instances fSpec + | rul::Rule <- instanceList fSpec ] ) ,("gengen" , "IsE" , "Concept" - , [ ( dirtyId ise, dirtyId cpt) - | ise@IsE{} <- instances fSpec + , Set.fromList $ + [ ( dirtyId ise, dirtyId cpt) + | ise@IsE{} <- instanceList fSpec , cpt <- genrhs ise] ) ,("gengen" , "Isa" , "Concept" - , [ ( dirtyId isa, dirtyId (gengen isa)) - | isa@Isa{} <- instances fSpec + , Set.fromList $ + [ ( dirtyId isa, dirtyId (gengen isa)) + | isa@Isa{} <- instanceList fSpec ] ) ,("gens" , "Context" , "IsE" - , [ ( dirtyId ctx, dirtyId ise) - | ctx::A_Context <- instances fSpec - , ise@IsE{} <- instances fSpec + , Set.fromList $ + [ ( dirtyId ctx, dirtyId ise) + | ctx::A_Context <- instanceList fSpec + , ise@IsE{} <- instanceList fSpec ] ) ,("gens" , "Context" , "Isa" - , [(dirtyId ctx, dirtyId isa) - | ctx::A_Context <- instances fSpec - , isa@Isa{} <- instances fSpec + , Set.fromList $ + [(dirtyId ctx, dirtyId isa) + | ctx::A_Context <- instanceList fSpec + , isa@Isa{} <- instanceList fSpec ] ) ,("genspc" , "IsE" , "Concept" - , [ ( dirtyId ise, dirtyId (genspc ise)) - | ise@IsE{} <- instances fSpec + , Set.fromList $ + [ ( dirtyId ise, dirtyId (genspc ise)) + | ise@IsE{} <- instanceList fSpec ] ) ,("genspc" , "Isa" , "Concept" - , [ ( dirtyId isa, dirtyId (genspc isa)) - | isa@Isa{} <- instances fSpec + , Set.fromList $ + [ ( dirtyId isa, dirtyId (genspc isa)) + | isa@Isa{} <- instanceList fSpec ] ) ,("getExpressionRelation" , "Expression" , "Relation" - , [] --TODO + , Set.empty --TODO ) ,("hasView" , "Concept" , "Concept" - , [] --TODO + , Set.empty --TODO ) ,("identityRules" , "Rule" , "Context" - , [(dirtyId rul, dirtyId ctx) - | ctx::A_Context <- instances fSpec + , Set.fromList $ + [(dirtyId rul, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec , rul <- Set.elems $ identityRules ctx ] ) ,("identityRules" , "Rule" , "Pattern" - , [(dirtyId rul, dirtyId pat) - | pat::Pattern <- instances fSpec + , Set.fromList $ + [(dirtyId rul, dirtyId pat) + | pat::Pattern <- instanceList fSpec , rul <- Set.elems $ identityRules pat ] ) ,("ifcClass" , "Interface" , "String" - , [] --TODO + , Set.empty --TODO ) ,("ifcControls" , "Interface" , "Conjunct" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList $ [(dirtyId ifc, dirtyId conj) - | ifc::Interface <- instances fSpec + | ifc::Interface <- instanceList fSpec , conj <- ifcControls ifc ] ) ,("ifcInputs" , "Interface" , "Relation" - , [] --TODO + , Set.empty --TODO ) ,("ifcObj" , "Interface" , "ObjectDef" - , [(dirtyId ifc, dirtyId (ifcObj ifc)) - | ifc::Interface <- instances fSpec + , Set.fromList $ + [(dirtyId ifc, dirtyId (ifcObj ifc)) + | ifc::Interface <- instanceList fSpec ] ) ,("ifcOutputs" , "Interface" , "Relation" - , [] --TODO + , Set.empty --TODO ) ,("ifcPos" , "Interface" , "Origin" - , [(dirtyId ifc, PopAlphaNumeric . show . ifcPos $ ifc) - | ifc::Interface <- instances fSpec + , Set.fromList $ + [(dirtyId ifc, PopAlphaNumeric . show . ifcPos $ ifc) + | ifc::Interface <- instanceList fSpec ] ) ,("ifcPrp" , "Interface" , "String" - , [] --TODO + , Set.empty --TODO ) ,("ifcQuads" , "Interface" , "Quad" - , [] --TODO + , Set.empty --TODO ) ,("ifcRoles" , "Interface" , "Role" - , [] --TODO + , Set.empty --TODO ) ,("in" , "Pair" , "Expression" - , [] --TODO + , Set.empty --TODO ) ,("inQ" , "Quad" , "Act" - , [] --TODO + , Set.empty --TODO ) ,("inst" , "Object" , "ObjectDef" - , [] --TODO + , Set.empty --TODO ) ,("inst" , "Transaction" , "Interface" - , [] --TODO + , Set.empty --TODO ) ,("interfaces" , "Context" , "Interface" - , [(dirtyId ctx,dirtyId ifc) - | ctx::A_Context <- instances fSpec - , ifc::Interface <- instances fSpec + , Set.fromList $ + [(dirtyId ctx,dirtyId ifc) + | ctx::A_Context <- instanceList fSpec + , ifc::Interface <- instanceList fSpec ] ) ,("interfaces" , "Role" , "Interface" - , [(dirtyId rol,dirtyId ifc) - | ifc <- instances fSpec + , Set.fromList $ + [(dirtyId rol,dirtyId ifc) + | ifc <- instanceList fSpec , rol <- ifcRoles ifc ] ) ,("isa" , "Concept" , "Concept" - , [ ( dirtyId gCpt, dirtyId (genspc ise)) - | ise@IsE{} <- instances fSpec + , Set.fromList + [ ( dirtyId gCpt, dirtyId (genspc ise)) + | ise@IsE{} <- instanceList fSpec , gCpt <- genrhs ise - ]++ + ] `Set.union` + Set.fromList [ ( dirtyId (genspc isa), dirtyId (genspc isa)) - | isa@Isa{} <- instances fSpec + | isa@Isa{} <- instanceList fSpec ] ) ,("isaCopy" , "Concept" , "Concept" - , [] --TODO + , Set.empty --TODO ) ,("isaPlus" , "Concept" , "Concept" - , [] --TODO + , Set.empty --TODO ) ,("isaRfx" , "Concept" , "Concept" - , [] --TODO + , Set.empty --TODO ) ,("isaRfxCopy" , "Concept" , "Concept" - , [] --TODO + , Set.empty --TODO ) ,("isaRfxPlus" , "Concept" , "Concept" - , [] --TODO + , Set.empty --TODO ) ,("isaRfxStar" , "Concept" , "Concept" - , [] --TODO + , Set.empty --TODO ) ,("isaStar" , "Concept" , "Concept" - , [] --TODO + , Set.empty --TODO ) ,("language" , "Context" , "Language" - , [(dirtyId ctx,(PopAlphaNumeric . show . ctxlang) ctx) - | ctx::A_Context <- instances fSpec + , Set.fromList + [(dirtyId ctx,(PopAlphaNumeric . show . ctxlang) ctx) + | ctx::A_Context <- instanceList fSpec ] ) ,("language" , "Markup" , "Language" - , [(dirtyId mrk,(PopAlphaNumeric . show . amLang) mrk) - | mrk::Markup <- instances fSpec + , Set.fromList + [(dirtyId mrk,(PopAlphaNumeric . show . amLang) mrk) + | mrk::Markup <- instanceList fSpec ] ) ,("left" , "Pair" , "Atom" - , [] --TODO + , Set.empty --TODO ) ,("maintains" , "Role" , "Rule" - , [(dirtyId rol, dirtyId rul) + , Set.fromList + [(dirtyId rol, dirtyId rul) | (rol,rul) <- fRoleRuls fSpec ] ) ,("markup" , "Meaning" , "Markup" - , [(dirtyId mean, dirtyId . ameaMrk $ mean) - | mean::Meaning <- instances fSpec + , Set.fromList + [(dirtyId mean, dirtyId . ameaMrk $ mean) + | mean::Meaning <- instanceList fSpec ] ) ,("markup" , "Purpose" , "Markup" - , [(dirtyId purp, dirtyId . explMarkup $ purp) - | purp::Purpose <- instances fSpec + , Set.fromList + [(dirtyId purp, dirtyId . explMarkup $ purp) + | purp::Purpose <- instanceList fSpec ] ) ,("meaning" , "Rule" , "Meaning" - , [] --TODO + , Set.empty --TODO ) ,("message" , "Rule" , "Message" - , [] --TODO + , Set.empty --TODO ) ,("multrules" , "Rule" , "Context" - , [(dirtyId rul, dirtyId ctx) - | ctx::A_Context <- instances fSpec + , Set.fromList + [(dirtyId rul, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec , rul <- Set.elems $ multrules ctx ] ) ,("multrules" , "Rule" , "Pattern" - , [(dirtyId rul, dirtyId pat) - | pat::Pattern <- instances fSpec + , Set.fromList + [(dirtyId rul, dirtyId pat) + | pat::Pattern <- instanceList fSpec , rul <- Set.elems $ multrules pat ] ) ,("name" , "Concept" , "ConceptName" - , [(dirtyId cpt,(PopAlphaNumeric . name) cpt) - | cpt::A_Concept <- instances fSpec + , Set.fromList + [(dirtyId cpt,(PopAlphaNumeric . name) cpt) + | cpt::A_Concept <- instanceList fSpec ] ) ,("name" , "Context" , "ContextName" - , [(dirtyId ctx,(PopAlphaNumeric . name) ctx) - | ctx::A_Context <- instances fSpec + , Set.fromList + [(dirtyId ctx,(PopAlphaNumeric . name) ctx) + | ctx::A_Context <- instanceList fSpec ] ) ,("name" , "Interface" , "InterfaceName" - , [(dirtyId ifc,(PopAlphaNumeric . name) ifc) - | ifc::Interface <- instances fSpec + , Set.fromList + [(dirtyId ifc,(PopAlphaNumeric . name) ifc) + | ifc::Interface <- instanceList fSpec ] ) ,("name" , "ObjectDef" , "ObjectName" - , [(dirtyId obj, (PopAlphaNumeric . name) obj) - | obj::ObjectDef <- instances fSpec + , Set.fromList + [(dirtyId obj, (PopAlphaNumeric . name) obj) + | obj::ObjectDef <- instanceList fSpec ] ) ,("name" , "Pattern" , "PatternName" - , [(dirtyId pat,(PopAlphaNumeric . name) pat) - | pat::Pattern <- instances fSpec + , Set.fromList + [(dirtyId pat,(PopAlphaNumeric . name) pat) + | pat::Pattern <- instanceList fSpec ] ) ,("name" , "Relation" , "RelationName" - , [(dirtyId rel,(PopAlphaNumeric . name) rel) - | rel::Relation <- instances fSpec + , Set.fromList + [(dirtyId rel,(PopAlphaNumeric . name) rel) + | rel::Relation <- instanceList fSpec ] ) ,("name" , "Role" , "RoleName" - , [(dirtyId rol,(PopAlphaNumeric . name) rol) - | rol::Role <- instances fSpec + , Set.fromList + [(dirtyId rol,(PopAlphaNumeric . name) rol) + | rol::Role <- instanceList fSpec ] ) ,("name" , "Rule" , "RuleName" - , [(dirtyId rul,(PopAlphaNumeric . name) rul) - | rul::Rule <- instances fSpec + , Set.fromList + [(dirtyId rul,(PopAlphaNumeric . name) rul) + | rul::Rule <- instanceList fSpec ] ) ,("objExpression" , "ObjectDef" , "Expression" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId obj, dirtyId (objExpression obj)) - | obj::ObjectDef <- instances fSpec + | obj::ObjectDef <- instanceList fSpec ] ) ,("objmView" , "ObjectDef" , "View" - , [] --TODO + , Set.empty --TODO ) ,("objpos" , "ObjectDef" , "Origin" - , [(dirtyId obj, PopAlphaNumeric . show . origin $ obj) - | obj::ObjectDef <- instances fSpec + , Set.fromList + [(dirtyId obj, PopAlphaNumeric . show . origin $ obj) + | obj::ObjectDef <- instanceList fSpec ] ) ,("operator" , "BinaryTerm" , "Operator" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId expr, PopAlphaNumeric . show $ op) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec , Just op <- [binOp expr] ] ) ,("operator" , "UnaryTerm" , "Operator" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId expr, PopAlphaNumeric . show $ op) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec , Just op <- [unaryOp expr] ] ) ,("origin" , "Rule" , "Origin" - , [(dirtyId rul, (PopAlphaNumeric . show . origin) rul) - | rul::Rule <- instances fSpec + , Set.fromList + [(dirtyId rul, (PopAlphaNumeric . show . origin) rul) + | rul::Rule <- instanceList fSpec ] ) ,("originatesFrom" , "Conjunct" , "Rule" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId conj, dirtyId rul) - | conj::Conjunct <- instances fSpec + | conj::Conjunct <- instanceList fSpec , rul <- Set.elems $ rc_orgRules conj ] ) ,("outQ" , "Quad" , "Act" - , [] --TODO + , Set.empty --TODO ) ,("pairView" , "Rule" , "PairView" - , [] --TODO + , Set.empty --TODO ) ,("prop" , "Relation" , "Property" - , [(dirtyId rel, PopAlphaNumeric . show $ prop) - | rel::Relation <- instances fSpec + , Set.fromList + [(dirtyId rel, PopAlphaNumeric . show $ prop) + | rel::Relation <- instanceList fSpec , prop <- Set.elems $ decprps rel ] ) ,("propertyRule" , "Relation" , "PropertyRule" - , [(dirtyId rel, dirtyId rul) - | rul::Rule <- instances fSpec + , Set.fromList + [(dirtyId rel, dirtyId rul) + | rul::Rule <- instanceList fSpec , Just(_,rel) <- [rrdcl rul] ] ) ,("purpose" , "Concept" , "Purpose" - , [(dirtyId cpt, dirtyId purp) - | cpt::A_Concept <- instances fSpec + , Set.fromList + [(dirtyId cpt, dirtyId purp) + | cpt::A_Concept <- instanceList fSpec , purp <- purposes fSpec cpt ] ) ,("purpose" , "Context" , "Purpose" - , [(dirtyId ctx, dirtyId purp) - | ctx::A_Context <- instances fSpec + , Set.fromList + [(dirtyId ctx, dirtyId purp) + | ctx::A_Context <- instanceList fSpec , purp <- purposes fSpec ctx ] ) ,("purpose" , "Identity" , "Purpose" - , [(dirtyId idn, dirtyId purp) - | idn::IdentityDef <- instances fSpec + , Set.fromList + [(dirtyId idn, dirtyId purp) + | idn::IdentityDef <- instanceList fSpec , purp <- purposes fSpec idn ] ) ,("purpose" , "Interface" , "Purpose" - , [(dirtyId ifc, dirtyId purp) - | ifc::Interface <- instances fSpec + , Set.fromList + [(dirtyId ifc, dirtyId purp) + | ifc::Interface <- instanceList fSpec , purp <- purposes fSpec ifc ] ) ,("purpose" , "Pattern" , "Purpose" - , [(dirtyId pat, dirtyId purp) - | pat::Pattern <- instances fSpec + , Set.fromList + [(dirtyId pat, dirtyId purp) + | pat::Pattern <- instanceList fSpec , purp <- purposes fSpec pat ] ) ,("purpose" , "Relation" , "Purpose" - , [(dirtyId rel, dirtyId purp) - | rel::Relation <- instances fSpec + , Set.fromList + [(dirtyId rel, dirtyId purp) + | rel::Relation <- instanceList fSpec , purp <- purposes fSpec rel ] ) ,("purpose" , "Rule" , "Purpose" - , [(dirtyId rul, dirtyId purp) - | rul::Rule <- instances fSpec + , Set.fromList + [(dirtyId rul, dirtyId purp) + | rul::Rule <- instanceList fSpec , purp <- purposes fSpec rul ] ) ,("purpose" , "View" , "Purpose" - , [(dirtyId vw, dirtyId purp) - | vw::ViewDef <- instances fSpec + , Set.fromList + [(dirtyId vw, dirtyId purp) + | vw::ViewDef <- instanceList fSpec , purp <- purposes fSpec vw ] ) ,("relsDefdIn" , "Pattern" , "Relation" - , [(dirtyId pat, dirtyId rel) - | pat::Pattern <- instances fSpec - , rel <- Set.elems $ ptdcs pat + , Set.fromList + [(dirtyId pat, dirtyId rel) + | pat::Pattern <- instanceList fSpec + , rel <- Set.elems $ relsDefdIn pat ] ) ,("right" , "Pair" , "Atom" - , [] --TODO + , Set.empty --TODO ) ,("formalExpression" , "Rule" , "Expression" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId rul, dirtyId (formalExpression rul)) - | rul::Rule <- instances fSpec + | rul::Rule <- instanceList fSpec ] ) ,("second" , "BinaryTerm" , "Expression" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId expr, dirtyId x) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec , Just x <- [second expr] ] ) ,("segment" , "PairView" , "PairViewSegment" - , [] --TODO + , Set.empty --TODO ) ,("segmentType" , "PairViewSegment" , "PairViewSegmentType" - , [] --TODO + , Set.empty --TODO ) ,("sequenceNr" , "PairViewSegment" , "Int" - , [] --TODO + , Set.empty --TODO ) ,("sessAtom" , "SESSION" , "Atom" - , [] --TODO + , Set.empty --TODO ) ,("sessIfc" , "SESSION" , "Interface" - , [] --TODO + , Set.empty --TODO ) ,("sessionRole" , "SESSION" , "Role" - , [] --TODO + , Set.empty --TODO ) ,("showADL" , "Expression" , "ShowADL" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId expr, PopAlphaNumeric (showA expr)) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec ] ) ,("sign" , "Expression" , "Signature" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId expr, dirtyId (sign expr)) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec ] ) ,("sign" , "Relation" , "Signature" - , [(dirtyId rel, dirtyId (sign rel)) - | rel::Relation <- instances fSpec + , Set.fromList + [(dirtyId rel, dirtyId (sign rel)) + | rel::Relation <- instanceList fSpec ] ) ,("singleton" , "Singleton" , "AtomValue" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId expr, dirtyId x) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec , Just x <- [singleton expr] ] ) ,("source" , "Relation" , "Concept" - , [(dirtyId rel, dirtyId (source rel)) - | rel::Relation <- instances fSpec + , Set.fromList + [(dirtyId rel, dirtyId (source rel)) + | rel::Relation <- instanceList fSpec ] ) ,("src" , "Signature" , "Concept" - , [(dirtyId sgn, dirtyId (source sgn)) - | sgn::Signature <- instances fSpec + , Set.fromList + [(dirtyId sgn, dirtyId (source sgn)) + | sgn::Signature <- instanceList fSpec ] ) ,("srcOrTgt" , "PairViewSegment" , "SourceOrTarget" - , [] --TODO + , Set.empty --TODO ) ,("target" , "Relation" , "Concept" - , [(dirtyId rel, dirtyId (target rel)) - | rel::Relation <- instances fSpec + , Set.fromList + [(dirtyId rel, dirtyId (target rel)) + | rel::Relation <- instanceList fSpec ] ) ,("text" , "PairViewSegment" , "String" - , [] --TODO + , Set.empty --TODO ) ,("tgt" , "Signature" , "Concept" - , [(dirtyId sgn, dirtyId (target sgn)) - | sgn::Signature <- instances fSpec + , Set.fromList + [(dirtyId sgn, dirtyId (target sgn)) + | sgn::Signature <- instanceList fSpec ] ) ,("transactionObject" , "Transaction" , "Object" - , [] --TODO + , Set.empty --TODO ) ,("ttype" , "Concept" , "TType" - , [(dirtyId cpt, (PopAlphaNumeric . show . cptTType fSpec) cpt) - | cpt::A_Concept <- instances fSpec + , Set.fromList + [(dirtyId cpt, (PopAlphaNumeric . show . cptTType fSpec) cpt) + | cpt::A_Concept <- instanceList fSpec ] ) ,("udefrules" , "Rule" , "Context" - , [(dirtyId rul, dirtyId ctx) - | ctx::A_Context <- instances fSpec + , Set.fromList + [(dirtyId rul, dirtyId ctx) + | ctx::A_Context <- instanceList fSpec , rul <- Set.elems $ udefrules ctx ] ) ,("udefrules" , "Rule" , "Pattern" - , [(dirtyId rul, dirtyId pat) - | pat::Pattern <- instances fSpec + , Set.fromList + [(dirtyId rul, dirtyId pat) + | pat::Pattern <- instanceList fSpec , rul <- Set.elems $ udefrules pat ] ) ,("urlEncodedName" , "Concept" , "EncodedName" - , [(dirtyId cpt,(PopAlphaNumeric . escapeNonAlphaNum . name) cpt) - | cpt::A_Concept <- instances fSpec + , Set.fromList + [(dirtyId cpt,(PopAlphaNumeric . escapeNonAlphaNum . name) cpt) + | cpt::A_Concept <- instanceList fSpec ] ) ,("urlEncodedName" , "Pattern" , "EncodedName" - , [(dirtyId pat,(PopAlphaNumeric . escapeNonAlphaNum . name) pat) - | pat::Pattern <- instances fSpec + , Set.fromList + [(dirtyId pat,(PopAlphaNumeric . escapeNonAlphaNum . name) pat) + | pat::Pattern <- instanceList fSpec ] ) ,("urlEncodedName" , "Rule" , "EncodedName" - , [(dirtyId rul,(PopAlphaNumeric . escapeNonAlphaNum . name) rul) - | rul::Rule <- instances fSpec + , Set.fromList + [(dirtyId rul,(PopAlphaNumeric . escapeNonAlphaNum . name) rul) + | rul::Rule <- instanceList fSpec ] ) ,("usedIn" , "Relation" , "Expression" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId rel, dirtyId expr) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec , rel::Relation <- Set.elems $ bindedRelationsIn expr ] ) ,("userCpt" , "Epsilon" , "Concept" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId expr, dirtyId x) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec , Just (x::A_Concept) <- [userCpt expr] ] ) ,("userSrc" , "V" , "Concept" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId expr, dirtyId x) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec , Just x <- [userSrc expr] ] ) ,("userTrg" , "V" , "Concept" - , if atlasWithoutExpressions opts then [] else + , if atlasWithoutExpressions opts then Set.empty else + Set.fromList [(dirtyId expr, dirtyId x) - | expr::Expression <- instances fSpec + | expr::Expression <- instanceList fSpec , Just x <- [userTrg expr] ] ) ,("uses" , "Context" , "Pattern" - , [] --TODO + , Set.empty --TODO ) ,("valid" , "Concept" , "Context" - , [] --TODO + , Set.empty --TODO ) ,("valid" , "Relation" , "Context" - , [] --TODO + , Set.empty --TODO ) ,("valid" , "Rule" , "Context" - , [] --TODO + , Set.empty --TODO ) ,("versionInfo" , "Context" , "AmpersandVersion" - , [(dirtyId ctx,PopAlphaNumeric ampersandVersionStr) - | ctx::A_Context <- instances fSpec + , Set.fromList + [(dirtyId ctx,PopAlphaNumeric ampersandVersionStr) + | ctx::A_Context <- instanceList fSpec ] ) ,("viewBy" , "Concept" , "Concept" - , [] --TODO + , Set.empty --TODO ) ,("viol" , "Interface" , "Rule" - , [] --TODO + , Set.empty --TODO ) ] where @@ -737,56 +827,79 @@ transformers fSpec = map toTransformer [ -- Concept. They are the atoms of the concepts, as looked -- upon from the Formal Ampersand viewpoint. class Typeable a => Instances a where ---TODO: This should eventially be replaced by Set a - instances :: FSpec -> [a] + instances :: FSpec -> Set.Set a + instanceList :: FSpec -> [a] + instanceList = Set.toList . instances + {-# MINIMAL instances #-} +-- --WARNING: Beware of loops! +-- To prevent loops in the definition of instances, it is considered bad +-- to use the `instances` function while defining it. +-- For this reason, some helper functions are defined here: +expressionInstances :: FSpec -> Set.Set Expression +expressionInstances = allExprs +interfaceInstances :: FSpec -> Set.Set Interface +interfaceInstances = Set.fromList . ctxifcs . originalContext +meaningInstances :: FSpec -> Set.Set Meaning +meaningInstances fSpec = (Set.fromList . concat . fmap meanings . Set.toList . relationInstances $ fSpec) + `Set.union` + (Set.fromList . concat . fmap meanings . Set.toList . ruleInstances $ fSpec) +purposeInstances :: FSpec -> Set.Set Purpose +purposeInstances fSpec = Set.fromList . fSexpls $ fSpec +relationInstances :: FSpec -> Set.Set Relation +relationInstances = relsDefdIn . originalContext +ruleInstances :: FSpec -> Set.Set Rule +ruleInstances = allRules . originalContext instance Instances A_Context where - instances fSpec = [originalContext fSpec] + instances = Set.singleton . originalContext instance Instances AClassify where - instances fSpec = gens (originalContext fSpec) + instances = Set.fromList . gens . originalContext instance Instances A_Concept where - instances fSpec = Set.elems . concs . originalContext $ fSpec + instances = concs . originalContext instance Instances Conjunct where - instances fSpec = allConjuncts fSpec -instance Instances Relation where - instances fSpec = Set.elems $ relsDefdIn (originalContext fSpec) + instances = Set.fromList . allConjuncts instance Instances Expression where - instances fSpec = Set.elems $ allExprs fSpec + instances = expressionInstances instance Instances IdentityDef where - instances fSpec = ctxks (originalContext fSpec) + instances = Set.fromList . ctxks . originalContext instance Instances Interface where - instances fSpec = ctxifcs (originalContext fSpec) + instances = interfaceInstances +instance Instances Meaning where + instances fSpec = Set.fromList (concatMap meanings . ruleInstances $ fSpec) + `Set.union` + Set.fromList (concatMap meanings . relationInstances $ fSpec) +instance Instances Markup where + instances fSpec = (Set.fromList . map explMarkup . Set.toList . purposeInstances $ fSpec) + `Set.union` + (Set.fromList . map ameaMrk . Set.toList . meaningInstances $ fSpec) instance Instances ObjectDef where - instances fSpec = - nub - . concatMap (objects . ifcObj) - . instances $ fSpec + instances fSpec = Set.fromList . concatMap (objects . ifcObj) + . interfaceInstances $ fSpec where objects :: ObjectDef -> [ObjectDef] objects obj = obj : fields obj instance Instances Pattern where - instances fSpec = ctxpats (originalContext fSpec) + instances = Set.fromList . ctxpats . originalContext instance Instances Population where - instances fSpec = ctxpopus (originalContext fSpec) -instance Instances Meaning where - instances fSpec = concatMap meanings (allRules fSpec) ++ - concatMap decMean (vrels fSpec) + instances = Set.fromList . ctxpopus . originalContext instance Instances Purpose where - instances fSpec = fSexpls fSpec -instance Instances Markup where - instances fSpec = - map explMarkup (instances fSpec) ++ - map ameaMrk (instances fSpec) + instances = purposeInstances +instance Instances Relation where + instances = relationInstances instance Instances Role where - instances fSpec = nub $ [Role "SystemAdmin"] ++ map fst (fRoles fSpec) + instances = Set.insert (Role "SystemAdmin") + . Set.fromList . map fst . fRoles instance Instances Rule where - instances fSpec = Set.elems . allRules $ originalContext fSpec + instances = ruleInstances +instance Instances (Role,Rule) where + instances = Set.fromList . fRoleRuls instance Instances Signature where - instances fSpec = nub $ - [sign dcl | dcl::Relation <- instances fSpec] - ++ [sign expr | expr::Expression <- instances fSpec] + instances fSpec = + (Set.fromList . map sign . Set.toList . relationInstances $ fSpec) + `Set.union` + (Set.fromList . map sign . Set.toList . expressionInstances $ fSpec) instance Instances ViewDef where - instances fSpec = viewDefs (originalContext fSpec) + instances = Set.fromList . viewDefs . originalContext -- All Concepts that are relevant in Formal Ampersand (RAP), @@ -814,7 +927,7 @@ instance Unique a => HasDirtyId a where class Instances a => HasPurpose a where purposes :: FSpec -> a -> [Purpose] purposes fSpec a = - filter (isFor a) (instances fSpec) + Set.toList . Set.filter (isFor a) . instances $ fSpec isFor :: a -> Purpose -> Bool instance HasPurpose A_Concept where isFor cpt purp = @@ -870,26 +983,29 @@ data ExprInfo = ExprInfo , singleton' :: Maybe PAtomValue -- the value of a singleton expression } binOp :: Expression -> Maybe BinOp -binOp = binOp' . exprInfo +binOp = aap "binOp" $ binOp' unaryOp :: Expression -> Maybe UnaryOp -unaryOp = unaryOp' . exprInfo +unaryOp = aap "unaryOp" $ unaryOp' bindedRel :: Expression -> Maybe Relation -bindedRel = bindedRel' . exprInfo +bindedRel = aap "bindedRel" $ bindedRel' first :: Expression -> Maybe Expression -first = first' . exprInfo +first = aap "first" $ first' second :: Expression -> Maybe Expression -second = second' . exprInfo +second = aap "second" $ second' arg :: Expression -> Maybe Expression -arg = arg' . exprInfo +arg = aap "arg" $ arg' userCpt :: Expression -> Maybe A_Concept -userCpt = userCpt' . exprInfo +userCpt = aap "userCpt" $ userCpt' userSrc :: Expression -> Maybe A_Concept -userSrc = userSrc' . exprInfo +userSrc = aap "userSrc" $ userSrc' userTrg :: Expression -> Maybe A_Concept -userTrg = userTrg' . exprInfo +userTrg = aap "userTrg" $ userTrg' singleton :: Expression -> Maybe PAtomValue -singleton = singleton' . exprInfo +singleton = aap "singleton" $ singleton' +aap :: String -> (ExprInfo->a) -> (Expression->a) +aap _ f e = -- traceShow (str++" "++showA e) $ + (f . exprInfo) e exprInfo :: Expression -> ExprInfo exprInfo expr = case expr of @@ -1169,4 +1285,5 @@ instance Unique BinOp where showUnique = show instance Unique (Either BinOp UnaryOp) where showUnique (Left a) = showUnique a - showUnique (Right b) = showUnique b \ No newline at end of file + showUnique (Right b) = showUnique b + From 85224d419ccac22fd4b9270e80b5e5d37cd69ec3 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Tue, 15 Jan 2019 09:23:15 +0100 Subject: [PATCH 127/131] Found culprit of loop --- src/Ampersand/FSpec/Transformers.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Ampersand/FSpec/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs index f3670c8058..bbe051f72f 100644 --- a/src/Ampersand/FSpec/Transformers.hs +++ b/src/Ampersand/FSpec/Transformers.hs @@ -841,15 +841,17 @@ expressionInstances = allExprs interfaceInstances :: FSpec -> Set.Set Interface interfaceInstances = Set.fromList . ctxifcs . originalContext meaningInstances :: FSpec -> Set.Set Meaning -meaningInstances fSpec = (Set.fromList . concat . fmap meanings . Set.toList . relationInstances $ fSpec) - `Set.union` - (Set.fromList . concat . fmap meanings . Set.toList . ruleInstances $ fSpec) +meaningInstances fSpec = Set.empty + -- (Set.fromList . concat . fmap meanings . Set.toList . relationInstances $ fSpec) + -- `Set.union` + -- (Set.fromList . concat . fmap meanings . Set.toList . ruleInstances $ fSpec) purposeInstances :: FSpec -> Set.Set Purpose purposeInstances fSpec = Set.fromList . fSexpls $ fSpec relationInstances :: FSpec -> Set.Set Relation relationInstances = relsDefdIn . originalContext ruleInstances :: FSpec -> Set.Set Rule ruleInstances = allRules . originalContext + instance Instances A_Context where instances = Set.singleton . originalContext instance Instances AClassify where @@ -865,9 +867,7 @@ instance Instances IdentityDef where instance Instances Interface where instances = interfaceInstances instance Instances Meaning where - instances fSpec = Set.fromList (concatMap meanings . ruleInstances $ fSpec) - `Set.union` - Set.fromList (concatMap meanings . relationInstances $ fSpec) + instances = meaningInstances instance Instances Markup where instances fSpec = (Set.fromList . map explMarkup . Set.toList . purposeInstances $ fSpec) `Set.union` From 95ae974ff15ae3051452b7e4573a855748c76254 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Wed, 16 Jan 2019 23:12:19 +0100 Subject: [PATCH 128/131] Loop was in showUnique --- src/Ampersand/ADL1/Rule.hs | 3 +- src/Ampersand/Basics/PandocExtended.hs | 2 +- src/Ampersand/Basics/Unique.hs | 10 +++--- src/Ampersand/Classes/ViewPoint.hs | 10 +++--- src/Ampersand/Core/AbstractSyntaxTree.hs | 29 ++++++++-------- src/Ampersand/Core/ParseTree.hs | 2 +- src/Ampersand/FSpec/FSpec.hs | 10 +++--- src/Ampersand/FSpec/ShowHS.hs | 17 +++++++--- src/Ampersand/FSpec/Transformers.hs | 42 +++++++++++------------- src/Ampersand/Input/ADL1/FilePos.hs | 2 ++ src/Ampersand/Input/Xslx/XLSX.hs | 5 ++- 11 files changed, 68 insertions(+), 64 deletions(-) diff --git a/src/Ampersand/ADL1/Rule.hs b/src/Ampersand/ADL1/Rule.hs index f17737a7b9..1eb8f3436a 100644 --- a/src/Ampersand/ADL1/Rule.hs +++ b/src/Ampersand/ADL1/Rule.hs @@ -36,7 +36,7 @@ rulefromProp :: Prop -> Relation -> Rule rulefromProp prp d = Ru { rrnm = show prp++" "++showDcl , formalExpression = rExpr - , rrfps = origin d + , rrfps = PropertyRule nm (origin d) , rrmean = meanings prp , rrmsg = violMsg prp , rrviol = Nothing @@ -46,6 +46,7 @@ rulefromProp prp d = , isSignal = fatal "It is determined later (when all MAINTAIN statements are available), what this value is." } where + nm = show prp++" "++showDcl showDcl = showRel d r:: Expression r = EDcD d diff --git a/src/Ampersand/Basics/PandocExtended.hs b/src/Ampersand/Basics/PandocExtended.hs index 1814a35bc5..2c1b19bd2c 100644 --- a/src/Ampersand/Basics/PandocExtended.hs +++ b/src/Ampersand/Basics/PandocExtended.hs @@ -22,7 +22,7 @@ data Markup = , amPandoc :: [Block] } deriving (Show, Eq, Ord, Typeable, Data) instance Unique Markup where - showUnique x = uniqueShow True x++" in "++(show.amLang) x + showUnique = show -- | a way to show the pandoc in a default way. We currently use Markdown for this purpose. diff --git a/src/Ampersand/Basics/Unique.hs b/src/Ampersand/Basics/Unique.hs index ff452a73ee..5f4b84eb22 100644 --- a/src/Ampersand/Basics/Unique.hs +++ b/src/Ampersand/Basics/Unique.hs @@ -23,15 +23,14 @@ class (Typeable e, Eq e) => Unique e where -- | a representation of a unique thing self :: e -> UniqueObj e self a = UniqueObj { theThing = a - , theShow = showUnique + -- , theShow = showUnique } -- | representation of a Unique thing into a string. - uniqueShow :: Bool -> -- Should the type show too? + uniqueShowWithType :: e -> -- the thing to show String - uniqueShow includeType x = typePrefix ++ (showUnique . theThing . self) x - where - typePrefix = if includeType then show (typeOf x) ++"_" else "" + uniqueShowWithType x = show (typeOf x) ++"_" ++ showUnique x + -- | A function to show a unique instance. It is the responsability -- of the instance definition to make sure that for every a, b of -- an individual type: @@ -43,7 +42,6 @@ class (Typeable e, Eq e) => Unique e where -- | this is the implementation of the abstract data type. It mustn't be exported data UniqueObj a = UniqueObj { theThing :: a - , theShow :: a -> String } deriving (Typeable) instance Unique a => Unique [a] where diff --git a/src/Ampersand/Classes/ViewPoint.hs b/src/Ampersand/Classes/ViewPoint.hs index ee79c8b5bd..a200ef604d 100644 --- a/src/Ampersand/Classes/ViewPoint.hs +++ b/src/Ampersand/Classes/ViewPoint.hs @@ -19,7 +19,8 @@ class Language a where udefrules :: a -> Rules -- ^ all user defined rules that are maintained within this viewpoint, -- which are not multiplicity- and not identity rules. multrules :: a -> Rules -- ^ all multiplicityrules that are maintained within this viewpoint. - multrules x = Set.fromList $ [rulefromProp p d |d<-Set.elems $ relsDefdIn x, p<-Set.elems (properties d)] + multrules x = Set.fromList $ + [rulefromProp p d |d<-Set.elems $ relsDefdIn x, p<-Set.elems (properties d)] identityRules :: a -> Rules -- all identity rules that are maintained within this viewpoint. identityRules x = Set.unions . map rulesFromIdentity $ identities x allRules :: a -> Rules @@ -68,10 +69,10 @@ instance (Eq a,Language a) => Language [a] where instance (Eq a,Language a) => Language (Set.Set a) where relsDefdIn = Set.unions . map relsDefdIn . Set.elems udefrules = Set.unions . map udefrules . Set.elems - identities = concatMap identities . Set.elems - viewDefs = concatMap viewDefs . Set.elems + identities = nub . concatMap identities . Set.elems + viewDefs = nub . concatMap viewDefs . Set.elems gens = nub . concatMap gens . Set.elems - patterns = concatMap patterns . Set.elems + patterns = nub . concatMap patterns . Set.elems instance Language A_Context where relsDefdIn context = uniteRels ( relsDefdIn (patterns context) @@ -96,7 +97,6 @@ instance Language A_Context where instance Language Pattern where relsDefdIn = ptdcs udefrules = ptrls -- all user defined rules in this pattern --- invariants pat = [r |r<-ptrls pat, not (isSignal r)] identities = ptids viewDefs = ptvds gens = ptgns diff --git a/src/Ampersand/Core/AbstractSyntaxTree.hs b/src/Ampersand/Core/AbstractSyntaxTree.hs index fbe126627a..d4b31bd8fe 100644 --- a/src/Ampersand/Core/AbstractSyntaxTree.hs +++ b/src/Ampersand/Core/AbstractSyntaxTree.hs @@ -8,6 +8,7 @@ module Ampersand.Core.AbstractSyntaxTree ( A_Context(..) , Typology(..) , Meta(..) + , Origin(..) , Pattern(..) , PairView(..) , PairViewSegment(..) @@ -170,7 +171,7 @@ data Rule = instance Eq Rule where r==r' = name r==name r' && origin r==origin r' -- Origin should be here too: A check that they all have unique names is done after typechecking. instance Unique Rule where - showUnique = rrnm + showUnique = optionalQuote . name instance Ord Rule where compare = compare `on` rrnm instance Show Rule where @@ -234,7 +235,7 @@ instance Ord Relation where else compare (name a) (name b) instance Unique Relation where showUnique d = - name d++uniqueShow False (decsgn d) + name d++showUnique (decsgn d) instance Hashable Relation where hashWithSalt s Relation{dechash = v} = s `hashWithSalt` v instance Show Relation where -- For debugging purposes only (and fatal messages) @@ -246,7 +247,7 @@ showRel rel = name rel++"["++show (source rel) ++ "*"++ show (target rel)++"]" data Meaning = Meaning { ameaMrk ::Markup} deriving (Show, Eq, Ord, Typeable, Data) instance Unique Meaning where - showUnique x = uniqueShow True x++" in "++(show.amLang.ameaMrk) x + showUnique = show instance Named Relation where name d = unpack (decnm d) @@ -266,7 +267,7 @@ instance Named IdentityDef where instance Traced IdentityDef where origin = idPos instance Unique IdentityDef where - showUnique = idLbl + showUnique = name instance Ord IdentityDef where compare a b = name a `compare` name b data IdentitySegment = IdentityExp ObjectDef deriving (Eq, Show) -- TODO: refactor to a list of terms @@ -284,7 +285,7 @@ instance Named ViewDef where instance Traced ViewDef where origin = vdpos instance Unique ViewDef where - showUnique vd = vdlbl vd++"_"++name (vdcpt vd) + showUnique vd = name vd++"_"++name (vdcpt vd) instance Eq ViewDef where a == b = vdlbl a == vdlbl b && vdcpt a == vdcpt b instance Ord ViewDef where @@ -320,8 +321,8 @@ instance Traced AClassify where instance Unique AClassify where showUnique a = case a of - Isa{} -> uniqueShow False (genspc a)++" ISA "++uniqueShow False (gengen a) - IsE{} -> uniqueShow False (genspc a)++" IS "++intercalate " /\\ " (map (uniqueShow False) (genrhs a)) + Isa{} -> showUnique (genspc a)++" ISA "++showUnique (gengen a) + IsE{} -> showUnique (genspc a)++" IS "++intercalate " /\\ " (map (showUnique) (genrhs a)) instance Show AClassify where -- This show is used in error messages. It should therefore not display the term's type showsPrec _ g = @@ -447,8 +448,8 @@ instance Eq Purpose where instance Ord Purpose where compare a b = compare (explObj a, origin a) (explObj b, origin b) instance Unique Purpose where - showUnique p = showUnique (explMarkup p) - ++ uniqueShow True (explPos p) + showUnique p = uniqueShowWithType (explMarkup p) + ++ uniqueShowWithType (explPos p) instance Traced Purpose where origin = explPos @@ -463,8 +464,8 @@ data Population -- The user defined populations } deriving (Eq,Ord) instance Unique Population where - showUnique pop@ARelPopu{} = (showUnique.popdcl) pop ++ (showUnique.popps) pop - showUnique pop@ACptPopu{} = (showUnique.popcpt) pop ++ (showUnique.popas) pop + showUnique pop@ARelPopu{} = (uniqueShowWithType.popdcl) pop ++ (showUnique.popps) pop + showUnique pop@ACptPopu{} = (uniqueShowWithType.popcpt) pop ++ (showUnique.popas) pop type AAtomPairs = Set.Set AAtomPair data AAtomPair @@ -555,8 +556,8 @@ data ExplObj = ExplConceptDef ConceptDef instance Unique ExplObj where showUnique e = "Explanation of "++ case e of - (ExplConceptDef cd) -> uniqueShow True cd - (ExplRelation d) -> uniqueShow True d + (ExplConceptDef cd) -> uniqueShowWithType cd + (ExplRelation d) -> uniqueShowWithType d (ExplRule s) -> "a Rule named "++s (ExplIdentityDef s) -> "an Ident named "++s (ExplViewDef s) -> "a View named "++s @@ -805,7 +806,7 @@ instance Show Signature where showsPrec _ (Sign s t) = showString ( "[" ++ show s ++ "*" ++ show t ++ "]" ) instance Unique Signature where - showUnique (Sign s t) = "[" ++ uniqueShow False s ++ "*" ++ uniqueShow False t ++ "]" + showUnique (Sign s t) = "[" ++ showUnique s ++ "*" ++ showUnique t ++ "]" instance HasSignature Signature where source (Sign s _) = s target (Sign _ t) = t diff --git a/src/Ampersand/Core/ParseTree.hs b/src/Ampersand/Core/ParseTree.hs index 34cee4db58..6150fb77d1 100644 --- a/src/Ampersand/Core/ParseTree.hs +++ b/src/Ampersand/Core/ParseTree.hs @@ -152,7 +152,7 @@ data ConceptDef } deriving (Show,Eq,Ord,Typeable) instance Unique ConceptDef where - showUnique cd = cdcpt cd++"At"++uniqueShow True (origin cd) + showUnique cd = cdcpt cd++"At"++uniqueShowWithType (origin cd) instance Traced ConceptDef where origin = pos instance Named ConceptDef where diff --git a/src/Ampersand/FSpec/FSpec.hs b/src/Ampersand/FSpec/FSpec.hs index 35c7a6cb5c..e758180e86 100644 --- a/src/Ampersand/FSpec/FSpec.hs +++ b/src/Ampersand/FSpec/FSpec.hs @@ -147,8 +147,8 @@ instance Unique Atom where showUnique a = showValADL (atmVal a)++" in " ++case atmRoots a of [] -> fatal "an atom must have at least one root concept" - [x] -> uniqueShow True x - xs -> "["++intercalate ", " (map (uniqueShow True) xs)++"]" + [x] -> uniqueShowWithType x + xs -> "["++intercalate ", " (map uniqueShowWithType xs)++"]" data A_Pair = Pair { lnkDcl :: Relation , lnkLeft :: Atom @@ -157,9 +157,9 @@ data A_Pair = Pair { lnkDcl :: Relation instance HasSignature A_Pair where sign = sign . lnkDcl instance Unique A_Pair where - showUnique x = uniqueShow False (lnkDcl x) - ++ uniqueShow False (lnkLeft x) - ++ uniqueShow False (lnkRight x) + showUnique x = showUnique (lnkDcl x) + ++ showUnique (lnkLeft x) + ++ showUnique (lnkRight x) concDefs :: FSpec -> A_Concept -> [ConceptDef] concDefs fSpec c = [ cdef | cdef<-conceptDefs fSpec, name cdef==name c ] diff --git a/src/Ampersand/FSpec/ShowHS.hs b/src/Ampersand/FSpec/ShowHS.hs index 6956935e7c..3fefa7df6f 100644 --- a/src/Ampersand/FSpec/ShowHS.hs +++ b/src/Ampersand/FSpec/ShowHS.hs @@ -636,14 +636,21 @@ instance ShowHSName Origin where FileLoc l sym -> "FileLoc (" ++ show l ++ " " ++ sym ++ ")" DBLoc l -> "DBLoc " ++ show l Origin s -> "Origin " ++ show s + PropertyRule str declOrig + -> "PropertyRule of "++str++" "++ + case declOrig of + FileLoc l sym -> "declared at FileLoc (" ++ show l ++ " " ++ sym ++ ")" + _ -> fatal $ "This should be the origin of a Relation, but it doesn't seem like it is.\n" + ++show declOrig OriginUnknown -> "OriginUnknown" XLSXLoc fPath sheet (a,b) -> "XLSXLoc "++fPath++" "++sheet++" "++show(a,b) instance ShowHS Origin where - showHS opts indent (FileLoc l s) = "FileLoc (" ++ showHS opts indent l ++ " " ++ s ++ ")" - showHS _ _ (DBLoc l) = "DBLoc " ++ show l - showHS _ _ (Origin s) = "Origin " ++ show s - showHS _ _ OriginUnknown = "OriginUnknown" - showHS _ _ (XLSXLoc fPath sheet (a,b)) = "XLSXLoc "++fPath++" "++sheet++" "++show(a,b) + showHS opts indent (FileLoc l s) = "FileLoc (" ++ showHS opts indent l ++ " " ++ s ++ ")" + showHS _ _ (DBLoc l) = "DBLoc " ++ show l + showHS opts indent (PropertyRule str declOrig) = "PropertyRule " ++ show str ++ " ("++showHS opts indent declOrig++")" + showHS _ _ (Origin s) = "Origin " ++ show s + showHS _ _ OriginUnknown = "OriginUnknown" + showHS _ _ (XLSXLoc fPath sheet (a,b)) = "XLSXLoc "++fPath++" "++sheet++" "++show(a,b) instance ShowHS Block where showHS _ _ = show diff --git a/src/Ampersand/FSpec/Transformers.hs b/src/Ampersand/FSpec/Transformers.hs index bbe051f72f..a615f64247 100644 --- a/src/Ampersand/FSpec/Transformers.hs +++ b/src/Ampersand/FSpec/Transformers.hs @@ -421,14 +421,14 @@ transformers fSpec = map toTransformer [ ) ,("markup" , "Meaning" , "Markup" , Set.fromList - [(dirtyId mean, dirtyId . ameaMrk $ mean) - | mean::Meaning <- instanceList fSpec + [ (dirtyId mean, dirtyId . ameaMrk $ mean) + | mean::Meaning <- Set.toList . meaningInstances $ fSpec ] ) ,("markup" , "Purpose" , "Markup" , Set.fromList [(dirtyId purp, dirtyId . explMarkup $ purp) - | purp::Purpose <- instanceList fSpec + | purp::Purpose <- Set.toList . purposeInstances $ fSpec ] ) ,("meaning" , "Rule" , "Meaning" @@ -841,10 +841,9 @@ expressionInstances = allExprs interfaceInstances :: FSpec -> Set.Set Interface interfaceInstances = Set.fromList . ctxifcs . originalContext meaningInstances :: FSpec -> Set.Set Meaning -meaningInstances fSpec = Set.empty - -- (Set.fromList . concat . fmap meanings . Set.toList . relationInstances $ fSpec) - -- `Set.union` - -- (Set.fromList . concat . fmap meanings . Set.toList . ruleInstances $ fSpec) +meaningInstances fSpec = (Set.fromList . concat . map meanings . Set.toList . relationInstances $ fSpec) + `Set.union` + (Set.fromList . concat . map meanings . Set.toList . ruleInstances $ fSpec) purposeInstances :: FSpec -> Set.Set Purpose purposeInstances fSpec = Set.fromList . fSexpls $ fSpec relationInstances :: FSpec -> Set.Set Relation @@ -866,8 +865,8 @@ instance Instances IdentityDef where instances = Set.fromList . ctxks . originalContext instance Instances Interface where instances = interfaceInstances -instance Instances Meaning where - instances = meaningInstances +--instance Instances Meaning where +-- instances = meaningInstances instance Instances Markup where instances fSpec = (Set.fromList . map explMarkup . Set.toList . purposeInstances $ fSpec) `Set.union` @@ -923,7 +922,7 @@ class HasDirtyId a where rawId :: a -> String instance Unique a => HasDirtyId a where - rawId = uniqueShow True + rawId = uniqueShowWithType class Instances a => HasPurpose a where purposes :: FSpec -> a -> [Purpose] purposes fSpec a = @@ -983,29 +982,26 @@ data ExprInfo = ExprInfo , singleton' :: Maybe PAtomValue -- the value of a singleton expression } binOp :: Expression -> Maybe BinOp -binOp = aap "binOp" $ binOp' +binOp = binOp' . exprInfo unaryOp :: Expression -> Maybe UnaryOp -unaryOp = aap "unaryOp" $ unaryOp' +unaryOp = unaryOp' . exprInfo bindedRel :: Expression -> Maybe Relation -bindedRel = aap "bindedRel" $ bindedRel' +bindedRel = bindedRel' . exprInfo first :: Expression -> Maybe Expression -first = aap "first" $ first' +first = first' . exprInfo second :: Expression -> Maybe Expression -second = aap "second" $ second' +second = second' . exprInfo arg :: Expression -> Maybe Expression -arg = aap "arg" $ arg' +arg = arg' . exprInfo userCpt :: Expression -> Maybe A_Concept -userCpt = aap "userCpt" $ userCpt' +userCpt = userCpt' . exprInfo userSrc :: Expression -> Maybe A_Concept -userSrc = aap "userSrc" $ userSrc' +userSrc = userSrc' . exprInfo userTrg :: Expression -> Maybe A_Concept -userTrg = aap "userTrg" $ userTrg' +userTrg = userTrg' . exprInfo singleton :: Expression -> Maybe PAtomValue -singleton = aap "singleton" $ singleton' +singleton = singleton' . exprInfo -aap :: String -> (ExprInfo->a) -> (Expression->a) -aap _ f e = -- traceShow (str++" "++showA e) $ - (f . exprInfo) e exprInfo :: Expression -> ExprInfo exprInfo expr = case expr of diff --git a/src/Ampersand/Input/ADL1/FilePos.hs b/src/Ampersand/Input/ADL1/FilePos.hs index ae25e41220..42097cc0c4 100644 --- a/src/Ampersand/Input/ADL1/FilePos.hs +++ b/src/Ampersand/Input/ADL1/FilePos.hs @@ -55,6 +55,7 @@ instance Hashable FilePos where data Origin = OriginUnknown | Origin String + | PropertyRule String Origin -- Constructor is used to hold the origin of a propertyrule. | FileLoc FilePos SymbolName | XLSXLoc FilePath String (Int,Int) | DBLoc String @@ -72,6 +73,7 @@ instance Show Origin where show (XLSXLoc filePath sheet (row,col)) = show filePath++":"++ "\n Sheet: "++sheet++", "++T.unpack (int2col col)++show row + show (PropertyRule dcl o) = "PropertyRule for "++dcl++" which is defined at "++show o show (DBLoc str) = "Database location: "++str show (Origin str) = str show OriginUnknown = "Unknown origin" diff --git a/src/Ampersand/Input/Xslx/XLSX.hs b/src/Ampersand/Input/Xslx/XLSX.hs index ab312410ed..6eda445d06 100644 --- a/src/Ampersand/Input/Xslx/XLSX.hs +++ b/src/Ampersand/Input/Xslx/XLSX.hs @@ -59,7 +59,7 @@ toPops :: Options -> FilePath -> SheetCellsForTable -> [P_Population] toPops opts file x = map popForColumn (colNrs x) where popForColumn :: Int -> P_Population - popForColumn i = --trace (show x ++"(Now column: "++show i++")") $ + popForColumn i = if i == sourceCol then P_CptPopu { pos = popOrigin , p_cnme = sourceConceptName @@ -187,8 +187,7 @@ theSheetCellsForTable (sheetName,ws) theMapping indexInTableStarters | length okHeaderRows /= nrOfHeaderRows = Nothing -- Because there are not enough header rows | otherwise - = Just -- . (\x->trace (show x) x) $ - Mapping { theSheetName = T.unpack sheetName + = Just Mapping { theSheetName = T.unpack sheetName , theCellMap = ws ^. wsCells , headerRowNrs = okHeaderRows , popRowNrs = populationRows From 4888fd2f26688c9f9352a7912d552ec700fc6406 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Wed, 16 Jan 2019 23:23:45 +0100 Subject: [PATCH 129/131] Fix #879 --- ReleaseNotes.md | 1 + 1 file changed, 1 insertion(+) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 083b130152..2e6988aced 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -14,6 +14,7 @@ * Improved output of any invariant violations or signals for initial population * Improved use of compiler when no prototype is requested (reporting violations, testing specific rules and rap population output are possible) * Improved use of compiler when no script is provided (e.g. for --sampleConfigFile) +* [Issue #879](https://github.com/AmpersandTarski/Ampersand/issues/879) Bugfix in the meatgrinder. Also a big performance win in generating meta-stuff. ## v3.12.0 (21 december 2018) From 8699be59858bb8ead4e6e8a67b2d146a01c2c27c Mon Sep 17 00:00:00 2001 From: Michiel Stornebrink Date: Fri, 18 Jan 2019 11:06:14 +0100 Subject: [PATCH 130/131] Update prototype framework version to latest release v1.1.0 --- ReleaseNotes.md | 3 +-- src/Ampersand/Misc/Options.hs | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 2e6988aced..75cc264f3f 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,8 +1,7 @@ # Release notes of Ampersand ## Unreleased changes -**!!Before release, do a release of the prototype framework and set option zwolleVersion to this release tag** -* Update prototype framework. See [releases](https://github.com/AmpersandTarski/Prototype/releases) for more information +* Update prototype framework to v1.1.0. See [releases](https://github.com/AmpersandTarski/Prototype/releases) for more information * Add 'public' folder in prototype directory to better distinguish between public and non-public scripts. If used, requires change in 'customizations' folder * [Issue #616](https://github.com/AmpersandTarski/Ampersand/issues/616) Add missing TType 'Object' to parser * [Issue #792](https://github.com/AmpersandTarski/Ampersand/issues/792) Add possibility to extend TXT in interfaces diff --git a/src/Ampersand/Misc/Options.hs b/src/Ampersand/Misc/Options.hs index a26ec6f51d..d843d2f151 100644 --- a/src/Ampersand/Misc/Options.hs +++ b/src/Ampersand/Misc/Options.hs @@ -209,7 +209,7 @@ getOptions' envOpts = , outputfile = fatal "No monadic options available." , dirPrototype = fromMaybe "." (envDirPrototype envOpts) (takeBaseName (fromMaybe "" fName)) <.> ".proto" , dirSource = takeDirectory $ fromMaybe "/" fName - , zwolleVersion = "development" + , zwolleVersion = "v1.1.0" , forceReinstallFramework = False , dirCustomizations = ["customizations"] , dbName = fmap toLower . fromMaybe ("ampersand_" ++ takeBaseName (fromMaybe "prototype" fName)) $ envDbName envOpts From d22ffcba535c3e361c45223480dd799e6838ac35 Mon Sep 17 00:00:00 2001 From: Han Joosten Date: Fri, 18 Jan 2019 11:49:30 +0100 Subject: [PATCH 131/131] bump version --- ReleaseNotes.md | 3 ++- ampersand.cabal | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 75cc264f3f..ea7f3c479f 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,6 +1,7 @@ # Release notes of Ampersand -## Unreleased changes +## v3.13.0 (18 january 2019) + * Update prototype framework to v1.1.0. See [releases](https://github.com/AmpersandTarski/Prototype/releases) for more information * Add 'public' folder in prototype directory to better distinguish between public and non-public scripts. If used, requires change in 'customizations' folder * [Issue #616](https://github.com/AmpersandTarski/Ampersand/issues/616) Add missing TType 'Object' to parser diff --git a/ampersand.cabal b/ampersand.cabal index 056c39f360..9c360f70fb 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -1,5 +1,5 @@ name: ampersand -version: 3.12.0 +version: 3.13.0 author: Stef Joosten maintainer: stef.joosten@ou.nl synopsis: Toolsuite for automated design of enterprise information systems.