From afce504fa0c3e505e5d025231eab1938b3a9cf95 Mon Sep 17 00:00:00 2001 From: Kai Prott Date: Tue, 20 Jun 2017 15:30:55 +0200 Subject: [PATCH 01/19] Started adding a parser for conditional compiling --- src/Curry/CondCompile/Parser.hs | 90 +++++++++++++++++++++++++++++++++ 1 file changed, 90 insertions(+) create mode 100644 src/Curry/CondCompile/Parser.hs diff --git a/src/Curry/CondCompile/Parser.hs b/src/Curry/CondCompile/Parser.hs new file mode 100644 index 0000000..0962e6d --- /dev/null +++ b/src/Curry/CondCompile/Parser.hs @@ -0,0 +1,90 @@ +module Curry.CondCompile.Parser where + +import Text.Parsec hiding (newline) + + +data Stmt = IFDEF String [Stmt] [Stmt] + | IF Condition [Stmt] [Stmt] + | Code String + deriving Show + +type Condition = (String, CompOperator, String) + +data CompOperator = EQUAL | LESS | LEQ | GREATER | GEQ | NEQ + deriving Show + +type Parser a = Parsec String () a + +example = "#IFDEF value\nlol\n#ENDIF" + +iftoken = return () <* string "#IF" <* whitespaces +ifdeftoken = return () <* string "#IFDEF" <* whitespaces +elsetoken = return () <* newline <* string "#ELSE" <* whitespaces +endtoken = return () <* newline <* string "#ENDIF" <* whitespaces + +reservedTokens = [iftoken, ifdeftoken, elsetoken, endtoken] + +whitespaces :: Parser () +whitespaces = skipMany (() <$ space) + +simpleParse :: String -> Either String [Stmt] +simpleParse = either (Left . show) Right . runParser program () "" + +program :: Parser [Stmt] +program = many statement <* eof + +statement :: Parser Stmt +statement = ifdef <|> ifstmt <|> code + +ifstmt :: Parser Stmt +ifstmt = try ifelse <|> try ifstmt' + +ifelse :: Parser Stmt +ifelse = IF <$> (iftoken *> condition <* newline) + <*> many statement + <*> (elsetoken *> many statement <* endtoken) + +ifstmt' :: Parser Stmt +ifstmt' = IF <$> (iftoken *> condition <* newline) + <*> many statement + <*> (return [] <* endtoken) + +ifdef :: Parser Stmt +ifdef = try ifdef' <|> try ifdefelse + +ifdefelse :: Parser Stmt +ifdefelse = IFDEF <$> (ifdeftoken *> identifier <* newline) + <*> many statement + <*> (elsetoken *> many statement <* endtoken) + +ifdef' :: Parser Stmt +ifdef' = IFDEF <$> (ifdeftoken *> identifier <* newline) + <*> many statement + <*> (return [] <* endtoken) + +newline :: Parser Char +newline = char '\n' + +code :: Parser Stmt +code = Code <$> many1 (notFollowedBy (choice reservedTokens) *> anyChar) + +condition :: Parser Condition +condition = do ident <- identifier + op <- operator + condVal <- many digit + whitespaces + return (ident, op, condVal) + +operator :: Parser CompOperator +operator = choice [ EQUAL <$ string "=" + , LESS <$ string "<" + , GREATER <$ string ">" + , LEQ <$ string "<=" + , GEQ <$ string ">=" + , NEQ <$ string "!=" + ] + +identifier :: Parser String +identifier = (:) <$> firstChar <*> many nonFirstChar + where firstChar = letter <|> char '_' + nonFirstChar = digit <|> firstChar <|> char '.' -- GitLab From 715cb8c78f18beb588c1bc0f4f60622b65e5ad73 Mon Sep 17 00:00:00 2001 From: Kai Prott Date: Sun, 25 Jun 2017 02:40:50 +0200 Subject: [PATCH 02/19] Fixed some problems, nested parsing still does not work --- src/Curry/CondCompile/Parser.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/Curry/CondCompile/Parser.hs b/src/Curry/CondCompile/Parser.hs index 0962e6d..7c257c7 100644 --- a/src/Curry/CondCompile/Parser.hs +++ b/src/Curry/CondCompile/Parser.hs @@ -15,18 +15,20 @@ data CompOperator = EQUAL | LESS | LEQ | GREATER | GEQ | NEQ type Parser a = Parsec String () a -example = "#IFDEF value\nlol\n#ENDIF" +example = "#IF value<=599\nLOL\n#ENDIF\n#IFDEF anotha\nONE\n#ENDIF\n" -iftoken = return () <* string "#IF" <* whitespaces -ifdeftoken = return () <* string "#IFDEF" <* whitespaces -elsetoken = return () <* newline <* string "#ELSE" <* whitespaces -endtoken = return () <* newline <* string "#ENDIF" <* whitespaces +iftoken = () <$ try (string "#IF" <* whitespaces) +ifdeftoken = () <$ try (string "#IFDEF" <* whitespaces) +elsetoken = () <$ try (newline <* string "#ELSE" <* whitespaces) +endtoken = () <$ try (newline <* string "#ENDIF" <* whitespaces) reservedTokens = [iftoken, ifdeftoken, elsetoken, endtoken] whitespaces :: Parser () whitespaces = skipMany (() <$ space) +test = either putStrLn print (simpleParse example) + simpleParse :: String -> Either String [Stmt] simpleParse = either (Left . show) Right . runParser program () "" @@ -37,7 +39,7 @@ statement :: Parser Stmt statement = ifdef <|> ifstmt <|> code ifstmt :: Parser Stmt -ifstmt = try ifelse <|> try ifstmt' +ifstmt = try ifstmt' <|> try ifelse ifelse :: Parser Stmt ifelse = IF <$> (iftoken *> condition <* newline) @@ -62,8 +64,8 @@ ifdef' = IFDEF <$> (ifdeftoken *> identifier <* newline) <*> many statement <*> (return [] <* endtoken) -newline :: Parser Char -newline = char '\n' +newline :: Parser String +newline = string "\n" <|> string "\r\n" code :: Parser Stmt code = Code <$> many1 (notFollowedBy (choice reservedTokens) *> anyChar) @@ -72,16 +74,15 @@ condition :: Parser Condition condition = do ident <- identifier op <- operator condVal <- many digit - whitespaces return (ident, op, condVal) operator :: Parser CompOperator -operator = choice [ EQUAL <$ string "=" +operator = choice [ LEQ <$ string "<=" , LESS <$ string "<" - , GREATER <$ string ">" - , LEQ <$ string "<=" , GEQ <$ string ">=" + , GREATER <$ string ">" , NEQ <$ string "!=" + , EQUAL <$ string "=" ] identifier :: Parser String -- GitLab From 5e349efd5e1fa123cf956679ffbbd9ce741aaec5 Mon Sep 17 00:00:00 2001 From: Finn Teegen Date: Wed, 28 Jun 2017 13:59:25 +0200 Subject: [PATCH 03/19] Rework parser and separate type definitions for conditional compiling --- src/Curry/CondCompile/Parser.hs | 130 ++++++++++++++------------------ src/Curry/CondCompile/Type.hs | 31 ++++++++ 2 files changed, 86 insertions(+), 75 deletions(-) create mode 100644 src/Curry/CondCompile/Type.hs diff --git a/src/Curry/CondCompile/Parser.hs b/src/Curry/CondCompile/Parser.hs index 7c257c7..5984a58 100644 --- a/src/Curry/CondCompile/Parser.hs +++ b/src/Curry/CondCompile/Parser.hs @@ -1,91 +1,71 @@ +{- | + Module : $Header$ + Description : Parser for conditional compiling + Copyright : (c) 2017 Kai-Oliver Prott + 2017 Finn Teegen + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + TODO +-} module Curry.CondCompile.Parser where -import Text.Parsec hiding (newline) +import Text.Parsec - -data Stmt = IFDEF String [Stmt] [Stmt] - | IF Condition [Stmt] [Stmt] - | Code String - deriving Show - -type Condition = (String, CompOperator, String) - -data CompOperator = EQUAL | LESS | LEQ | GREATER | GEQ | NEQ - deriving Show +import Curry.CondCompile.Type type Parser a = Parsec String () a -example = "#IF value<=599\nLOL\n#ENDIF\n#IFDEF anotha\nONE\n#ENDIF\n" - -iftoken = () <$ try (string "#IF" <* whitespaces) -ifdeftoken = () <$ try (string "#IFDEF" <* whitespaces) -elsetoken = () <$ try (newline <* string "#ELSE" <* whitespaces) -endtoken = () <$ try (newline <* string "#ENDIF" <* whitespaces) - -reservedTokens = [iftoken, ifdeftoken, elsetoken, endtoken] - -whitespaces :: Parser () -whitespaces = skipMany (() <$ space) - -test = either putStrLn print (simpleParse example) - -simpleParse :: String -> Either String [Stmt] -simpleParse = either (Left . show) Right . runParser program () "" - -program :: Parser [Stmt] -program = many statement <* eof +program :: Parser Program +program = statement `sepBy` eol <* eof statement :: Parser Stmt -statement = ifdef <|> ifstmt <|> code - -ifstmt :: Parser Stmt -ifstmt = try ifstmt' <|> try ifelse +statement = ifElse "ifdef" identifier IfDef + <|> ifElse "if" condition If + <|> code + +ifElse :: String -> Parser a -> (a -> [Stmt] -> Maybe [Stmt] -> Stmt) + -> Parser Stmt +ifElse k p c = c <$> (try (many sp *> keyword k) *> many1 sp *> p <* many sp <* eol) + <*> many (statement <* eol) + <*> optionMaybe + (try (many sp *> keyword "else" *> many sp) *> eol *> many (statement <* eol)) + <* many sp <* keyword "endif" <* many sp -ifelse :: Parser Stmt -ifelse = IF <$> (iftoken *> condition <* newline) - <*> many statement - <*> (elsetoken *> many statement <* endtoken) +code :: Parser Stmt +code = try $ (char '#' "") *> fail "unknown directive" + <|> Code <$> manyTill anyChar (try (lookAhead (eol <|> eof))) -ifstmt' :: Parser Stmt -ifstmt' = IF <$> (iftoken *> condition <* newline) - <*> many statement - <*> (return [] <* endtoken) +keyword :: String -> Parser String +keyword = string . ('#' :) -ifdef :: Parser Stmt -ifdef = try ifdef' <|> try ifdefelse +condition :: Parser Cond +condition = (,,) <$> (identifier <* many sp) + <*> operator + <*> (many sp *> value) "condition" -ifdefelse :: Parser Stmt -ifdefelse = IFDEF <$> (ifdeftoken *> identifier <* newline) - <*> many statement - <*> (elsetoken *> many statement <* endtoken) +identifier :: Parser String +identifier = (:) <$> firstChar <*> many (firstChar <|> digit) "identifier" + where firstChar = letter <|> char '_' -ifdef' :: Parser Stmt -ifdef' = IFDEF <$> (ifdeftoken *> identifier <* newline) - <*> many statement - <*> (return [] <* endtoken) +operator :: Parser Op +operator = choice [ Leq <$ try (string "<=") + , Lt <$ try (string "<") + , Geq <$ try (string ">=") + , Gt <$ try (string ">") + , Neq <$ try (string "!=") + , Eq <$ string "==" + ] "operator" -newline :: Parser String -newline = string "\n" <|> string "\r\n" +value :: Parser String +value = many1 digit -code :: Parser Stmt -code = Code <$> many1 (notFollowedBy (choice reservedTokens) *> anyChar) - -condition :: Parser Condition -condition = do ident <- identifier - op <- operator - condVal <- many digit - return (ident, op, condVal) - -operator :: Parser CompOperator -operator = choice [ LEQ <$ string "<=" - , LESS <$ string "<" - , GEQ <$ string ">=" - , GREATER <$ string ">" - , NEQ <$ string "!=" - , EQUAL <$ string "=" - ] +eol :: Parser () +eol = endOfLine *> return () -identifier :: Parser String -identifier = (:) <$> firstChar <*> many nonFirstChar - where firstChar = letter <|> char '_' - nonFirstChar = digit <|> firstChar <|> char '.' +sp :: Parser () +sp = try $ lookAhead (eol *> unexpected "end of line" "") + <|> space *> return () diff --git a/src/Curry/CondCompile/Type.hs b/src/Curry/CondCompile/Type.hs new file mode 100644 index 0000000..f1ee3e6 --- /dev/null +++ b/src/Curry/CondCompile/Type.hs @@ -0,0 +1,31 @@ +{- | + Module : $Header$ + Description : Abstract syntax for conditional compiling + Copyright : (c) 2017 Kai-Oliver Prott + 2017 Finn Teegen + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + TODO +-} +module Curry.CondCompile.Type where + +type Program = [Stmt] + +data Stmt = If Cond [Stmt] (Maybe [Stmt]) + | IfDef String [Stmt] (Maybe [Stmt]) + | Code String + deriving Show + +type Cond = (String, Op, String) + +data Op = Eq + | Neq + | Lt + | Leq + | Gt + | Geq + deriving Show -- GitLab From d77a0187839115ff21a8cbc61b86e74e7a7e75ae Mon Sep 17 00:00:00 2001 From: Finn Teegen Date: Wed, 28 Jun 2017 14:00:07 +0200 Subject: [PATCH 04/19] Expose modules for conditional compiling --- curry-base.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/curry-base.cabal b/curry-base.cabal index 309e571..b1236b4 100644 --- a/curry-base.cabal +++ b/curry-base.cabal @@ -60,6 +60,8 @@ Library Curry.Base.Position Curry.Base.Pretty Curry.Base.Span + Curry.CondCompile.Parser + Curry.CondCompile.Type Curry.Files.Filenames Curry.Files.PathUtils Curry.Files.Unlit -- GitLab From 643305f5ce4041be423873002adb3694bcc992f4 Mon Sep 17 00:00:00 2001 From: Finn Teegen Date: Wed, 28 Jun 2017 14:00:24 +0200 Subject: [PATCH 05/19] Add parsec dependency --- curry-base.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/curry-base.cabal b/curry-base.cabal index b1236b4..99f5935 100644 --- a/curry-base.cabal +++ b/curry-base.cabal @@ -46,6 +46,7 @@ Library mtl , containers , filepath + , parsec , pretty ghc-options: -Wall Exposed-Modules: -- GitLab From a15282e9188d4eb1b40afba888687f5b3426b8d0 Mon Sep 17 00:00:00 2001 From: Finn Teegen Date: Wed, 28 Jun 2017 17:49:46 +0200 Subject: [PATCH 06/19] Extend conditional compiling functionality --- src/Curry/CondCompile/Parser.hs | 48 +++++++++++++++++++++------------ src/Curry/CondCompile/Type.hs | 13 ++++++--- 2 files changed, 40 insertions(+), 21 deletions(-) diff --git a/src/Curry/CondCompile/Parser.hs b/src/Curry/CondCompile/Parser.hs index 5984a58..2a3372a 100644 --- a/src/Curry/CondCompile/Parser.hs +++ b/src/Curry/CondCompile/Parser.hs @@ -23,29 +23,43 @@ program :: Parser Program program = statement `sepBy` eol <* eof statement :: Parser Stmt -statement = ifElse "ifdef" identifier IfDef - <|> ifElse "if" condition If - <|> code - -ifElse :: String -> Parser a -> (a -> [Stmt] -> Maybe [Stmt] -> Stmt) +statement = ifElse "if" condition If + <|> ifElse "ifdef" identifier IfDef + <|> ifElse "ifndef" identifier IfNDef + <|> define + <|> undef + <|> line + +ifElse :: String -> Parser a + -> (a -> [Stmt] -> [(Cond, [Stmt])] -> Maybe [Stmt] -> Stmt) -> Parser Stmt -ifElse k p c = c <$> (try (many sp *> keyword k) *> many1 sp *> p <* many sp <* eol) +ifElse k p c = c <$> (try (many sp *> keyword k *> many1 sp) *> p <* many sp <* eol) <*> many (statement <* eol) + <*> many ((,) <$> (try (many sp *> keyword "elif" *> many1 sp) *> condition <* many sp <* eol) + <*> many (statement <* eol)) <*> optionMaybe (try (many sp *> keyword "else" *> many sp) *> eol *> many (statement <* eol)) - <* many sp <* keyword "endif" <* many sp + <* try (many sp <* keyword "endif" <* many sp) + +define :: Parser Stmt +define = Define <$> (try (many sp *> keyword "define" *> many1 sp) *> identifier <* many1 sp) + <*> value <* many sp + +undef :: Parser Stmt +undef = Undef <$> (try (many sp *> keyword "undef" *> many1 sp) *> identifier <* many sp) -code :: Parser Stmt -code = try $ (char '#' "") *> fail "unknown directive" - <|> Code <$> manyTill anyChar (try (lookAhead (eol <|> eof))) +line :: Parser Stmt +line = do + sps <- many sp + try $ ((char '#' "") *> fail "unknown directive") + <|> ((Line . (sps ++)) <$> manyTill anyChar (try (lookAhead (eol <|> eof)))) keyword :: String -> Parser String keyword = string . ('#' :) condition :: Parser Cond -condition = (,,) <$> (identifier <* many sp) - <*> operator - <*> (many sp *> value) "condition" +condition = (Defined <$> (try (string "defined(") *> many sp *> identifier <* many sp <* char ')')) + <|> (Comp <$> (identifier <* many sp) <*> operator <*> (many sp *> value) "condition") identifier :: Parser String identifier = (:) <$> firstChar <*> many (firstChar <|> digit) "identifier" @@ -60,12 +74,12 @@ operator = choice [ Leq <$ try (string "<=") , Eq <$ string "==" ] "operator" -value :: Parser String -value = many1 digit +value :: Parser Int +value = many1 digit >>= return . read eol :: Parser () eol = endOfLine *> return () -sp :: Parser () +sp :: Parser Char sp = try $ lookAhead (eol *> unexpected "end of line" "") - <|> space *> return () + <|> space diff --git a/src/Curry/CondCompile/Type.hs b/src/Curry/CondCompile/Type.hs index f1ee3e6..f4ab36d 100644 --- a/src/Curry/CondCompile/Type.hs +++ b/src/Curry/CondCompile/Type.hs @@ -15,12 +15,17 @@ module Curry.CondCompile.Type where type Program = [Stmt] -data Stmt = If Cond [Stmt] (Maybe [Stmt]) - | IfDef String [Stmt] (Maybe [Stmt]) - | Code String +data Stmt = If Cond [Stmt] [(Cond, [Stmt])] (Maybe [Stmt]) + | IfDef String [Stmt] [(Cond, [Stmt])] (Maybe [Stmt]) + | IfNDef String [Stmt] [(Cond, [Stmt])] (Maybe [Stmt]) + | Define String Int + | Undef String + | Line String deriving Show -type Cond = (String, Op, String) +data Cond = Comp String Op Int + | Defined String + deriving Show data Op = Eq | Neq -- GitLab From 1effddbd2ea361a63c072273c377741ff7af2545 Mon Sep 17 00:00:00 2001 From: Kai Prott Date: Wed, 28 Jun 2017 22:45:43 +0200 Subject: [PATCH 07/19] Added CondCompile AST transformation --- src/Curry/CondCompile/CondTransform.hs | 95 ++++++++++++++++++++++++++ src/Curry/CondCompile/Type.hs | 1 + 2 files changed, 96 insertions(+) create mode 100644 src/Curry/CondCompile/CondTransform.hs diff --git a/src/Curry/CondCompile/CondTransform.hs b/src/Curry/CondCompile/CondTransform.hs new file mode 100644 index 0000000..c14648c --- /dev/null +++ b/src/Curry/CondCompile/CondTransform.hs @@ -0,0 +1,95 @@ +module Curry.CondCompile.CondTransform where + +import qualified Data.Map.Strict as Map +import Control.Monad.State +import Text.Parsec hiding (State(..)) +import CompilerOpts +import Curry.CondCompile.Parser +import Curry.CondCompile.Type + +type CondDict = State (Map.Map String (Maybe Int)) +type Dict = Map.Map String (Maybe Int) + +fillLengthP :: Program -> Int +fillLengthP = foldr (\a b -> fillLengthS a + b) 0 + +fillLengthS :: Stmt -> Int +fillLengthS (Line _ ) = 1 +fillLengthS (Define _ _) = 1 +fillLengthS (Undef _ ) = 1 +fillLengthS (If _ t eif e) = iflength t eif e +fillLengthS (IfDef _ t eif e) = iflength t eif e +fillLengthS (IfNDef _ t eif e) = iflength t eif e + +iflength :: [Stmt] -> [(Cond, [Stmt])] -> Maybe [Stmt] -> Int +iflength t e eif = fillLengthP t + fillLengthEI e + fillLengthE eif + 3 + +fillLengthEI :: [(Cond, [Stmt])] -> Int +fillLengthEI xs = fillLengthP (concat $ snd $ unzip xs) + length xs + +fillLengthE :: Maybe [Stmt] -> Int +fillLengthE (Just e) = fillLengthP e + 1 +fillLengthE Nothing = 0 + +condCompile :: Map.Map String (Maybe Int) -> Program -> String +condCompile m p = show (evalState (transformProgram p) m) + +transformProgram :: Program -> CondDict Program +transformProgram [] = return [] +transformProgram (x:xs) = do s <- transformStmt x + p <- transformProgram xs + return (s ++ p) + + +transformStmt :: Stmt -> CondDict [Stmt] +transformStmt (Line s) = return [Line s] +transformStmt (If c t i e) = do n <- expandFirstMatch ((c ,t):i) e + return (blank : n ++ [blank]) +transformStmt (IfDef v t i e) = do n <- expandFirstMatch ((Defined v,t):i) e + return (blank : n ++ [blank]) +transformStmt (IfNDef v t i e) = do n <- expandFirstMatch ((NDefined v,t):i) e + return (blank : n ++ [blank]) +transformStmt (Define s v) = do modify (Map.insert s (Just v)) + return [blank] +transformStmt (Undef s ) = do modify (Map.insert s Nothing) + return [blank] +blank :: Stmt +blank = Line "" + +expandFirstMatch :: [(Cond, [Stmt])] -> Maybe [Stmt] -> CondDict [Stmt] +expandFirstMatch [] e = transformElse e +expandFirstMatch ((c, p) : xs) e = do m <- get + workaround (checkCondOpt c m) ((c, p) : xs) e + +workaround :: Bool -> [(Cond, [Stmt])] -> Maybe [Stmt] -> CondDict [Stmt] +workaround True ((c, p) : xs) e = do n <- transformProgram p + return (n ++ fillElseIf xs ++ fillElse e) +workaround False ((c, p) : xs) e = do n <- expandFirstMatch xs e + return (fillElseIf [(c, p)] ++ n) + +transformElse :: Maybe [Stmt] -> CondDict [Stmt] +transformElse (Just p) = do n <- transformProgram p + return (blank : n) +transformElse Nothing = return [] + +fillElse :: Maybe [Stmt] -> [Stmt] +fillElse e = replicate (fillLengthE e) blank + +fillElseIf :: [(Cond, [Stmt])] -> [Stmt] +fillElseIf xs = replicate (fillLengthEI xs) blank + +checkCondOpt :: Cond -> Dict -> Bool +checkCondOpt (Comp s o c) m = case Map.lookup s m of + (Just (Just x)) -> compareWith x o c + _ -> False +checkCondOpt (Defined s) m = Map.member s m +checkCondOpt (NDefined s) m = not $ Map.member s m + + +compareWith :: Int -> Op -> Int -> Bool +compareWith v Eq c = v == c +compareWith v Neq c = v /= c +compareWith v Lt c = v < c +compareWith v Leq c = v <= c +compareWith v Gt c = v > c +compareWith v Geq c = v >= c diff --git a/src/Curry/CondCompile/Type.hs b/src/Curry/CondCompile/Type.hs index f4ab36d..968a485 100644 --- a/src/Curry/CondCompile/Type.hs +++ b/src/Curry/CondCompile/Type.hs @@ -25,6 +25,7 @@ data Stmt = If Cond [Stmt] [(Cond, [Stmt])] (Maybe [Stmt]) data Cond = Comp String Op Int | Defined String + | NDefined String deriving Show data Op = Eq -- GitLab From 68b0481870377f21e2db136eac7340997027f950 Mon Sep 17 00:00:00 2001 From: Kai Prott Date: Thu, 29 Jun 2017 09:43:04 +0200 Subject: [PATCH 08/19] cleanup and pretty instance part --- src/Curry/CondCompile/CondTransform.hs | 98 ++++++++++++++------------ src/Curry/CondCompile/Type.hs | 33 +++++++++ 2 files changed, 87 insertions(+), 44 deletions(-) diff --git a/src/Curry/CondCompile/CondTransform.hs b/src/Curry/CondCompile/CondTransform.hs index c14648c..7e25e87 100644 --- a/src/Curry/CondCompile/CondTransform.hs +++ b/src/Curry/CondCompile/CondTransform.hs @@ -1,83 +1,63 @@ -module Curry.CondCompile.CondTransform where +module Curry.CondCompile.CondTransform (Dict, condCompile, runCondCompile, transformWith) where import qualified Data.Map.Strict as Map import Control.Monad.State -import Text.Parsec hiding (State(..)) -import CompilerOpts import Curry.CondCompile.Parser import Curry.CondCompile.Type -type CondDict = State (Map.Map String (Maybe Int)) +type DictState = State (Map.Map String (Maybe Int)) type Dict = Map.Map String (Maybe Int) -fillLengthP :: Program -> Int -fillLengthP = foldr (\a b -> fillLengthS a + b) 0 - -fillLengthS :: Stmt -> Int -fillLengthS (Line _ ) = 1 -fillLengthS (Define _ _) = 1 -fillLengthS (Undef _ ) = 1 -fillLengthS (If _ t eif e) = iflength t eif e -fillLengthS (IfDef _ t eif e) = iflength t eif e -fillLengthS (IfNDef _ t eif e) = iflength t eif e +condCompile :: Dict -> Program -> String +condCompile m p = fst $ runCondCompile m p -iflength :: [Stmt] -> [(Cond, [Stmt])] -> Maybe [Stmt] -> Int -iflength t e eif = fillLengthP t + fillLengthEI e + fillLengthE eif + 3 +runCondCompile :: Dict -> Program -> (String, Dict) +runCondCompile m p = (unlines $ map pretty s, d) + where (s, d) = transformWith m p -fillLengthEI :: [(Cond, [Stmt])] -> Int -fillLengthEI xs = fillLengthP (concat $ snd $ unzip xs) + length xs - -fillLengthE :: Maybe [Stmt] -> Int -fillLengthE (Just e) = fillLengthP e + 1 -fillLengthE Nothing = 0 +transformWith :: Dict -> Program -> (Program, Dict) +transformWith m p = runState (transformProgram p) m -condCompile :: Map.Map String (Maybe Int) -> Program -> String -condCompile m p = show (evalState (transformProgram p) m) - -transformProgram :: Program -> CondDict Program +--monadic concatMap? +transformProgram :: Program -> DictState Program transformProgram [] = return [] -transformProgram (x:xs) = do s <- transformStmt x - p <- transformProgram xs - return (s ++ p) +transformProgram (x : xs) = do s <- transformStmt x + p <- transformProgram xs + return (s ++ p) -transformStmt :: Stmt -> CondDict [Stmt] +-- note: putting the first condition inside the elif results in an additinal +-- blank from expandFirstMatch. Thus we do not add a blank for the "#if(ndef)" +transformStmt :: Stmt -> DictState [Stmt] transformStmt (Line s) = return [Line s] transformStmt (If c t i e) = do n <- expandFirstMatch ((c ,t):i) e - return (blank : n ++ [blank]) + return (n ++ [blank]) transformStmt (IfDef v t i e) = do n <- expandFirstMatch ((Defined v,t):i) e - return (blank : n ++ [blank]) + return (n ++ [blank]) transformStmt (IfNDef v t i e) = do n <- expandFirstMatch ((NDefined v,t):i) e - return (blank : n ++ [blank]) + return (n ++ [blank]) transformStmt (Define s v) = do modify (Map.insert s (Just v)) return [blank] transformStmt (Undef s ) = do modify (Map.insert s Nothing) return [blank] -blank :: Stmt -blank = Line "" -expandFirstMatch :: [(Cond, [Stmt])] -> Maybe [Stmt] -> CondDict [Stmt] +expandFirstMatch :: [(Cond, [Stmt])] -> Maybe [Stmt] -> DictState [Stmt] expandFirstMatch [] e = transformElse e expandFirstMatch ((c, p) : xs) e = do m <- get workaround (checkCondOpt c m) ((c, p) : xs) e -workaround :: Bool -> [(Cond, [Stmt])] -> Maybe [Stmt] -> CondDict [Stmt] +-- ifthenelse in do notation did not work somehow +workaround :: Bool -> [(Cond, [Stmt])] -> Maybe [Stmt] -> DictState [Stmt] workaround True ((c, p) : xs) e = do n <- transformProgram p return (n ++ fillElseIf xs ++ fillElse e) workaround False ((c, p) : xs) e = do n <- expandFirstMatch xs e return (fillElseIf [(c, p)] ++ n) -transformElse :: Maybe [Stmt] -> CondDict [Stmt] +transformElse :: Maybe [Stmt] -> DictState [Stmt] transformElse (Just p) = do n <- transformProgram p return (blank : n) transformElse Nothing = return [] -fillElse :: Maybe [Stmt] -> [Stmt] -fillElse e = replicate (fillLengthE e) blank - -fillElseIf :: [(Cond, [Stmt])] -> [Stmt] -fillElseIf xs = replicate (fillLengthEI xs) blank - checkCondOpt :: Cond -> Dict -> Bool checkCondOpt (Comp s o c) m = case Map.lookup s m of (Just (Just x)) -> compareWith x o c @@ -93,3 +73,33 @@ compareWith v Lt c = v < c compareWith v Leq c = v <= c compareWith v Gt c = v > c compareWith v Geq c = v >= c + +blank :: Stmt +blank = Line "" + +fillElse :: Maybe [Stmt] -> [Stmt] +fillElse e = replicate (fillLengthE e) blank + +fillElseIf :: [(Cond, [Stmt])] -> [Stmt] +fillElseIf xs = replicate (fillLengthEI xs) blank + +fillLengthP :: Program -> Int +fillLengthP = foldr ((+) . fillLengthS) 0 + +fillLengthS :: Stmt -> Int +fillLengthS (Line _ ) = 1 +fillLengthS (Define _ _) = 1 +fillLengthS (Undef _ ) = 1 +fillLengthS (If _ t eif e) = fillLengthIf t eif e +fillLengthS (IfDef _ t eif e) = fillLengthIf t eif e +fillLengthS (IfNDef _ t eif e) = fillLengthIf t eif e + +fillLengthIf :: [Stmt] -> [(Cond, [Stmt])] -> Maybe [Stmt] -> Int +fillLengthIf t e eif = fillLengthP t + fillLengthEI e + fillLengthE eif + 3 + +fillLengthEI :: [(Cond, [Stmt])] -> Int +fillLengthEI xs = fillLengthP (concat $ snd $ unzip xs) + length xs + +fillLengthE :: Maybe [Stmt] -> Int +fillLengthE (Just e) = fillLengthP e + 1 +fillLengthE Nothing = 0 diff --git a/src/Curry/CondCompile/Type.hs b/src/Curry/CondCompile/Type.hs index 968a485..b56ec91 100644 --- a/src/Curry/CondCompile/Type.hs +++ b/src/Curry/CondCompile/Type.hs @@ -35,3 +35,36 @@ data Op = Eq | Gt | Geq deriving Show + +class Pretty a where + pretty :: a -> String + +instance Pretty Stmt where + pretty (If c t i e) = prettyIf ("#if " ++ pretty c) t i e + pretty (IfDef s t i e) = prettyIf ("#ifdef" ++ s ) t i e + pretty (IfNDef s t i e) = prettyIf ("#ifndef" ++ s ) t i e + pretty (Define s i) = "#define " ++ s ++ " " ++ show i ++ "\n" + pretty (Undef s ) = "#undef " ++ s ++ "\n" + pretty (Line s ) = s ++ "\n" + +prettyIf pre t i e = pre ++ "\n" ++ + unlines (map pretty t) ++ "\n" ++ + unlines (map prettyElseIf i) ++ "\n" ++ + maybe "" (\xs -> "#else\n" ++ + unlines (map pretty xs) ++ "\n") e ++ + "#endif" ++ "\n" +prettyElseIf (c, p) = "#elif " ++ pretty c ++ "\n" ++ + unlines (map pretty p) ++ "\n" + +instance Pretty Cond where + pretty (Comp s o v) = s ++ " " ++ pretty o ++ " " ++ show v + pretty (Defined s) = "defined(" ++ s ++ ")" + pretty (NDefined s) = "undefined(" ++ s ++ ")" + +instance Pretty Op where + pretty Eq = "=" + pretty Neq = "!=" + pretty Lt = "<" + pretty Leq = "<=" + pretty Gt = ">" + pretty Geq = ">=" -- GitLab From a60f5ca105d6f082d62127f1f097b9321e06f557 Mon Sep 17 00:00:00 2001 From: Kai Prott Date: Fri, 30 Jun 2017 00:34:11 +0200 Subject: [PATCH 09/19] Reworked CondCompile with typeclasses --- curry-base.cabal | 1 + src/Curry/CondCompile/CondTransform.hs | 138 ++++++++++++------------- src/Curry/CondCompile/Pretty.hs | 44 ++++++++ src/Curry/CondCompile/Type.hs | 33 ------ 4 files changed, 113 insertions(+), 103 deletions(-) create mode 100644 src/Curry/CondCompile/Pretty.hs diff --git a/curry-base.cabal b/curry-base.cabal index 99f5935..ec1d6d0 100644 --- a/curry-base.cabal +++ b/curry-base.cabal @@ -46,6 +46,7 @@ Library mtl , containers , filepath + , extra >= 1.4.6 , parsec , pretty ghc-options: -Wall diff --git a/src/Curry/CondCompile/CondTransform.hs b/src/Curry/CondCompile/CondTransform.hs index 7e25e87..0b712a8 100644 --- a/src/Curry/CondCompile/CondTransform.hs +++ b/src/Curry/CondCompile/CondTransform.hs @@ -1,68 +1,69 @@ -module Curry.CondCompile.CondTransform (Dict, condCompile, runCondCompile, transformWith) where +module Curry.CondCompile.CondTransform (CCState, condCompile, runCondCompile, transformWith) where import qualified Data.Map.Strict as Map import Control.Monad.State import Curry.CondCompile.Parser import Curry.CondCompile.Type +import Curry.CondCompile.Pretty +import Curry.Base.Pretty -type DictState = State (Map.Map String (Maybe Int)) -type Dict = Map.Map String (Maybe Int) +type CCState = Map.Map String Int +type CCM = State Dict -condCompile :: Dict -> Program -> String +condCompile :: CCState -> Program -> String condCompile m p = fst $ runCondCompile m p -runCondCompile :: Dict -> Program -> (String, Dict) -runCondCompile m p = (unlines $ map pretty s, d) +runCondCompile :: CCState -> Program -> (String, CCState) +runCondCompile m p = (unlines $ map prettyShow s, d) where (s, d) = transformWith m p -transformWith :: Dict -> Program -> (Program, Dict) +transformWith :: CCState -> Program -> (Program, CCState) transformWith m p = runState (transformProgram p) m ---monadic concatMap? -transformProgram :: Program -> DictState Program -transformProgram [] = return [] -transformProgram (x : xs) = do s <- transformStmt x - p <- transformProgram xs - return (s ++ p) - - --- note: putting the first condition inside the elif results in an additinal --- blank from expandFirstMatch. Thus we do not add a blank for the "#if(ndef)" -transformStmt :: Stmt -> DictState [Stmt] -transformStmt (Line s) = return [Line s] -transformStmt (If c t i e) = do n <- expandFirstMatch ((c ,t):i) e - return (n ++ [blank]) -transformStmt (IfDef v t i e) = do n <- expandFirstMatch ((Defined v,t):i) e - return (n ++ [blank]) -transformStmt (IfNDef v t i e) = do n <- expandFirstMatch ((NDefined v,t):i) e - return (n ++ [blank]) -transformStmt (Define s v) = do modify (Map.insert s (Just v)) - return [blank] -transformStmt (Undef s ) = do modify (Map.insert s Nothing) - return [blank] - -expandFirstMatch :: [(Cond, [Stmt])] -> Maybe [Stmt] -> DictState [Stmt] -expandFirstMatch [] e = transformElse e +class CCTransform a where + transform :: a -> CCM [Stmt] + + -- note: putting the first condition inside the elif results in an additinal + -- blank from expandFirstMatch. Thus we do not add a blank for the "#if(ndef)" +instance CCTransform Stmt where + transform (Line s) = return [Line s] + transform (If c t i e) = do n <- expandFirstMatch ((c ,t):i) e + return (n ++ [blank]) + transform (IfDef v t i e) = do n <- expandFirstMatch ((Defined v,t):i) e + return (n ++ [blank]) + transform (IfNDef v t i e) = do n <- expandFirstMatch ((NDefined v,t):i) e + return (n ++ [blank]) + transform (Define s v) = do modify (Map.insert s (Just v)) + return [blank] + transform (Undef s ) = do modify (Map.remove s) + return [blank] + +instance CCTransform a => CCTransform [a] where + transform = concatMapM transform + + +instance CCTransform a => CCTransform [a] where + transform = concatMapM transform + +instance CCTransform a => CCTransform (Maybe a) where + transform (Just p) = do t <- transform p + return (blank : t) + transform Nothing = [] + +expandFirstMatch :: [(Cond, [Stmt])] -> Maybe [Stmt] -> CCM [Stmt] +expandFirstMatch [] e = transform e expandFirstMatch ((c, p) : xs) e = do m <- get - workaround (checkCondOpt c m) ((c, p) : xs) e + if checkCondOpt c m + then do n <- transform p + return (n ++ fill xs ++ fill e) + else do n <- expandFirstMatch xs e + return (fill [(c,p)] ++ n) --- ifthenelse in do notation did not work somehow -workaround :: Bool -> [(Cond, [Stmt])] -> Maybe [Stmt] -> DictState [Stmt] -workaround True ((c, p) : xs) e = do n <- transformProgram p - return (n ++ fillElseIf xs ++ fillElse e) -workaround False ((c, p) : xs) e = do n <- expandFirstMatch xs e - return (fillElseIf [(c, p)] ++ n) - -transformElse :: Maybe [Stmt] -> DictState [Stmt] -transformElse (Just p) = do n <- transformProgram p - return (blank : n) -transformElse Nothing = return [] - -checkCondOpt :: Cond -> Dict -> Bool +checkCondOpt :: Cond -> CCState -> Bool checkCondOpt (Comp s o c) m = case Map.lookup s m of - (Just (Just x)) -> compareWith x o c - _ -> False -checkCondOpt (Defined s) m = Map.member s m + (Just x) -> compareWith x o c + Nothing -> compareWith 0 o c +checkCondOpt (Defined s) m = Map.member s m checkCondOpt (NDefined s) m = not $ Map.member s m @@ -77,29 +78,26 @@ compareWith v Geq c = v >= c blank :: Stmt blank = Line "" -fillElse :: Maybe [Stmt] -> [Stmt] -fillElse e = replicate (fillLengthE e) blank - -fillElseIf :: [(Cond, [Stmt])] -> [Stmt] -fillElseIf xs = replicate (fillLengthEI xs) blank +class FillLength a where + fillLength :: a -> Int -fillLengthP :: Program -> Int -fillLengthP = foldr ((+) . fillLengthS) 0 +instance FillLength Stmt where + fillLength (Line _ ) = 1 + fillLength (Define _ _) = 1 + fillLength (Undef _ ) = 1 + fillLength (If _ t i e) = fillLength t + fillLength e + fillLength i + 3 + fillLength (IfDef s t i e) = fillLength (If ( Defined s) t i e) + fillLength (IfNDef s t i e) = fillLength (If (NDefined s) t i e) -fillLengthS :: Stmt -> Int -fillLengthS (Line _ ) = 1 -fillLengthS (Define _ _) = 1 -fillLengthS (Undef _ ) = 1 -fillLengthS (If _ t eif e) = fillLengthIf t eif e -fillLengthS (IfDef _ t eif e) = fillLengthIf t eif e -fillLengthS (IfNDef _ t eif e) = fillLengthIf t eif e +instance FillLength a => FillLength [a] where + fillLength xs = foldr ((+) . fillLength) 0 -fillLengthIf :: [Stmt] -> [(Cond, [Stmt])] -> Maybe [Stmt] -> Int -fillLengthIf t e eif = fillLengthP t + fillLengthEI e + fillLengthE eif + 3 +instance FillLength a => FillLength (Maybe a) where + fillLength (Just p) = fillLength p + 1 + fillLength Nothing = 0 -fillLengthEI :: [(Cond, [Stmt])] -> Int -fillLengthEI xs = fillLengthP (concat $ snd $ unzip xs) + length xs +instance FillLength a => FillLength [(b, [a])] where + fillLength xs = fillLength (concat $ snd $ unzip xs) + length xs -fillLengthE :: Maybe [Stmt] -> Int -fillLengthE (Just e) = fillLengthP e + 1 -fillLengthE Nothing = 0 +fill :: FillLength a => a -> [Stmt] +fill p = replicate (fillLength p) blank diff --git a/src/Curry/CondCompile/Pretty.hs b/src/Curry/CondCompile/Pretty.hs new file mode 100644 index 0000000..fa43805 --- /dev/null +++ b/src/Curry/CondCompile/Pretty.hs @@ -0,0 +1,44 @@ +module Curry.CondCompile.Pretty where + +import Curry.Base.Pretty + +instance Pretty Stmt where + pPrint (If c t i e) = prettyIf ("#if " ++ pretty c) t i e + pPrint (IfDef s t i e) = prettyIf ("#ifdef " ++ s ) t i e + pPrint (IfNDef s t i e) = prettyIf ("#ifndef " ++ s ) t i e + pPrint (Define s i) = "#define" <+> text s <+> int i <> char '\n' + pPrint (Undef s ) = "#undef" <+> text s <> char '\n' + pPrint (Line s ) = text s <> char '\n' + + pPrintList = foldr (\ x -> (pPrint x <>)) empty + +instance Pretty a b => Pretty (a, [b]) where + pPrint (c, p) = text "#elif " <+> pPrint c <> char 'n' <> + pPrintList p + + pPrintList = foldr (\ x -> (pPrint x <>)) empty + + +instance Pretty a => Pretty (Maybe [a]) where + pPrint Just xs = text "#else\n" <> + pPrintList xs + pPrint Nothing = empty + +prettyIf :: String -> [Stmt] -> [(Cond, [Stmt])] -> Maybe [Stmt] -> Doc +prettyIf pre t i e = text pre <> char '\n' <> + pPrintList t <> + pPrintList i <> + pPrint e <> text "#endif\n" + +instance Pretty Cond where + pPrint (Comp s o v) = text s <+> pPrint o <+> int v + pPrint (Defined s) = text "defined(" <> text s <> char ')' + pPrint (NDefined s) = text "!defined(" <> text s <> char ')' + +instance Pretty Op where + pPrint Eq = text "=" + pPrint Neq = text "/=" + pPrint Lt = text "<" + pPrint Leq = text "<=" + pPrint Gt = text ">" + pPrint Geq = text ">=" diff --git a/src/Curry/CondCompile/Type.hs b/src/Curry/CondCompile/Type.hs index b56ec91..968a485 100644 --- a/src/Curry/CondCompile/Type.hs +++ b/src/Curry/CondCompile/Type.hs @@ -35,36 +35,3 @@ data Op = Eq | Gt | Geq deriving Show - -class Pretty a where - pretty :: a -> String - -instance Pretty Stmt where - pretty (If c t i e) = prettyIf ("#if " ++ pretty c) t i e - pretty (IfDef s t i e) = prettyIf ("#ifdef" ++ s ) t i e - pretty (IfNDef s t i e) = prettyIf ("#ifndef" ++ s ) t i e - pretty (Define s i) = "#define " ++ s ++ " " ++ show i ++ "\n" - pretty (Undef s ) = "#undef " ++ s ++ "\n" - pretty (Line s ) = s ++ "\n" - -prettyIf pre t i e = pre ++ "\n" ++ - unlines (map pretty t) ++ "\n" ++ - unlines (map prettyElseIf i) ++ "\n" ++ - maybe "" (\xs -> "#else\n" ++ - unlines (map pretty xs) ++ "\n") e ++ - "#endif" ++ "\n" -prettyElseIf (c, p) = "#elif " ++ pretty c ++ "\n" ++ - unlines (map pretty p) ++ "\n" - -instance Pretty Cond where - pretty (Comp s o v) = s ++ " " ++ pretty o ++ " " ++ show v - pretty (Defined s) = "defined(" ++ s ++ ")" - pretty (NDefined s) = "undefined(" ++ s ++ ")" - -instance Pretty Op where - pretty Eq = "=" - pretty Neq = "!=" - pretty Lt = "<" - pretty Leq = "<=" - pretty Gt = ">" - pretty Geq = ">=" -- GitLab From 174360f887546e504fc11a43d252da77bf0bc4c8 Mon Sep 17 00:00:00 2001 From: Kai Prott Date: Fri, 30 Jun 2017 01:36:59 +0200 Subject: [PATCH 10/19] Fixed compile errors --- src/Curry/CondCompile/CondTransform.hs | 28 +++++++------- src/Curry/CondCompile/Parser.hs | 5 ++- src/Curry/CondCompile/Pretty.hs | 51 ++++++++++++++++---------- 3 files changed, 47 insertions(+), 37 deletions(-) diff --git a/src/Curry/CondCompile/CondTransform.hs b/src/Curry/CondCompile/CondTransform.hs index 0b712a8..4c22463 100644 --- a/src/Curry/CondCompile/CondTransform.hs +++ b/src/Curry/CondCompile/CondTransform.hs @@ -2,23 +2,22 @@ module Curry.CondCompile.CondTransform (CCState, condCompile, runCondCompile, tr import qualified Data.Map.Strict as Map import Control.Monad.State +import Control.Monad.Extra (concatMapM) import Curry.CondCompile.Parser import Curry.CondCompile.Type import Curry.CondCompile.Pretty -import Curry.Base.Pretty type CCState = Map.Map String Int -type CCM = State Dict +type CCM = State CCState condCompile :: CCState -> Program -> String condCompile m p = fst $ runCondCompile m p runCondCompile :: CCState -> Program -> (String, CCState) -runCondCompile m p = (unlines $ map prettyShow s, d) - where (s, d) = transformWith m p +runCondCompile m p = mapFst prettyShow (runState (transform p) m) transformWith :: CCState -> Program -> (Program, CCState) -transformWith m p = runState (transformProgram p) m +transformWith m p = runState (transform p) m class CCTransform a where transform :: a -> CCM [Stmt] @@ -33,22 +32,18 @@ instance CCTransform Stmt where return (n ++ [blank]) transform (IfNDef v t i e) = do n <- expandFirstMatch ((NDefined v,t):i) e return (n ++ [blank]) - transform (Define s v) = do modify (Map.insert s (Just v)) + transform (Define s v) = do modify (Map.insert s v) return [blank] - transform (Undef s ) = do modify (Map.remove s) + transform (Undef s ) = do modify (Map.delete s) return [blank] -instance CCTransform a => CCTransform [a] where - transform = concatMapM transform - - instance CCTransform a => CCTransform [a] where transform = concatMapM transform instance CCTransform a => CCTransform (Maybe a) where transform (Just p) = do t <- transform p return (blank : t) - transform Nothing = [] + transform Nothing = return [] expandFirstMatch :: [(Cond, [Stmt])] -> Maybe [Stmt] -> CCM [Stmt] expandFirstMatch [] e = transform e @@ -90,14 +85,17 @@ instance FillLength Stmt where fillLength (IfNDef s t i e) = fillLength (If (NDefined s) t i e) instance FillLength a => FillLength [a] where - fillLength xs = foldr ((+) . fillLength) 0 + fillLength = foldr ((+) . fillLength) 0 instance FillLength a => FillLength (Maybe a) where fillLength (Just p) = fillLength p + 1 fillLength Nothing = 0 -instance FillLength a => FillLength [(b, [a])] where - fillLength xs = fillLength (concat $ snd $ unzip xs) + length xs +instance FillLength a => FillLength (b, a) where + fillLength (_, xs) = fillLength xs + 1 fill :: FillLength a => a -> [Stmt] fill p = replicate (fillLength p) blank + +mapFst :: (a -> b) -> (a, c) -> (b, c) +mapFst f (a, b) = (f a, b) diff --git a/src/Curry/CondCompile/Parser.hs b/src/Curry/CondCompile/Parser.hs index 2a3372a..02d942d 100644 --- a/src/Curry/CondCompile/Parser.hs +++ b/src/Curry/CondCompile/Parser.hs @@ -58,7 +58,8 @@ keyword :: String -> Parser String keyword = string . ('#' :) condition :: Parser Cond -condition = (Defined <$> (try (string "defined(") *> many sp *> identifier <* many sp <* char ')')) +condition = ( Defined <$> (try (string "defined(") *> many sp *> identifier <* many sp <* char ')')) + <|> (NDefined <$> (try (string "!defined(") *> many sp *> identifier <* many sp <* char ')')) <|> (Comp <$> (identifier <* many sp) <*> operator <*> (many sp *> value) "condition") identifier :: Parser String @@ -75,7 +76,7 @@ operator = choice [ Leq <$ try (string "<=") ] "operator" value :: Parser Int -value = many1 digit >>= return . read +value = fmap read (many1 digit) eol :: Parser () eol = endOfLine *> return () diff --git a/src/Curry/CondCompile/Pretty.hs b/src/Curry/CondCompile/Pretty.hs index fa43805..07a4923 100644 --- a/src/Curry/CondCompile/Pretty.hs +++ b/src/Curry/CondCompile/Pretty.hs @@ -1,31 +1,42 @@ -module Curry.CondCompile.Pretty where +module Curry.CondCompile.Pretty (Pretty(pPrint, pPrintList), prettyShow) where -import Curry.Base.Pretty - -instance Pretty Stmt where - pPrint (If c t i e) = prettyIf ("#if " ++ pretty c) t i e - pPrint (IfDef s t i e) = prettyIf ("#ifdef " ++ s ) t i e - pPrint (IfNDef s t i e) = prettyIf ("#ifndef " ++ s ) t i e - pPrint (Define s i) = "#define" <+> text s <+> int i <> char '\n' - pPrint (Undef s ) = "#undef" <+> text s <> char '\n' - pPrint (Line s ) = text s <> char '\n' +import Text.PrettyPrint +import Curry.CondCompile.Type +class Pretty a where + -- | Pretty-print something in isolation. + pPrint :: a -> Doc + -- |Pretty-print a list. + pPrintList :: [a] -> Doc pPrintList = foldr (\ x -> (pPrint x <>)) empty -instance Pretty a b => Pretty (a, [b]) where - pPrint (c, p) = text "#elif " <+> pPrint c <> char 'n' <> - pPrintList p +-- | Pretty print a value to a 'String'. +prettyShow :: Pretty a => a -> String +prettyShow = render . pPrint - pPrintList = foldr (\ x -> (pPrint x <>)) empty +instance Pretty Stmt where + pPrint (If c t i e) = prettyIf (text "#if" <+> pPrint c) t i e + pPrint (IfDef s t i e) = prettyIf (text "#ifdef" <+> text s ) t i e + pPrint (IfNDef s t i e) = prettyIf (text "#ifndef" <+> text s ) t i e + pPrint (Define s i) = text "#define" <+> text s <+> int i <> char '\n' + pPrint (Undef s ) = text "#undef" <+> text s <> char '\n' + pPrint (Line s ) = text s <> char '\n' + +instance (Pretty a, Pretty b) => Pretty (a, b) where + pPrint (c, p) = text "#elif " <+> pPrint c <> char 'n' <> + pPrint p +instance Pretty a => Pretty (Maybe a) where + pPrint (Just xs) = text "#else\n" <> + pPrint xs + pPrint Nothing = empty -instance Pretty a => Pretty (Maybe [a]) where - pPrint Just xs = text "#else\n" <> - pPrintList xs - pPrint Nothing = empty +-- | Instance for '[]' +instance (Pretty a) => Pretty [a] where + pPrint = pPrintList -prettyIf :: String -> [Stmt] -> [(Cond, [Stmt])] -> Maybe [Stmt] -> Doc -prettyIf pre t i e = text pre <> char '\n' <> +prettyIf :: Doc -> [Stmt] -> [(Cond, [Stmt])] -> Maybe [Stmt] -> Doc +prettyIf pre t i e = pre <> char '\n' <> pPrintList t <> pPrintList i <> pPrint e <> text "#endif\n" -- GitLab From 8626f764398f4a5df4e424789d1aa390153f9070 Mon Sep 17 00:00:00 2001 From: Kai Prott Date: Fri, 30 Jun 2017 19:34:30 +0200 Subject: [PATCH 11/19] Fixed #if missing blank line on transform and added exampleString for transform --- src/Curry/CondCompile/CondTransform.hs | 32 ++++++++++++++------------ src/Curry/CondCompile/Parser.hs | 2 ++ src/Curry/CondCompile/Pretty.hs | 2 +- 3 files changed, 20 insertions(+), 16 deletions(-) diff --git a/src/Curry/CondCompile/CondTransform.hs b/src/Curry/CondCompile/CondTransform.hs index 4c22463..5a7e656 100644 --- a/src/Curry/CondCompile/CondTransform.hs +++ b/src/Curry/CondCompile/CondTransform.hs @@ -3,6 +3,7 @@ module Curry.CondCompile.CondTransform (CCState, condCompile, runCondCompile, tr import qualified Data.Map.Strict as Map import Control.Monad.State import Control.Monad.Extra (concatMapM) +import Text.Parsec (parse) import Curry.CondCompile.Parser import Curry.CondCompile.Type import Curry.CondCompile.Pretty @@ -26,12 +27,22 @@ class CCTransform a where -- blank from expandFirstMatch. Thus we do not add a blank for the "#if(ndef)" instance CCTransform Stmt where transform (Line s) = return [Line s] - transform (If c t i e) = do n <- expandFirstMatch ((c ,t):i) e - return (n ++ [blank]) - transform (IfDef v t i e) = do n <- expandFirstMatch ((Defined v,t):i) e - return (n ++ [blank]) - transform (IfNDef v t i e) = do n <- expandFirstMatch ((NDefined v,t):i) e - return (n ++ [blank]) + transform (If c t i e) = do m <- get + if checkCondOpt c m + then do n <- transform t + return (blank : n ++ fill i + ++ fill e ++ [blank]) + else case i of + [] -> do n <- transform e + return (blank : fill t + ++ n ++ [blank]) + ((nc, p) : xs) -> do n <- transform + (If nc p xs e) + return (blank : + fill t + ++ n) + transform (IfDef v t i e) = transform (If ( Defined v) t i e) + transform (IfNDef v t i e) = transform (If (NDefined v) t i e) transform (Define s v) = do modify (Map.insert s v) return [blank] transform (Undef s ) = do modify (Map.delete s) @@ -45,15 +56,6 @@ instance CCTransform a => CCTransform (Maybe a) where return (blank : t) transform Nothing = return [] -expandFirstMatch :: [(Cond, [Stmt])] -> Maybe [Stmt] -> CCM [Stmt] -expandFirstMatch [] e = transform e -expandFirstMatch ((c, p) : xs) e = do m <- get - if checkCondOpt c m - then do n <- transform p - return (n ++ fill xs ++ fill e) - else do n <- expandFirstMatch xs e - return (fill [(c,p)] ++ n) - checkCondOpt :: Cond -> CCState -> Bool checkCondOpt (Comp s o c) m = case Map.lookup s m of (Just x) -> compareWith x o c diff --git a/src/Curry/CondCompile/Parser.hs b/src/Curry/CondCompile/Parser.hs index 02d942d..baacf35 100644 --- a/src/Curry/CondCompile/Parser.hs +++ b/src/Curry/CondCompile/Parser.hs @@ -19,6 +19,8 @@ import Curry.CondCompile.Type type Parser a = Parsec String () a +example = "#if value < 3\n#ifdef nope\nnope\n#else\nyes\n#endif\n#elif value > 3\nthree\n#endif\nline" + program :: Parser Program program = statement `sepBy` eol <* eof diff --git a/src/Curry/CondCompile/Pretty.hs b/src/Curry/CondCompile/Pretty.hs index 07a4923..c45541b 100644 --- a/src/Curry/CondCompile/Pretty.hs +++ b/src/Curry/CondCompile/Pretty.hs @@ -23,7 +23,7 @@ instance Pretty Stmt where pPrint (Line s ) = text s <> char '\n' instance (Pretty a, Pretty b) => Pretty (a, b) where - pPrint (c, p) = text "#elif " <+> pPrint c <> char 'n' <> + pPrint (c, p) = text "#elif " <+> pPrint c <> char '\n' <> pPrint p instance Pretty a => Pretty (Maybe a) where -- GitLab From e0ea2f897a7a5ac02823406d284529764508ddf3 Mon Sep 17 00:00:00 2001 From: Kai Prott Date: Sat, 1 Jul 2017 14:02:26 +0200 Subject: [PATCH 12/19] Using newtype to redefine Maybe and tuple instances for pretty --- src/Curry/CondCompile/CondTransform.hs | 27 ++++++++-------- src/Curry/CondCompile/Parser.hs | 10 +++--- src/Curry/CondCompile/Pretty.hs | 44 ++++++++++---------------- src/Curry/CondCompile/Type.hs | 11 +++++-- 4 files changed, 43 insertions(+), 49 deletions(-) diff --git a/src/Curry/CondCompile/CondTransform.hs b/src/Curry/CondCompile/CondTransform.hs index 5a7e656..ab678df 100644 --- a/src/Curry/CondCompile/CondTransform.hs +++ b/src/Curry/CondCompile/CondTransform.hs @@ -4,6 +4,7 @@ import qualified Data.Map.Strict as Map import Control.Monad.State import Control.Monad.Extra (concatMapM) import Text.Parsec (parse) +import Curry.Base.Pretty import Curry.CondCompile.Parser import Curry.CondCompile.Type import Curry.CondCompile.Pretty @@ -36,11 +37,9 @@ instance CCTransform Stmt where [] -> do n <- transform e return (blank : fill t ++ n ++ [blank]) - ((nc, p) : xs) -> do n <- transform - (If nc p xs e) - return (blank : - fill t - ++ n) + (Elif (nc, p) : xs) + -> do n <- transform (If nc p xs e) + return (blank : fill t ++ n) transform (IfDef v t i e) = transform (If ( Defined v) t i e) transform (IfNDef v t i e) = transform (If (NDefined v) t i e) transform (Define s v) = do modify (Map.insert s v) @@ -51,10 +50,10 @@ instance CCTransform Stmt where instance CCTransform a => CCTransform [a] where transform = concatMapM transform -instance CCTransform a => CCTransform (Maybe a) where - transform (Just p) = do t <- transform p - return (blank : t) - transform Nothing = return [] +instance CCTransform Else where + transform (Else (Just p)) = do t <- transform p + return (blank : t) + transform (Else Nothing) = return [] checkCondOpt :: Cond -> CCState -> Bool checkCondOpt (Comp s o c) m = case Map.lookup s m of @@ -89,12 +88,12 @@ instance FillLength Stmt where instance FillLength a => FillLength [a] where fillLength = foldr ((+) . fillLength) 0 -instance FillLength a => FillLength (Maybe a) where - fillLength (Just p) = fillLength p + 1 - fillLength Nothing = 0 +instance FillLength Else where + fillLength (Else (Just p)) = fillLength p + 1 + fillLength (Else Nothing) = 0 -instance FillLength a => FillLength (b, a) where - fillLength (_, xs) = fillLength xs + 1 +instance FillLength Elif where + fillLength (Elif (_, xs)) = fillLength xs + 1 fill :: FillLength a => a -> [Stmt] fill p = replicate (fillLength p) blank diff --git a/src/Curry/CondCompile/Parser.hs b/src/Curry/CondCompile/Parser.hs index baacf35..3f0f01f 100644 --- a/src/Curry/CondCompile/Parser.hs +++ b/src/Curry/CondCompile/Parser.hs @@ -33,14 +33,14 @@ statement = ifElse "if" condition If <|> line ifElse :: String -> Parser a - -> (a -> [Stmt] -> [(Cond, [Stmt])] -> Maybe [Stmt] -> Stmt) + -> (a -> [Stmt] -> [Elif] -> Else -> Stmt) -> Parser Stmt ifElse k p c = c <$> (try (many sp *> keyword k *> many1 sp) *> p <* many sp <* eol) <*> many (statement <* eol) - <*> many ((,) <$> (try (many sp *> keyword "elif" *> many1 sp) *> condition <* many sp <* eol) - <*> many (statement <* eol)) - <*> optionMaybe - (try (many sp *> keyword "else" *> many sp) *> eol *> many (statement <* eol)) + <*> many (Elif <$> ((,) <$> (try (many sp *> keyword "elif" *> many1 sp) *> condition <* many sp <* eol) + <*> many (statement <* eol))) + <*> (Else <$> optionMaybe + (try (many sp *> keyword "else" *> many sp) *> eol *> many (statement <* eol))) <* try (many sp <* keyword "endif" <* many sp) define :: Parser Stmt diff --git a/src/Curry/CondCompile/Pretty.hs b/src/Curry/CondCompile/Pretty.hs index c45541b..aa5190d 100644 --- a/src/Curry/CondCompile/Pretty.hs +++ b/src/Curry/CondCompile/Pretty.hs @@ -1,18 +1,8 @@ -module Curry.CondCompile.Pretty (Pretty(pPrint, pPrintList), prettyShow) where +module Curry.CondCompile.Pretty (Pretty(pPrint, pPrintList)) where -import Text.PrettyPrint +import Curry.Base.Pretty import Curry.CondCompile.Type -class Pretty a where - -- | Pretty-print something in isolation. - pPrint :: a -> Doc - -- |Pretty-print a list. - pPrintList :: [a] -> Doc - pPrintList = foldr (\ x -> (pPrint x <>)) empty - --- | Pretty print a value to a 'String'. -prettyShow :: Pretty a => a -> String -prettyShow = render . pPrint instance Pretty Stmt where pPrint (If c t i e) = prettyIf (text "#if" <+> pPrint c) t i e @@ -22,24 +12,24 @@ instance Pretty Stmt where pPrint (Undef s ) = text "#undef" <+> text s <> char '\n' pPrint (Line s ) = text s <> char '\n' -instance (Pretty a, Pretty b) => Pretty (a, b) where - pPrint (c, p) = text "#elif " <+> pPrint c <> char '\n' <> - pPrint p + pPrintList = foldr ((<>) . pPrint) empty + +instance Pretty Elif where + pPrint (Elif (c, p)) = text "#elif " <+> pPrint c <> char '\n' <> + pPrint p -instance Pretty a => Pretty (Maybe a) where - pPrint (Just xs) = text "#else\n" <> - pPrint xs - pPrint Nothing = empty + pPrintList = foldr ((<>) . pPrint) empty --- | Instance for '[]' -instance (Pretty a) => Pretty [a] where - pPrint = pPrintList +instance Pretty Else where + pPrint (Else (Just xs)) = text "#else\n" <> + pPrint xs + pPrint (Else Nothing) = empty -prettyIf :: Doc -> [Stmt] -> [(Cond, [Stmt])] -> Maybe [Stmt] -> Doc -prettyIf pre t i e = pre <> char '\n' <> - pPrintList t <> - pPrintList i <> - pPrint e <> text "#endif\n" +prettyIf :: Doc -> [Stmt] -> [Elif] -> Else -> Doc +prettyIf pre t i e = pre <> char '\n' <> + pPrint t <> + pPrint i <> + pPrint e <> text "#endif\n" instance Pretty Cond where pPrint (Comp s o v) = text s <+> pPrint o <+> int v diff --git a/src/Curry/CondCompile/Type.hs b/src/Curry/CondCompile/Type.hs index 968a485..62913b0 100644 --- a/src/Curry/CondCompile/Type.hs +++ b/src/Curry/CondCompile/Type.hs @@ -15,9 +15,14 @@ module Curry.CondCompile.Type where type Program = [Stmt] -data Stmt = If Cond [Stmt] [(Cond, [Stmt])] (Maybe [Stmt]) - | IfDef String [Stmt] [(Cond, [Stmt])] (Maybe [Stmt]) - | IfNDef String [Stmt] [(Cond, [Stmt])] (Maybe [Stmt]) +newtype Else = Else (Maybe [Stmt]) + deriving Show +newtype Elif = Elif (Cond, [Stmt]) + deriving Show + +data Stmt = If Cond [Stmt] [Elif] Else + | IfDef String [Stmt] [Elif] Else + | IfNDef String [Stmt] [Elif] Else | Define String Int | Undef String | Line String -- GitLab From b8d5a2ed91ae533c4e2ae63bcbf737d8f3c78f1c Mon Sep 17 00:00:00 2001 From: Kai Prott Date: Sun, 2 Jul 2017 17:12:21 +0200 Subject: [PATCH 13/19] Now using $+$ for newline seperation --- src/Curry/CondCompile/Pretty.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/Curry/CondCompile/Pretty.hs b/src/Curry/CondCompile/Pretty.hs index aa5190d..6a7cfbe 100644 --- a/src/Curry/CondCompile/Pretty.hs +++ b/src/Curry/CondCompile/Pretty.hs @@ -1,4 +1,4 @@ -module Curry.CondCompile.Pretty (Pretty(pPrint, pPrintList)) where +module Curry.CondCompile.Pretty(Pretty(pPrint, pPrintList)) where import Curry.Base.Pretty import Curry.CondCompile.Type @@ -8,28 +8,29 @@ instance Pretty Stmt where pPrint (If c t i e) = prettyIf (text "#if" <+> pPrint c) t i e pPrint (IfDef s t i e) = prettyIf (text "#ifdef" <+> text s ) t i e pPrint (IfNDef s t i e) = prettyIf (text "#ifndef" <+> text s ) t i e - pPrint (Define s i) = text "#define" <+> text s <+> int i <> char '\n' - pPrint (Undef s ) = text "#undef" <+> text s <> char '\n' - pPrint (Line s ) = text s <> char '\n' + pPrint (Define s i) = text "#define" <+> text s <+> int i + pPrint (Undef s ) = text "#undef" <+> text s + pPrint (Line s ) = text s - pPrintList = foldr ((<>) . pPrint) empty + pPrintList = foldr (($+$) . pPrint) empty instance Pretty Elif where - pPrint (Elif (c, p)) = text "#elif " <+> pPrint c <> char '\n' <> + pPrint (Elif (c, p)) = text "#elif " <+> pPrint c $+$ pPrint p - pPrintList = foldr ((<>) . pPrint) empty + pPrintList = foldr (($+$) . pPrint) empty instance Pretty Else where - pPrint (Else (Just xs)) = text "#else\n" <> + pPrint (Else (Just xs)) = text "#else" $+$ pPrint xs pPrint (Else Nothing) = empty prettyIf :: Doc -> [Stmt] -> [Elif] -> Else -> Doc -prettyIf pre t i e = pre <> char '\n' <> - pPrint t <> - pPrint i <> - pPrint e <> text "#endif\n" +prettyIf pre t i e = pre $+$ + pPrint t $+$ + pPrint i $+$ + pPrint e $+$ + text "#endif" instance Pretty Cond where pPrint (Comp s o v) = text s <+> pPrint o <+> int v -- GitLab From f92035545b4c1785d71ddb06ef3851087fe5a43e Mon Sep 17 00:00:00 2001 From: Kai Prott Date: Sun, 2 Jul 2017 17:13:10 +0200 Subject: [PATCH 14/19] Fixed rendering of doc to string --- src/Curry/CondCompile/CondTransform.hs | 30 ++++++++++++++++++++------ 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/src/Curry/CondCompile/CondTransform.hs b/src/Curry/CondCompile/CondTransform.hs index ab678df..6902bd3 100644 --- a/src/Curry/CondCompile/CondTransform.hs +++ b/src/Curry/CondCompile/CondTransform.hs @@ -3,8 +3,11 @@ module Curry.CondCompile.CondTransform (CCState, condCompile, runCondCompile, tr import qualified Data.Map.Strict as Map import Control.Monad.State import Control.Monad.Extra (concatMapM) -import Text.Parsec (parse) +import Text.Parsec hiding (State) +import Text.Parsec.Error import Curry.Base.Pretty +import qualified Curry.Base.Message as CM +import Curry.Base.Position import Curry.CondCompile.Parser import Curry.CondCompile.Type import Curry.CondCompile.Pretty @@ -12,14 +15,27 @@ import Curry.CondCompile.Pretty type CCState = Map.Map String Int type CCM = State CCState -condCompile :: CCState -> Program -> String -condCompile m p = fst $ runCondCompile m p +test = readFile "/home/prott/curry/Test/Array.curry" >>= putStrLn . either show id . condCompile Map.empty "" -runCondCompile :: CCState -> Program -> (String, CCState) -runCondCompile m p = mapFst prettyShow (runState (transform p) m) +condCompile :: CCState -> FilePath -> String -> Either [CM.Message] String +condCompile m f p = do let e = parse program f p + either (Left . convertError) + (Right . runCondCompile m) e -transformWith :: CCState -> Program -> (Program, CCState) -transformWith m p = runState (transform p) m +runCondCompile :: CCState -> Program -> String +runCondCompile m p = fst $ transformWith m p + +transformWith :: CCState -> Program -> (String, CCState) +transformWith m p = mapFst (show . pPrint) (runState (transform p) m) + +instance HasPosition ParseError where + getPosition e = Position (sourceName p) + (sourceLine p) + (sourceColumn p) + where p = errorPos e + +convertError :: ParseError -> [CM.Message] +convertError e = map (\m -> CM.posMessage e (text $ messageString m)) (errorMessages e) class CCTransform a where transform :: a -> CCM [Stmt] -- GitLab From ba832ae1ee61eb0e601c7a3daeffcd3e3f609173 Mon Sep 17 00:00:00 2001 From: Kai Prott Date: Sun, 2 Jul 2017 17:13:50 +0200 Subject: [PATCH 15/19] Added CondTransform, Pretty to cabal --- curry-base.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/curry-base.cabal b/curry-base.cabal index ec1d6d0..19acc9a 100644 --- a/curry-base.cabal +++ b/curry-base.cabal @@ -64,6 +64,8 @@ Library Curry.Base.Span Curry.CondCompile.Parser Curry.CondCompile.Type + Curry.CondCompile.Pretty + Curry.CondCompile.CondTransform Curry.Files.Filenames Curry.Files.PathUtils Curry.Files.Unlit -- GitLab From e2e0f647ecb49977acc2d843bb9d0e50ff7a39be Mon Sep 17 00:00:00 2001 From: Finn Teegen Date: Thu, 6 Jul 2017 16:21:11 +0200 Subject: [PATCH 16/19] Refactor code for conditional compiling --- src/Curry/CondCompile/CondTransform.hs | 159 +++++++++++++------------ src/Curry/CondCompile/Parser.hs | 9 +- src/Curry/CondCompile/Type.hs | 12 +- 3 files changed, 91 insertions(+), 89 deletions(-) diff --git a/src/Curry/CondCompile/CondTransform.hs b/src/Curry/CondCompile/CondTransform.hs index 6902bd3..2e5dc5f 100644 --- a/src/Curry/CondCompile/CondTransform.hs +++ b/src/Curry/CondCompile/CondTransform.hs @@ -1,118 +1,119 @@ -module Curry.CondCompile.CondTransform (CCState, condCompile, runCondCompile, transformWith) where +{- | + Module : $Header$ + Description : Conditional compiling transformation + Copyright : (c) 2017 Kai-Oliver Prott + 2017 Finn Teegen + License : BSD-3-clause + + Maintainer : fte@informatik.uni-kiel.de + Stability : experimental + Portability : portable + + TODO +-} +module Curry.CondCompile.CondTransform + ( CCState, condCompile + ) where -import qualified Data.Map.Strict as Map import Control.Monad.State -import Control.Monad.Extra (concatMapM) -import Text.Parsec hiding (State) -import Text.Parsec.Error -import Curry.Base.Pretty -import qualified Curry.Base.Message as CM -import Curry.Base.Position -import Curry.CondCompile.Parser -import Curry.CondCompile.Type import Curry.CondCompile.Pretty +import Control.Monad.Extra (concatMapM) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Text.Parsec hiding (State) +import Text.Parsec.Error () -type CCState = Map.Map String Int -type CCM = State CCState +import Curry.Base.Message +import Curry.Base.Position test = readFile "/home/prott/curry/Test/Array.curry" >>= putStrLn . either show id . condCompile Map.empty "" +import Curry.CondCompile.Parser +import Curry.CondCompile.Type -condCompile :: CCState -> FilePath -> String -> Either [CM.Message] String -condCompile m f p = do let e = parse program f p - either (Left . convertError) - (Right . runCondCompile m) e +type CCState = Map.Map String Int -runCondCompile :: CCState -> Program -> String -runCondCompile m p = fst $ transformWith m p +type CCM = State CCState -transformWith :: CCState -> Program -> (String, CCState) -transformWith m p = mapFst (show . pPrint) (runState (transform p) m) +condCompile :: CCState -> FilePath -> String -> Either Message String +condCompile s fn p = either (Left . convertError) + (Right . transformWith s) + (parse program fn p) -instance HasPosition ParseError where - getPosition e = Position (sourceName p) - (sourceLine p) - (sourceColumn p) - where p = errorPos e +transformWith :: CCState -> Program -> String +transformWith s p = show $ pPrint $ evalState (transform p) s -convertError :: ParseError -> [CM.Message] -convertError e = map (\m -> CM.posMessage e (text $ messageString m)) (errorMessages e) +convertError :: ParseError -> Message +convertError err = posMessage pos $ + foldr ($+$) empty $ map text $ tail $ lines $ show err + where pos = Position (sourceName src) (sourceLine src) (sourceColumn src) + src = errorPos err class CCTransform a where transform :: a -> CCM [Stmt] - -- note: putting the first condition inside the elif results in an additinal - -- blank from expandFirstMatch. Thus we do not add a blank for the "#if(ndef)" instance CCTransform Stmt where - transform (Line s) = return [Line s] - transform (If c t i e) = do m <- get - if checkCondOpt c m - then do n <- transform t - return (blank : n ++ fill i - ++ fill e ++ [blank]) - else case i of - [] -> do n <- transform e - return (blank : fill t - ++ n ++ [blank]) - (Elif (nc, p) : xs) - -> do n <- transform (If nc p xs e) - return (blank : fill t ++ n) - transform (IfDef v t i e) = transform (If ( Defined v) t i e) - transform (IfNDef v t i e) = transform (If (NDefined v) t i e) - transform (Define s v) = do modify (Map.insert s v) - return [blank] - transform (Undef s ) = do modify (Map.delete s) - return [blank] + transform (Line s) = return [Line s] + transform (If c stmts is e) = do + s <- get + if checkCondOpt c s + then do stmts' <- transform stmts + return (blank : stmts' ++ fill is ++ fill e ++ [blank]) + else case is of + [] -> do + stmts' <- transform e + return (blank : fill stmts ++ stmts' ++ [blank]) + (Elif (c', stmts') : is') -> do + stmts'' <- transform (If c' stmts' is' e) + return (blank : fill stmts ++ stmts'') + transform (IfDef v stmts is e) = transform (If (Defined v) stmts is e) + transform (IfNDef v stmts is e) = transform (If (NDefined v) stmts is e) + transform (Define v i) = modify (Map.insert v i) >> return [blank] + transform (Undef v ) = modify (Map.delete v) >> return [blank] instance CCTransform a => CCTransform [a] where transform = concatMapM transform instance CCTransform Else where - transform (Else (Just p)) = do t <- transform p - return (blank : t) - transform (Else Nothing) = return [] + transform (Else (Just p)) = (blank :) <$> transform p + transform (Else Nothing ) = return [] checkCondOpt :: Cond -> CCState -> Bool -checkCondOpt (Comp s o c) m = case Map.lookup s m of - (Just x) -> compareWith x o c - Nothing -> compareWith 0 o c -checkCondOpt (Defined s) m = Map.member s m -checkCondOpt (NDefined s) m = not $ Map.member s m - - -compareWith :: Int -> Op -> Int -> Bool -compareWith v Eq c = v == c -compareWith v Neq c = v /= c -compareWith v Lt c = v < c -compareWith v Leq c = v <= c -compareWith v Gt c = v > c -compareWith v Geq c = v >= c - -blank :: Stmt -blank = Line "" +checkCondOpt (Comp v op i) = flip (compareOp op) i . fromMaybe 0 . Map.lookup v +checkCondOpt (Defined v) = Map.member v +checkCondOpt (NDefined v) = Map.notMember v + +compareOp :: Ord a => Op -> a -> a -> Bool +compareOp Eq = (==) +compareOp Neq = (/=) +compareOp Lt = (<) +compareOp Leq = (<=) +compareOp Gt = (>) +compareOp Geq = (>=) class FillLength a where fillLength :: a -> Int instance FillLength Stmt where - fillLength (Line _ ) = 1 - fillLength (Define _ _) = 1 - fillLength (Undef _ ) = 1 - fillLength (If _ t i e) = fillLength t + fillLength e + fillLength i + 3 - fillLength (IfDef s t i e) = fillLength (If ( Defined s) t i e) - fillLength (IfNDef s t i e) = fillLength (If (NDefined s) t i e) + fillLength (Line _ ) = 1 + fillLength (Define _ _ ) = 1 + fillLength (Undef _ ) = 1 + fillLength (If _ stmts is e) = + 3 + fillLength stmts + fillLength e + fillLength is + fillLength (IfDef v stmts is e) = fillLength (If (Defined v) stmts is e) + fillLength (IfNDef v stmts is e) = fillLength (If (NDefined v) stmts is e) instance FillLength a => FillLength [a] where fillLength = foldr ((+) . fillLength) 0 instance FillLength Else where - fillLength (Else (Just p)) = fillLength p + 1 - fillLength (Else Nothing) = 0 + fillLength (Else (Just stmts)) = 1 + fillLength stmts + fillLength (Else Nothing ) = 0 instance FillLength Elif where - fillLength (Elif (_, xs)) = fillLength xs + 1 + fillLength (Elif (_, stmts)) = 1 + fillLength stmts fill :: FillLength a => a -> [Stmt] fill p = replicate (fillLength p) blank -mapFst :: (a -> b) -> (a, c) -> (b, c) -mapFst f (a, b) = (f a, b) +blank :: Stmt +blank = Line "" diff --git a/src/Curry/CondCompile/Parser.hs b/src/Curry/CondCompile/Parser.hs index 3f0f01f..9dea8a7 100644 --- a/src/Curry/CondCompile/Parser.hs +++ b/src/Curry/CondCompile/Parser.hs @@ -32,15 +32,14 @@ statement = ifElse "if" condition If <|> undef <|> line -ifElse :: String -> Parser a - -> (a -> [Stmt] -> [Elif] -> Else -> Stmt) +ifElse :: String -> Parser a -> (a -> [Stmt] -> [Elif] -> Else -> Stmt) -> Parser Stmt ifElse k p c = c <$> (try (many sp *> keyword k *> many1 sp) *> p <* many sp <* eol) <*> many (statement <* eol) <*> many (Elif <$> ((,) <$> (try (many sp *> keyword "elif" *> many1 sp) *> condition <* many sp <* eol) - <*> many (statement <* eol))) + <*> many (statement <* eol))) <*> (Else <$> optionMaybe - (try (many sp *> keyword "else" *> many sp) *> eol *> many (statement <* eol))) + (try (many sp *> keyword "else" *> many sp) *> eol *> many (statement <* eol))) <* try (many sp <* keyword "endif" <* many sp) define :: Parser Stmt @@ -60,7 +59,7 @@ keyword :: String -> Parser String keyword = string . ('#' :) condition :: Parser Cond -condition = ( Defined <$> (try (string "defined(") *> many sp *> identifier <* many sp <* char ')')) +condition = (Defined <$> (try (string "defined(") *> many sp *> identifier <* many sp <* char ')')) <|> (NDefined <$> (try (string "!defined(") *> many sp *> identifier <* many sp <* char ')')) <|> (Comp <$> (identifier <* many sp) <*> operator <*> (many sp *> value) "condition") diff --git a/src/Curry/CondCompile/Type.hs b/src/Curry/CondCompile/Type.hs index 62913b0..36b991d 100644 --- a/src/Curry/CondCompile/Type.hs +++ b/src/Curry/CondCompile/Type.hs @@ -13,12 +13,8 @@ -} module Curry.CondCompile.Type where -type Program = [Stmt] -newtype Else = Else (Maybe [Stmt]) - deriving Show -newtype Elif = Elif (Cond, [Stmt]) - deriving Show +type Program = [Stmt] data Stmt = If Cond [Stmt] [Elif] Else | IfDef String [Stmt] [Elif] Else @@ -28,6 +24,12 @@ data Stmt = If Cond [Stmt] [Elif] Else | Line String deriving Show +newtype Else = Else (Maybe [Stmt]) + deriving Show + +newtype Elif = Elif (Cond, [Stmt]) + deriving Show + data Cond = Comp String Op Int | Defined String | NDefined String -- GitLab From 0ae1998badef73d8c0f82c0f45042ae287426781 Mon Sep 17 00:00:00 2001 From: Finn Teegen Date: Thu, 6 Jul 2017 16:21:49 +0200 Subject: [PATCH 17/19] Clean up code for conditional compiling --- src/Curry/CondCompile/CondTransform.hs | 1 - src/Curry/CondCompile/Parser.hs | 2 -- 2 files changed, 3 deletions(-) diff --git a/src/Curry/CondCompile/CondTransform.hs b/src/Curry/CondCompile/CondTransform.hs index 2e5dc5f..3ecde93 100644 --- a/src/Curry/CondCompile/CondTransform.hs +++ b/src/Curry/CondCompile/CondTransform.hs @@ -26,7 +26,6 @@ import Text.Parsec.Error () import Curry.Base.Message import Curry.Base.Position -test = readFile "/home/prott/curry/Test/Array.curry" >>= putStrLn . either show id . condCompile Map.empty "" import Curry.CondCompile.Parser import Curry.CondCompile.Type diff --git a/src/Curry/CondCompile/Parser.hs b/src/Curry/CondCompile/Parser.hs index 9dea8a7..1839a9a 100644 --- a/src/Curry/CondCompile/Parser.hs +++ b/src/Curry/CondCompile/Parser.hs @@ -19,8 +19,6 @@ import Curry.CondCompile.Type type Parser a = Parsec String () a -example = "#if value < 3\n#ifdef nope\nnope\n#else\nyes\n#endif\n#elif value > 3\nthree\n#endif\nline" - program :: Parser Program program = statement `sepBy` eol <* eof -- GitLab From d87e5524452d5204c6b0281fd0f85ad88d8a12ae Mon Sep 17 00:00:00 2001 From: Finn Teegen Date: Thu, 6 Jul 2017 16:22:14 +0200 Subject: [PATCH 18/19] Move pretty printing for conditional compiling --- curry-base.cabal | 1 - src/Curry/CondCompile/CondTransform.hs | 2 +- src/Curry/CondCompile/Pretty.hs | 46 -------------------------- src/Curry/CondCompile/Type.hs | 41 ++++++++++++++++++++++- 4 files changed, 41 insertions(+), 49 deletions(-) delete mode 100644 src/Curry/CondCompile/Pretty.hs diff --git a/curry-base.cabal b/curry-base.cabal index 19acc9a..c26a60d 100644 --- a/curry-base.cabal +++ b/curry-base.cabal @@ -64,7 +64,6 @@ Library Curry.Base.Span Curry.CondCompile.Parser Curry.CondCompile.Type - Curry.CondCompile.Pretty Curry.CondCompile.CondTransform Curry.Files.Filenames Curry.Files.PathUtils diff --git a/src/Curry/CondCompile/CondTransform.hs b/src/Curry/CondCompile/CondTransform.hs index 3ecde93..603f9df 100644 --- a/src/Curry/CondCompile/CondTransform.hs +++ b/src/Curry/CondCompile/CondTransform.hs @@ -16,7 +16,6 @@ module Curry.CondCompile.CondTransform ) where import Control.Monad.State -import Curry.CondCompile.Pretty import Control.Monad.Extra (concatMapM) import qualified Data.Map as Map import Data.Maybe (fromMaybe) @@ -25,6 +24,7 @@ import Text.Parsec.Error () import Curry.Base.Message import Curry.Base.Position +import Curry.Base.Pretty import Curry.CondCompile.Parser import Curry.CondCompile.Type diff --git a/src/Curry/CondCompile/Pretty.hs b/src/Curry/CondCompile/Pretty.hs deleted file mode 100644 index 6a7cfbe..0000000 --- a/src/Curry/CondCompile/Pretty.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Curry.CondCompile.Pretty(Pretty(pPrint, pPrintList)) where - -import Curry.Base.Pretty -import Curry.CondCompile.Type - - -instance Pretty Stmt where - pPrint (If c t i e) = prettyIf (text "#if" <+> pPrint c) t i e - pPrint (IfDef s t i e) = prettyIf (text "#ifdef" <+> text s ) t i e - pPrint (IfNDef s t i e) = prettyIf (text "#ifndef" <+> text s ) t i e - pPrint (Define s i) = text "#define" <+> text s <+> int i - pPrint (Undef s ) = text "#undef" <+> text s - pPrint (Line s ) = text s - - pPrintList = foldr (($+$) . pPrint) empty - -instance Pretty Elif where - pPrint (Elif (c, p)) = text "#elif " <+> pPrint c $+$ - pPrint p - - pPrintList = foldr (($+$) . pPrint) empty - -instance Pretty Else where - pPrint (Else (Just xs)) = text "#else" $+$ - pPrint xs - pPrint (Else Nothing) = empty - -prettyIf :: Doc -> [Stmt] -> [Elif] -> Else -> Doc -prettyIf pre t i e = pre $+$ - pPrint t $+$ - pPrint i $+$ - pPrint e $+$ - text "#endif" - -instance Pretty Cond where - pPrint (Comp s o v) = text s <+> pPrint o <+> int v - pPrint (Defined s) = text "defined(" <> text s <> char ')' - pPrint (NDefined s) = text "!defined(" <> text s <> char ')' - -instance Pretty Op where - pPrint Eq = text "=" - pPrint Neq = text "/=" - pPrint Lt = text "<" - pPrint Leq = text "<=" - pPrint Gt = text ">" - pPrint Geq = text ">=" diff --git a/src/Curry/CondCompile/Type.hs b/src/Curry/CondCompile/Type.hs index 36b991d..3fd932f 100644 --- a/src/Curry/CondCompile/Type.hs +++ b/src/Curry/CondCompile/Type.hs @@ -11,8 +11,11 @@ TODO -} -module Curry.CondCompile.Type where +module Curry.CondCompile.Type + ( Program, Stmt (..), Else (..), Elif (..), Cond (..), Op (..) + ) where +import Curry.Base.Pretty type Program = [Stmt] @@ -42,3 +45,39 @@ data Op = Eq | Gt | Geq deriving Show + +instance Pretty Stmt where + pPrint (If c stmts is e) = prettyIf "#if" (pPrint c) stmts is e + pPrint (IfDef v stmts is e) = prettyIf "#ifdef" (text v) stmts is e + pPrint (IfNDef v stmts is e) = prettyIf "#ifndef" (text v) stmts is e + pPrint (Define v i ) = text "#define" <+> text v <+> int i + pPrint (Undef v ) = text "#undef" <+> text v + pPrint (Line s ) = text s + + pPrintList = foldr (($+$) . pPrint) empty + +instance Pretty Elif where + pPrint (Elif (c, stmts)) = text "#elif" <+> pPrint c $+$ pPrint stmts + + pPrintList = foldr (($+$) . pPrint) empty + +instance Pretty Else where + pPrint (Else (Just stmts)) = text "#else" $+$ pPrint stmts + pPrint (Else Nothing) = empty + +prettyIf :: String -> Doc -> [Stmt] -> [Elif] -> Else -> Doc +prettyIf k doc stmts is e = foldr ($+$) empty + [text k <+> doc, pPrint stmts, pPrint is, pPrint e, text "#endif"] + +instance Pretty Cond where + pPrint (Comp v op i) = text v <+> pPrint op <+> int i + pPrint (Defined v ) = text "defined(" <> text v <> char ')' + pPrint (NDefined v ) = text "!defined(" <> text v <> char ')' + +instance Pretty Op where + pPrint Eq = text "==" + pPrint Neq = text "/=" + pPrint Lt = text "<" + pPrint Leq = text "<=" + pPrint Gt = text ">" + pPrint Geq = text ">=" -- GitLab From 96a0fa34a2bc2f452b4e5efc3f58d407e3176818 Mon Sep 17 00:00:00 2001 From: Finn Teegen Date: Fri, 7 Jul 2017 11:26:26 +0200 Subject: [PATCH 19/19] Rename transformation module for conditional compiling --- curry-base.cabal | 2 +- .../{CondTransform.hs => Transform.hs} | 22 +++++++++---------- 2 files changed, 11 insertions(+), 13 deletions(-) rename src/Curry/CondCompile/{CondTransform.hs => Transform.hs} (86%) diff --git a/curry-base.cabal b/curry-base.cabal index c26a60d..d0e2e78 100644 --- a/curry-base.cabal +++ b/curry-base.cabal @@ -63,8 +63,8 @@ Library Curry.Base.Pretty Curry.Base.Span Curry.CondCompile.Parser + Curry.CondCompile.Transform Curry.CondCompile.Type - Curry.CondCompile.CondTransform Curry.Files.Filenames Curry.Files.PathUtils Curry.Files.Unlit diff --git a/src/Curry/CondCompile/CondTransform.hs b/src/Curry/CondCompile/Transform.hs similarity index 86% rename from src/Curry/CondCompile/CondTransform.hs rename to src/Curry/CondCompile/Transform.hs index 603f9df..72cceb5 100644 --- a/src/Curry/CondCompile/CondTransform.hs +++ b/src/Curry/CondCompile/Transform.hs @@ -11,9 +11,7 @@ TODO -} -module Curry.CondCompile.CondTransform - ( CCState, condCompile - ) where +module Curry.CondCompile.Transform (condTransform) where import Control.Monad.State import Control.Monad.Extra (concatMapM) @@ -33,10 +31,10 @@ type CCState = Map.Map String Int type CCM = State CCState -condCompile :: CCState -> FilePath -> String -> Either Message String -condCompile s fn p = either (Left . convertError) - (Right . transformWith s) - (parse program fn p) +condTransform :: CCState -> FilePath -> String -> Either Message String +condTransform s fn p = either (Left . convertError) + (Right . transformWith s) + (parse program fn p) transformWith :: CCState -> Program -> String transformWith s p = show $ pPrint $ evalState (transform p) s @@ -54,7 +52,7 @@ instance CCTransform Stmt where transform (Line s) = return [Line s] transform (If c stmts is e) = do s <- get - if checkCondOpt c s + if checkCond c s then do stmts' <- transform stmts return (blank : stmts' ++ fill is ++ fill e ++ [blank]) else case is of @@ -76,10 +74,10 @@ instance CCTransform Else where transform (Else (Just p)) = (blank :) <$> transform p transform (Else Nothing ) = return [] -checkCondOpt :: Cond -> CCState -> Bool -checkCondOpt (Comp v op i) = flip (compareOp op) i . fromMaybe 0 . Map.lookup v -checkCondOpt (Defined v) = Map.member v -checkCondOpt (NDefined v) = Map.notMember v +checkCond :: Cond -> CCState -> Bool +checkCond (Comp v op i) = flip (compareOp op) i . fromMaybe 0 . Map.lookup v +checkCond (Defined v) = Map.member v +checkCond (NDefined v) = Map.notMember v compareOp :: Ord a => Op -> a -> a -> Bool compareOp Eq = (==) -- GitLab