diff --git a/AmpersandData/SystemContext/SystemContext.adl b/AmpersandData/SystemContext/SystemContext.adl index 1d3169143a..43bfe21e06 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 + 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. - 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 +ENDCONTEXT 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 diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 9ec52cd045..9955f172cb 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,6 +1,8 @@ # Release notes of Ampersand -## Unreleased changes +## v3.11.5 (23 november 2018) + +* [Issue #628](https://github.com/AmpersandTarski/Ampersand/issues/628) Fixed a performance issue for specific queries. ## v3.11.4 (27 october 2018) diff --git a/ampersand.cabal b/ampersand.cabal index 11bebe1e1a..ceb67e56a6 100644 --- a/ampersand.cabal +++ b/ampersand.cabal @@ -1,5 +1,5 @@ name: ampersand -version: 3.11.4 +version: 3.11.5 author: Stef Joosten maintainer: stef.joosten@ou.nl synopsis: Toolsuite for automated design of enterprise information systems. @@ -132,6 +132,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, @@ -183,6 +184,15 @@ executable ampersand default-extensions:NoImplicitPrelude build-depends: base == 4.11.*, 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.11.*, + 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..f6523eaf25 --- /dev/null +++ b/preProcApp/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import Ampersand +import System.Environment +import Ampersand.Input.PreProcessor +import Ampersand.Basics.UTF8 (readUTF8File) + +main :: IO () +main = + do + filename:defs <- getArgs; + input <- readUTF8File filename + inputString <- return $ either id id input + putStr $ either show id (preProcess' filename defs inputString) ++ "\n" diff --git a/src/Ampersand/FSpec/SQL.hs b/src/Ampersand/FSpec/SQL.hs index 13ffeae017..da1b8b4cef 100644 --- a/src/Ampersand/FSpec/SQL.hs +++ b/src/Ampersand/FSpec/SQL.hs @@ -327,35 +327,130 @@ nonSpecialSelectExpr fSpec expr= , bseWhr = Nothing } makeIntersectSelectExpr :: [Expression] -> BinQueryExpr - makeIntersectSelectExpr exprs = - case map (selectExpr fSpec) exprs of - [] -> fatal "makeIntersectSelectExpr must not be used on empty list" - [e] -> e - es -> -- Note: We now have at least two subexpressions - BQEComment [BlockComment "`intersect` does not work in MySQL, so this statement is generated:"] + makeIntersectSelectExpr [] = fatal $ "makeIntersectSelectExpr must not be called with an empty list." + makeIntersectSelectExpr exprs + -- The story here: If at least one of the conjuncts is I, then + -- we know that all results should be in the broad table where + -- I is in. All expressions that are implemented in that table (esR) + -- can be used to efficiently restrict the rows from that table. + -- If we still have expressions left over, these have to be dealt with + -- appropriatly. + | null esI = nonOptimizedIntersectSelectExpr + | null esRest = optimizedIntersectSelectExpr + | otherwise = + let part1 = makeIntersectSelectExpr (map fst esI ++ map fst esR) + part2 = makeIntersectSelectExpr esRest + in traceComment ["Combination of optimized and non-optimized intersections"] BSE { bseSetQuantifier = SQDefault - , bseSrc = Col { cTable = [iSect 0] + , bseSrc = Col { cTable = [] , cCol = [sourceAlias] , cAlias = [] , cSpecial = Nothing} - , bseTrg = Col { cTable = [iSect 0] + , bseTrg = Col { cTable = [] , cCol = [targetAlias] , cAlias = [] , cSpecial = Nothing} - , bseTbl = zipWith tableRef [0 ..] es - , bseWhr = Just . conjunctSQL . concatMap constraintsOfTailExpression $ - [1..length (tail es)] - } - where - iSect :: Int -> Name - iSect n = Name ("subIntersect"++show n) - tableRef :: Int -> BinQueryExpr -> TableRef - tableRef n e = TRQueryExpr (toSQL e) `as` iSect n - constraintsOfTailExpression :: Int -> [ValueExpr] - constraintsOfTailExpression n - = [ BinOp (Iden[iSect n,sourceAlias]) [Name "="] (Iden[iSect 0,sourceAlias]) - , BinOp (Iden[iSect n,targetAlias]) [Name "="] (Iden[iSect 0,targetAlias]) - ] + , bseTbl = [TRQueryExpr (toSQL part2) `as` Name "part2" ] + , bseWhr = Just . conjunctSQL $ + [ BinOp (Iden [sourceAlias]) [Name "="] (Iden [targetAlias]) + , In True (Iden [sourceAlias]) + (InQueryExpr (makeSelect {qeSelectList = [(Iden [sourceAlias],Nothing)] + ,qeFrom = [TRQueryExpr (toSQL part1) `as` Name "part1"] + })) + ] + } + 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 + isI :: Expression -> Maybe (Expression,Name) + isI e = + case e of + 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 = mapMaybe isR exprs + where + isR :: Expression -> Maybe (Expression,[Name]) + isR e = + case e of + (ECps (EDcD r, EFlp (EDcD r'))) + -> let (plug,_,t) = getRelationTableInfo fSpec r in + if r == r' && plug == broadTable + then Just (e,[QName (name t)]) + else Nothing + (ECps (EFlp (EDcD r'), EDcD r)) + -> let (plug,s,_) = getRelationTableInfo fSpec r in + if r' == r && plug == broadTable + then Just (e,[QName (name s)]) + else Nothing + (EDcD r) + -> let (plug,s,t) = getRelationTableInfo fSpec r in + if plug == broadTable + then Just (e,[QName (name s),QName (name t)]) + else Nothing + (EFlp (EDcD r)) + -> let (plug,s,t) = getRelationTableInfo fSpec r in + if plug == broadTable + then Just (e,[QName (name s),QName (name t)]) + else Nothing + _ -> Nothing + esRest :: [Expression] -- all other conjuctions + esRest = (exprs \\ (map fst esI)) \\ (map fst esR) + optimizedIntersectSelectExpr :: BinQueryExpr + optimizedIntersectSelectExpr + = BQEComment [BlockComment "Optimized intersection:"] + BSE { bseSetQuantifier = SQDefault + , bseSrc = Col { cTable = [] + , cCol = [sqlAttConcept fSpec c] + , cAlias = [] + , cSpecial = Nothing} + , bseTrg = Col { cTable = [] + , cCol = [sqlAttConcept fSpec c] + , cAlias = [] + , cSpecial = Nothing} + , bseTbl = [sqlConceptTable fSpec c] + , bseWhr = Just . conjunctSQL $ + [notNull (Iden [nm]) | nm <- nub (map snd esI++concatMap snd esR)] + } + 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 + nonOptimizedIntersectSelectExpr :: BinQueryExpr + nonOptimizedIntersectSelectExpr = + case map (selectExpr fSpec) exprs of + [] -> fatal "makeIntersectSelectExpr must not be used on empty list" + [e] -> e + es -> -- Note: We now have at least two subexpressions + BQEComment [BlockComment "`intersect` does not work in MySQL, so this statement is generated:"] + BSE { bseSetQuantifier = SQDefault + , bseSrc = Col { cTable = [iSect 0] + , cCol = [sourceAlias] + , cAlias = [] + , cSpecial = Nothing} + , bseTrg = Col { cTable = [iSect 0] + , cCol = [targetAlias] + , cAlias = [] + , cSpecial = Nothing} + , bseTbl = zipWith tableRef [0 ..] es + , bseWhr = Just . conjunctSQL . concatMap constraintsOfTailExpression $ + [1..length (tail es)] + } + where + iSect :: Int -> Name + iSect n = Name ("subIntersect"++show n) + tableRef :: Int -> BinQueryExpr -> TableRef + tableRef n e = TRQueryExpr (toSQL e) `as` iSect n + constraintsOfTailExpression :: Int -> [ValueExpr] + constraintsOfTailExpression n + = [ BinOp (Iden[iSect n,sourceAlias]) [Name "="] (Iden[iSect 0,sourceAlias]) + , BinOp (Iden[iSect n,targetAlias]) [Name "="] (Iden[iSect 0,targetAlias]) + ] EUni (l,r) -> traceComment ["case: EUni (l,r)"] BCQE { bseSetQuantifier = SQDefault 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 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..686af6afad 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 @@ -33,26 +34,25 @@ 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) + 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 filePath (pcDefineds pc) fileContents)) + $ \(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..d214f3fde5 --- /dev/null +++ b/src/Ampersand/Input/PreProcessor.hs @@ -0,0 +1,271 @@ +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 +import Data.Either +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 + +-- 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 + +-- | 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 -- ^ filename, used only for error reporting + -> String -- ^ input, the string to process + -> Either ParseError Block -- ^ result +file2block fileName = (parseLexedFile fileName) <=< (runLexer fileName) + +---- LEXER + +newtype Guard = Guard String +guard :: Guard -> String +guard (Guard x) = x + +data LexLine = CodeLine String + | IncludeLine String (Maybe String) + | IfNotStart Guard + | IfStart Guard + | ElseClause + | EndIf +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" + +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 + +lexLine :: Lexer LexLine +lexLine = preProcDirective <|> includeLine <|> codeLine + +codeLine :: Lexer LexLine +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) *> + ( 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 <* + untilEOL + ) + +ifNotGuard :: Lexer LexLine +ifNotGuard = (IfNotStart . Guard) <$> + (try(string "IFNOT") *> + whitespace *> + some alphaNum <* + untilEOL + ) + +elseClause :: Lexer LexLine +elseClause = (const ElseClause) <$> (try(string "ELSE") *> untilEOL) + +ifEnd :: Lexer LexLine +ifEnd = (const EndIf) <$> (try(string "ENDIF") *> untilEOL) + +-- Helper Lexers +whitespace :: Lexer () +whitespace = skipMany1 space + +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 ] + +-- 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 + +parseLexedFile :: String -> [LexLine] -> (Either ParseError Block) +parseLexedFile fileName = parse (many blockElem <* eof) fileName + +blockElem :: TokenParser BlockElem +blockElem = choice [lineElem, includeElem, ifBlock, ifNotBlock ] + +lineElem :: TokenParser BlockElem +lineElem = parserToken ((fmap LineElem) <$> line2string) + where + line2string (CodeLine s) = Just s + 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) + <*> 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 + guard2string (IfStart g) = Just g + guard2string _ = Nothing + +ifNotElemStart :: TokenParser Guard +ifNotElemStart = parserToken guard2string + where + guard2string (IfNotStart g) = Just g + guard2string _ = Nothing + +ifElemEnd :: TokenParser () +ifElemEnd = parserToken matchIfEnd + where + matchIfEnd EndIf = Just () + matchIfEnd _ = Nothing + +elseClauseStart :: TokenParser () +elseClauseStart = parserToken matchIfEnd + where + matchIfEnd ElseClause = Just () + matchIfEnd _ = Nothing + +---- TURN BLOCK BACK INTO TEXT + +{- Note the recursion here: + block2file calls blockElem2String, which might call showGuardedBlock, which calls block2file and potentially also + showElse, which again calls block2file + + 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'. +-} + +-- | 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) + +-- | 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 _ 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 +-- 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 diff --git a/src/Ampersand/Output/FSpec2SQL.hs b/src/Ampersand/Output/FSpec2SQL.hs index b4779ea250..ad18213674 100644 --- a/src/Ampersand/Output/FSpec2SQL.hs +++ b/src/Ampersand/Output/FSpec2SQL.hs @@ -51,8 +51,10 @@ dumpSQLqueries multi <>header "Queries per relation" <>concatMap showDecl (vrels fSpec) <>header "Queries of interfaces" - <>concatMap showInterface (interfaceS fSpec <> interfaceG fSpec) + <>concatMap showInterface y where + y :: [Interface] + y = (\x -> trace (show x) x) (interfaceS fSpec <> interfaceG fSpec) fSpec = userFSpec multi showInterface :: Interface -> [Text.Text] showInterface ifc diff --git a/stack.yaml b/stack.yaml index 31e618bc17..8d0e3d92ff 100644 --- a/stack.yaml +++ b/stack.yaml @@ -29,6 +29,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