diff --git a/Language/Sh/Expansion.hs b/Language/Sh/Expansion.hs --- a/Language/Sh/Expansion.hs +++ b/Language/Sh/Expansion.hs @@ -169,7 +169,7 @@ arithExpand =<< expandWordE w --e _ x = fail $ "Expansion "++show x++" not yet implemented" removeNewlines = reverse . dropWhile (`elem`"\r\n") . reverse - toStr = removeQuotes . fromMaybe [] -- ${@#...} should map over words + toStr = removeQuotes . fromMaybe [] -- ${@#...} should map over words fromStr = quoteLiteral -- but it's technically undefined so no worry -- crap - need to fully expand all letters...? diff --git a/Language/Sh/Parser.hs b/Language/Sh/Parser.hs --- a/Language/Sh/Parser.hs +++ b/Language/Sh/Parser.hs @@ -55,6 +55,8 @@ newlines return a' +-- Need to work on error parsing for the function def... +-- at least, in the case of heredocs inside (illegal?) it seems to fail statement :: P Statement statement = do aliasOn choice [try $ do name <- basicName @@ -62,8 +64,8 @@ char ')' <|> unexpectedNoEOF spaces >> newlines -- optional FunctionDefinition name - `fmap` compoundStatement - `ap` many redirection + `fmap` compoundStatement + `ap` many redirection ,Compound `fmap` compoundStatement `ap` many redirection ,do s <- statementNoSS case s of -- needed to prevent errors w/ 'many' diff --git a/Language/Sh/Pretty.hs b/Language/Sh/Pretty.hs new file mode 100644 --- /dev/null +++ b/Language/Sh/Pretty.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, + PatternGuards #-} + +module Language.Sh.Pretty ( Pretty, pretty, + compacted, indented ) where + +import Control.Monad.State ( State, runState, evalState, + get, gets, put, modify ) +import Data.Char ( isAlphaNum ) + +import Language.Sh.Syntax + +-- |This is the pretty-printing class +class Pretty p where + pretty :: p -> String -- ^The standard user pretty-printing function. + -- |This version takes extra context information as arguments. + prettyC :: p -> PrettyP String + + pretty p = evalState (prettyC p) empty + prettyC = return . pretty + +instance Pretty String where pretty = id +instance Pretty (PrettyP String) where prettyC = id + +-- helper types +data QuoteType = None | DoubleQ | SingleQ | HeredocQ + deriving ( Show, Eq ) +type PrettyP = State PState +data PState = PState { heredocs :: [(Word,String)] + , delims :: String + , quotes :: QuoteType + , indent :: Int + , compact :: Bool } deriving ( Show ) +empty :: PState +empty = PState [] normalDelimiters None 0 False + +-- Just reset the things we mess with at the word level... +reset :: PrettyP () +reset = modify $ \s -> s { delims = normalDelimiters, quotes = None } + +-- helper functions (all internal) +setQuote :: QuoteType -> PrettyP () +setQuote q = modify $ \s -> s { quotes = q } + +sub :: PrettyP a -> PrettyP a +sub a = do s <- get + normalDelims + put $ s { heredocs = [], quotes = None } + a' <- a + modify $ \s' -> s { heredocs = heredocs s++heredocs s' } + return a' + +runLater :: Pretty p => p -> PrettyP (String,PState) +runLater a = do s <- get + return $ runState (prettyC a) $ s { heredocs = [] } + +runNow :: Pretty p => PState -> p -> PrettyP String +runNow s a = do a' <- prettyC a + laterState s + return a' + +laterState :: PState -> PrettyP () +laterState s = modify $ \s' -> s { heredocs = heredocs s'++heredocs s } + +normalDelimiters :: String +normalDelimiters = "&|;<>()# \t\r\n" + +normalDelims, braceDelims, noDelims :: PrettyP () +normalDelims = modify $ \s -> s { delims = "&|;<>()# \t\r\n" } +braceDelims = modify $ \s -> s { delims = "}" } +noDelims = modify $ \s -> s { delims = "" } + +-- This has a different implementation because we'll be a bit +-- smarter about quotes: this should still work after quote removal +-- The monad makes order a bit more important, but as long as we're +-- within a single word, we can rearrange...? just need to make +-- sure the heredocs go in the right spot... +quote :: QuoteType -> PrettyP String +quote q' = do q <- gets quotes + if q==HeredocQ + then return "" + else do modify $ \s -> s { quotes = q' } + return $ switch q + where switch q | q == q' = "" + | otherwise = symb q' ++symb q + symb SingleQ = "'" + symb DoubleQ = "\"" + symb _ = "" + +-- turn off quoting if the same type is on... +toggleQuote :: QuoteType -> PrettyP String +toggleQuote q' = do q <- gets quotes + if q==HeredocQ + then return "" + else if q'==q then quote None + else quote q' + +-- turn on quoting only if it's not already on +quoteOn :: PrettyP String +quoteOn = do q <- gets quotes + case q of + None -> quote DoubleQ + _ -> return "" + +(+++) :: (Pretty p,Pretty q) => p -> q -> PrettyP String +p +++ q = do p' <- prettyC p + q' <- prettyC q + return $ p'++q' + +-- inserts any pending heredocs where they'd be asked for +-- argument is what to print if we're compact ("; " or " ") +newline :: String -> PrettyP String +newline x = do ind <- gets indent + c <- gets compact + if c then return x + else printHD +++ ("\n" ++ replicate ind ' ') + +printHD :: PrettyP String +printHD = do hds <- gets heredocs + modify $ \s -> s { heredocs = [] } + intercM "" (map showhd hds) -- foldM? + where showhd (w,s) = "\n" +++ heredoc w +++ term s + term "" = "" + term s = "\n"++s + heredoc w = do q <- gets quotes + modify $ \s -> s { quotes = HeredocQ } + w' <- prettyC w + modify $ \s -> s { quotes = q } + return w' + +-- This is only used BETWEEN words, so we can reset! +intercM :: (Pretty p,Pretty q) => q -> [p] -> PrettyP String +intercM _ [] = return [] +intercM _ [x] = prettyC x +intercM s (x:xs) = prettyC x +++ prettyC s +++ intercM s xs + +indented :: Pretty p => Int -> p -> PrettyP String +indented i p = do s <- get + put $ s { indent = indent s + i } + a <- prettyC p + modify $ \s' -> s' { indent = indent s } + return a + +compacted :: Pretty p => p -> PrettyP String +compacted p = do s <- get + put $ s { compact = True } + a <- prettyC p + modify $ \s' -> s' { compact = compact s } + return a + +-- This is a pretty dumb printer. As long as all the quote +-- characters are retained, it should work fine. But we +-- won't really end up using it. + +instance Pretty Lexeme where + prettyC (Literal c) = return [c] + prettyC (Quoted l) = prettyC l + prettyC (Quote q) = return [q] + prettyC (Expand x) = prettyC x -- this is why we need prettyC here + prettyC SplitField = return "" + +-- This is where most of the trickness happens. +instance Pretty [Lexeme] where + prettyC w = do s <- pc w + reset + return s + where + pc [] = return "" + pc (Quote '\'':ls) = toggleQuote SingleQ +++ pc ls + pc (Quote '"':ls) = toggleQuote DoubleQ +++ pc ls + pc (Quote _:ls) = pc ls + pc (Quoted l:ls) = quoteOn +++ pc' (l:ls) + pc (l:ls) = quote None +++ pc' (l:ls) + -- Once we've got the quotes right... + pc' (Quoted l:ls) = pc' $ l:ls + pc' (Quote _:ls) = pc ls + -- Now we've only got Expand, Literal, or SplitField + pc' (Expand (SimpleExpansion x):ls) | (c:cs) <- x + = do (rest,st) <- runLater $ pc ls + if (null cs && c `elem` "@*#?-$!0123456789") + || null rest || not (isAlphaUnderNum (head rest)) + then (runNow st $ '$':x) +++ rest + else (runNow st $ SimpleExpansion x) +++ rest + pc' (Expand x:ls) = prettyC x +++ pc ls + pc' (Literal c:ls) = do q <- gets quotes + d <- gets delims + lit q d c +++ pc ls + pc' (SplitField:ls) = do q <- gets quotes + quote None +++ " " +++ quote q + lit q d c = case q of -- backslash-quote anything we need to + None | c `elem` (d++"$`\"'\\") -> ['\\',c] + SingleQ | c == '\'' -> "'\"'\"'" + DoubleQ | c `elem` "$`\"\\" -> ['\\',c] + HeredocQ | c `elem` "$`\\" -> ['\\',c] + _ -> [c] + isAlphaUnderNum c = isAlphaNum c || c=='_' + +instance Pretty Expansion where + prettyC (SimpleExpansion s) = return $ "${" ++ s ++ "}" + prettyC (ModifiedExpansion s c b w) + = do w' <- sub $ braceDelims >> compacted w + return $ "${" ++ s ++ oper ++ w' ++ "}" + where oper | c `elem` "-=+?" = (if b then (':':) else id) [c] + | c `elem` "#%" = (if b then (c:) else id) [c] + | otherwise = [c] -- error? + prettyC (LengthExpansion s) = return $ "${#" ++ s ++ "}" + prettyC (CommandSub cs) = sub $ "$( " +++ compacted cs +++ " )" + prettyC (Arithmetic w) = sub $ do noDelims + "$(( " +++ compacted w +++ " ))" + +instance Pretty Redir where + prettyC = p where + p (n:>w) = pn 1 n ">" +++ w + p (n:>|w) = pn 1 n ">|" +++ w + p (n:>&m) = pn 1 n ">&" +++ show m + p (n:>>w) = pn 1 n ">>" +++ w + p (n:<>w) = pn 0 n "<>" +++ w + p (n: s { heredocs = heredocs s ++ [(w,eot)] } + pn 0 n "<<" +++ eot + where eot = "EOF"++show (length w) -- "random"? + pn def n s | n == def = s++" " + | otherwise = show n++" "++s++" " + +instance Pretty Assignment where + prettyC (s:=w) = (s++"=") +++ prettyC w + +------ now upwards... + +instance Pretty CompoundStatement where + prettyC = pc where + pc (For name ws cs) = "for " +++ name +++ " in " + +++ intercM " " ws +++ loop cs + pc (While cond cs) = "while " +++ compacted cond +++ loop cs + pc (Until cond cs) = "until " +++ compacted cond +++ loop cs + pc (If cond thn els) = "if " +++ compacted cond +++ "; then" + +++ indented 2 (newline "; "+++thn) + +++ elseblock + where elseblock = case els of + [] -> newline "; " +++ "fi" + [Synchronous (Singleton (Pipeline [ + Compound i@(If _ _ _) []]))] + -> newline "; " +++ "el" +++ pc i + _ -> newline "; " +++ "else" + +++ indented 2 (newline " " +++ els) + +++ newline "; " +++ "fi" + pc (Case w ss) = "case " +++ w +++ " in" +++ indented 2 (cas ss) + +++ newline " " +++ "esac" + where cas [] = return "" + cas ((ps,cs):xs) + = newline " "+++ "(" +++ intercM "|" ps +++ ")" + +++ indented 2 (newline " " +++ cs +++ ";;") + +++ cas xs + pc (Subshell cs) = "(" +++ indented 2 cs +++ ")" + pc (BraceGroup cs) = "{ " +++ indented 2 cs +++ newline "; " +++ "}" + loop cs = "; do" +++ indented 2 (newline " " +++ cs) + +++ newline "; " +++ "done" + +instance Pretty Term where + prettyC (TWord w) = prettyC w + prettyC (TRedir r) = prettyC r + prettyC (TAssignment a) = prettyC a + +instance Pretty Statement where + prettyC (Statement ws rs as) = intercM " " as +++ space as ws + +++ intercM " " ws +++ space ws rs + +++ intercM " " rs + where space as bs = if null as || null bs then "" else " " + prettyC (OrderedStatement ts) = intercM " " ts + prettyC (Compound c rs) = c +++ " " +++ intercM " " rs + prettyC (FunctionDefinition f d rs) + = case d of -- specialize in the case of { } + BraceGroup b -> f +++ " () {" +++ indented 2 (newline " " +++ b) + +++ newline "; " +++ "} " +++ intercM " " rs + _ -> f +++ " ()" +++ newline " " +++ d +++ intercM " " rs + +instance Pretty Pipeline where + prettyC (Pipeline ss) = intercM " | " ss + prettyC (BangPipeline ss) = "! " +++ intercM " | " ss + +instance Pretty AndOrList where + prettyC (Singleton p) = prettyC p + prettyC (a :&&: p) = a +++ " && " +++ p + prettyC (a :||: p) = a +++ " || " +++ p + +instance Pretty Command where + prettyC (Synchronous a) = prettyC a +++ printHD + prettyC (Asynchronous a) = a +++ " &" +++ printHD + +instance Pretty [Command] where + prettyC [] = return "" + prettyC [c] = prettyC c + prettyC (Synchronous a:cs) = a +++ newline "; " +++ cs + prettyC (Asynchronous a:cs) = a +++ " &" +++ newline " " +++ cs diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,3 @@ -#!/usr/bin/env runhaskell +#!/usr/bin/env runghc import Distribution.Simple main = defaultMain diff --git a/language-sh.cabal b/language-sh.cabal --- a/language-sh.cabal +++ b/language-sh.cabal @@ -1,5 +1,5 @@ name: language-sh -version: 0.0.3 +version: 0.0.3.1 synopsis: A package for parsing shell scripts description: Language.Sh is a collection of modules for parsing and @@ -23,6 +23,7 @@ Language.Sh.Glob Language.Sh.Map Language.Sh.Parser + Language.Sh.Pretty Language.Sh.Syntax other-modules: Language.Sh.Parser.Internal Language.Sh.Parser.Parsec