content: {- Author:     Jeff Newbern
     Maintainer: Jeff Newbern <jnewbern@nomaware.com>
     Time-stamp: <Mon Aug 18 15:53:12 2003>
     License:    GPL
  -}
  
  {- DESCRIPTION
  
  Example 23 - Using the ReaderT monad transformer
  
  Usage: Compile the code to produce a simple but flexible template
         substitution system.
         
         The first argument is an initial template to evaluate.
         It would typically reference named variables and template files.
         
         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: ./ex23 '$<template1.txt>'
       ./ex23 '${language}' 'language=Haskell'
       ./ex23 '$"template3.txt"'
       ./ex23 '$<template3.txt>'
       ./ex23 '===$<no such file>==='
       ./ex23 '$<template2.txt>'
       ./ex23 '$<template2.txt>' 'var=dog'
       ./ex23 '$<template2.txt|var=dog>'
       ./ex23 '$<template4.txt|variable=cat>'
       ./ex23 '$<template5.txt>' 'which=3'
       ./ex23 '$<template5.txt|which=3>'
       ./ex23 '$<template6.txt|which=5>'
       ./ex23 '$<template6.txt|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 qualified IO (try)
  import Monad
  import System
  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
  
  -- 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)
  
  {- Here we define a parser for templates. -}
  
  -- 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 character that isn't part of a pattern and
  -- isn't in the list of excluded characters.
  textChar :: [Char] -> Parser Char
  textChar except = noneOf ("$" ++ except) <|> dollar
  
  -- 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 variable  values
  -- an association list of named variable values. 
  type Environment = [(String,String)]
  
  -- lookup a variable from the environment
  lookupVar :: String -> Environment -> Maybe String
  lookupVar = lookup
  
  -- add a list of resolved definitions to the environment
  addDefs :: [(String,String)] -> Environment -> Environment
  addDefs = (++)
  
  -- this is the type of our monad
  type TemplateReader a = ReaderT Environment IO a
  
  -- resolve a Definition and produce a (name,value) pair
  resolveDef :: Definition -> TemplateReader (String,String)
  resolveDef (D t d) = do name <- resolve t
                          value <- resolve d
                          return (name,value)
  
  -- resolve a template into a string
  resolve :: Template -> TemplateReader String
  resolve (T s)    = return s
  resolve (V t)    = do varName  <- resolve t
                        varValue <- asks (lookupVar varName)
                        case varValue of
                          Just s  -> return s
                          Nothing -> return ""
  resolve (Q t)    = do tmplName <- resolve t
                        body     <- liftIO $ IO.try (readFile tmplName)
                        case body of
  		        Left err -> do liftIO $ hPutStrLn stderr (show err)
  				       return ""
                          Right s  -> return s
  resolve (I t ds) = do tmplName <- resolve t
                        body     <- liftIO $ IO.try (parseFromFile (template []) tmplName)
                        case body of
  		        Left err          -> do liftIO $ hPutStrLn stderr (show err)
  			                        return ""
                          Right (Left err') -> do liftIO $ hPutStrLn stderr (show err')
  			                        return ""
  			Right (Right t')  -> do defs <- mapM resolveDef ds
                                                  local (addDefs defs) (resolve t')
  resolve (C ts)   = (liftM concat) (mapM resolve ts)
  
  -- 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 pattern = args!!0
  	      defs    = map (break (=='=')) (drop 1 args)  -- split into ("var","=value")
  	      env     = map (\ (x,y) -> (x,tail y)) defs   -- get rid of '='
  	  case parse (template []) "template" pattern of
  	    Left err -> hPutStrLn stderr (show err)
  	    Right t  -> (runReaderT (resolve t) env) >>= putStr
  
  -- END OF FILE
  