content: {- Author:     Jeff Newbern
     Maintainer: Jeff Newbern <jnewbern@nomaware.com>
     Time-stamp: <Mon Aug 18 15:15:38 2003>
     License:    GPL
  -}
  
  {- DESCRIPTION
  
  Example 16 - Using the Reader monad
  
  Usage: Compile the code to produce a simple but flexible template
         substitution system.
         
         The first argument is a file (look at template.txt) which
         contains templates within [name]...[END] pairs.  The templates
         are text, but the special sequences ${var}, $"name", and $<name>
         cause substitutions.  The ${var} form is replaced by the value
         of the variable.  The $"name" form is replaced by the named
         template, but the template is "quoted", so that variable
         patterns, etc. within it are not treated specially.  The
         $<name> form inserts the named template and performs all
         substitutions specified in the template.  Variable values
         can be introduced or overriden within an included template
         by using the form $<name|var1=value1,var2=value2,...,varN=valueN>.
  
         The second argument is an initial template to evaluate.
         It would typically reference named templates in the templates
         file specified in the first argument.
         
         Any arguments following the template are assumed to be
         variable definitions of the form "var=value".  These establish
         variable bindings for the initial template.
         
  Try: ./ex16 template.txt '$<#1>'
       ./ex16 template.txt '${language}' 'language=Haskell'
       ./ex16 template.txt '$"#3"'
       ./ex16 template.txt '$<#3>'
       ./ex16 template.txt '===$<no such file>==='
       ./ex16 template.txt '$<#2>'
       ./ex16 template.txt '$<#2>' 'var=dog'
       ./ex16 template.txt '$<#2|var=dog>'
       ./ex16 template.txt '$<#4|variable=cat>'
       ./ex16 template.txt '$<#5>' 'which=3'
       ./ex16 template.txt '$<#5|which=3>'
       ./ex16 template.txt '$<#6|which=5>'
       ./ex16 template.txt '$<#6|which=5,var=dog,variable=cat>'
  -}
  
  {- We use the Parsec monadic parser combinator library to parse
     template files -}
  import Text.ParserCombinators.Parsec
  import Text.ParserCombinators.Parsec.Token
  
  import IO hiding (try)  -- "try" is also defined in the Parsec libraries
  import Monad
  import System
  import Maybe
  import List (intersperse)
  import Control.Monad.Reader
  
  -- This the abstract syntax representation of a template
  --              Text       Variable     Quote        Include                   Compound
  data Template = T String | V Template | Q Template | I Template [Definition] | C [Template]
  data Definition = D Template Template
  data NamedTemplate = NT String Template
  
  -- Templates are members of the Show class
  instance Show Template where
    show (T s)    = s
    show (V t)    = "${" ++ (show t) ++ "}"
    show (Q t)    = "$\"" ++ (show t) ++ "\""
    show (I t ds) = let name        = (show t)
                        definitions = concat (intersperse ", " (map show ds))
                    in case definitions of
  		       []        -> "$<" ++ name ++ ">"
  		       otherwise -> "$<" ++ name ++ "|" ++ definitions ++ ">"
    show (C ts)   = concatMap show ts
  
  instance Show Definition where
    show (D t d) = (show t) ++ "=" ++ (show d)
  
  instance Show NamedTemplate where
    show (NT n t) = "[" ++ n ++ "]" ++ (show t) ++ "[END]\n"
  
  {- Here we define a parser for templates. -}
  
  -- parse a file containing named templates
  templateFile :: Parser [NamedTemplate]
  templateFile = do nts <- many namedTemplate
                    eof
  		  return nts
  
  -- parse a single named template
  namedTemplate :: Parser NamedTemplate
  namedTemplate = do n <- name
                     t <- (template []) <?> "template"
  		   end
  		   spaces
  		   return (NT n t)
  
  -- parse a named template label
  name :: Parser String
  name = between (char '[') (char ']') (many1 (noneOf "]")) <?> "label"
  
  -- parse a named template [END] keyword
  end :: Parser String
  end = string "[END]" <?> "[END]"
  
  -- parse a (possibly compound) template.
  -- the [Char] argument is a list of characters not allowed in the template.
  template :: [Char] -> Parser Template
  template except = do ts <- many1 (simpleTemplate except)
                       case ts of
  	               [t]       -> return t
  		       otherwise -> return (C ts)
  
  -- parse a simple template: text, a variable pattern, a quote pattern, or a include pattern
  -- the [Char] argument is a list of characters not allowed in the template.
  simpleTemplate :: [Char] -> Parser Template
  simpleTemplate except =  (text except)
                       <|> (try variable)
  		     <|> (try quote)
  		     <|> include
  
  -- parse a dollar-sign that doesn't begin a variable, quote, or include pattern 
  dollar :: Parser Char
  dollar = try (do c <- char '$'
                   notFollowedBy (oneOf "{<\"")
                   return c)
  	 <?> ""
  
  -- parse a left bracket that isn't part of an [END] keyword
  leftBracket :: Parser Char
  leftBracket = try (do s <- (try end) <|> (string "[")
                        case s of
  		        "[END]" -> pzero
  		        "["     -> return '[')
  	      <?> ""
  
  -- parse a character that isn't part of a pattern or END keyword and
  -- isn't in the list of excluded characters.
  textChar :: [Char] -> Parser Char
  textChar except = noneOf ("$[" ++ except) <|> dollar <|> leftBracket
  
  -- parse a string of allowed characters
  -- the [Char] argument is a list of characters not allowed in the text.
  text :: [Char] -> Parser Template
  text except = do str <- many1 (textChar except)
                   return (T str)
                <?> "text"
  
  -- parse a variable pattern
  variable :: Parser Template
  variable = do t <- between (string "${") (char '}') (template "}")
                return (V t)
  	   <?> "variable pattern"
  
  -- parse a quoted-inclusion pattern
  quote :: Parser Template
  quote = do t <- between (string "$\"") (char '\"') (template "\"")
             return (Q t)
  	   <?> "quoted include pattern"
  
  -- parse a resolved-inclusion pattern
  include :: Parser Template
  include = between (string "$<") (char '>') includeBody
            <?> "include pattern"
  
  -- parse the body of an inclusion pattern
  includeBody :: Parser Template
  includeBody = do t  <- (template "|>")
                   ds <- option [] definitions
  		 return (I t ds)
  
  -- parse a list of definitions
  definitions :: Parser [Definition]
  definitions = do char '|'
                   ds <- definition `sepBy1` (char ',')
  		 return ds
  		 
  -- parse a single definition
  definition :: Parser Definition
  definition = do t1 <- (template "=,>")
                  char '='
  		t2 <- (template ",>")
  		return (D t1 t2)
  	     <?> "variable definition"
  	     
  -- Our environment consists of an association list of named templates and
  -- an association list of named variable values. 
  data Environment = Env {templates::[(String,Template)],
                          variables::[(String,String)]}
  
  -- lookup a variable from the environment
  lookupVar :: String -> Environment -> Maybe String
  lookupVar name env = lookup name (variables env)
  
  -- lookup a template from the environment
  lookupTemplate :: String -> Environment -> Maybe Template
  lookupTemplate name env = lookup name (templates env)
  
  -- add a list of resolved definitions to the environment
  addDefs :: [(String,String)] -> Environment -> Environment
  addDefs defs env = env {variables = defs ++ (variables env)}
                        
  -- resolve a Definition and produce a (name,value) pair
  resolveDef :: Definition -> Reader Environment (String,String)
  resolveDef (D t d) = do name <- resolve t
                          value <- resolve d
                          return (name,value)
  
  -- resolve a template into a string
  resolve :: Template -> Reader Environment (String)
  resolve (T s)    = return s
  resolve (V t)    = do varName  <- resolve t
                        varValue <- asks (lookupVar varName)
  		      return $ maybe "" id varValue
  resolve (Q t)    = do tmplName <- resolve t
                        body     <- asks (lookupTemplate tmplName)
                        return $ maybe "" show body 
  resolve (I t ds) = do tmplName <- resolve t
                        body     <- asks (lookupTemplate tmplName)
                        case body of
                          Just t' -> do defs <- mapM resolveDef ds
                                        local (addDefs defs) (resolve t')
                          Nothing -> return ""
  resolve (C ts)   = (liftM concat) (mapM resolve ts)
  
  -- turn a named template into a (name,template) pair
  stripName :: NamedTemplate -> (String, Template)
  stripName (NT n t) = (n,t)
  
  -- Read the command line arguments, parse the template file, the user template, and any
  -- variable definitions.  Then construct the environment and print the resolved user template.
  main :: IO ()
  main = do args     <- getArgs
            let tmplFile = args!!0
  	      pattern  = args!!1
  	      defs     = drop 2 args
  	  nts      <- parseFromFile templateFile tmplFile
  	  case nts of
  	    (Left err) -> print err
  	    (Right _)  -> return ()
  	  let tmpl = parse (template []) "pattern" pattern
  	  case tmpl of
  	    (Left err) -> print err
  	    (Right _)  -> return ()
  	  let ds     = map (break (=='=')) defs
  	      ds'    = map (\ (x,y) -> (x,tail y)) ds
  	      ntl    = either (const []) id nts
  	      env    = Env (map stripName ntl) ds'
  	      t      = either (const (T "")) id tmpl
  	      result = runReader (resolve t) env
  	  putStr result
  
  -- END OF FILE
  