parsec-test-3.hs

import System.Environment (getArgs)
import Text.Parsec
import Text.Parsec.Prim
import Text.Parsec.Language
import qualified Text.Parsec.Token as T
import Control.Applicative ((<$>), (*>), (<*>), pure, liftA2)
import Data.List (intercalate)

type Parser = Parsec String ()
type Location = String
-- type LocNode a = (Location, a)

-- AST

data Program = Program [(Location, Statement)]
               -- deriving (Show)
data Statement = Print String
               | Use FilePath
                 deriving (Show)

instance Show Program where
  show (Program stmts) =
    "Program [\n\t" ++ intercalate "\n\t" (map show stmts) ++ "\n]"

myLangDef = emptyDef {
  T.reservedNames = [ "print", "use" ]
}

lexer = T.makeTokenParser myLangDef

reserved = T.reserved lexer
stringLiteral = T.stringLiteral lexer

parseString :: String -> String -> Program
parseString fname =
  either (error . show) id .
  parse program fname

parseFile :: String -> IO Program
parseFile fname = parseString <$> pure fname <*> readFile fname

-- parsers

program :: Parser Program
program = Program <$> many statement

statement :: Parser (Location, Statement)
statement = printStr <|> useFile

printStr :: Parser (Location, Statement)
printStr = withLocation $ Print <$> (reserved "print" *> stringLiteral)

useFile :: Parser (Location, Statement)
useFile = withLocation $ Use <$> (reserved "use" *> stringLiteral)

withLocation :: Parser a -> Parser (Location, a)
withLocation = liftA2 (,) getLocation

getLocation :: Parser String
getLocation = do
  pos <- getPosition
  return $ "(" ++ sourceName pos
               ++ ":"
               ++ (show . sourceLine) pos
               ++ ","
               ++ (show . sourceColumn) pos
               ++ ")"

-- read contents of "use"d files, parse and insert in the main AST

expandProgram :: Program -> IO Program
expandProgram (Program stmts) = Program <$> (includeUsedFiles stmts)
  where includeUsedFiles :: [(Location, Statement)] -> IO [(Location, Statement)]
        includeUsedFiles = fmap concat <$> mapM expandStatement

        expandStatement :: (Location, Statement) -> IO [(Location, Statement)]
        expandStatement (loc, stmt) =
          case stmt of
            Use file -> (extendLocation loc . getStatements) <$> parseFile file >>= includeUsedFiles
            _        -> return [(loc, stmt)]

        getStatements :: Program -> [(Location, Statement)]
        getStatements (Program stmts) = stmts

        extendLocation :: Location -> [(Location, Statement)] -> [(Location, Statement)]
        extendLocation loc = map (\(l, s) -> (loc ++ "|" ++ l, s))

main = do
  head <$> getArgs
    >>= parseFile
    >>= expandProgram
    >>= print