Parse.hs

{-# LANGUAGE OverloadedStrings #-}
module Erd.Parse
  ( loadER
  )
where

import Control.Monad (when)
import Data.List (find)
import Data.Maybe
import Data.Text.Lazy hiding (find, map, reverse)
import Data.Text.Lazy.IO
import System.IO (Handle)
import Text.Parsec
import Text.Printf (printf)
import Text.Parsec.Erd.Parser (AST(..), GlobalOptions(..), document)

import Erd.ER

loadER :: String -> Handle -> IO (Either String ER)
loadER fpath f = do
  s <- hGetContents f
  case parse (do { (opts, ast) <- document; return $ toER opts ast}) fpath s of
    Left err -> return $ Left $ show err
    Right err@(Left _) -> return err
    Right (Right er) -> return $ Right er

-- | Converts a list of syntactic categories in an entity-relationship
-- description to an ER representation. If there was a problem with the
-- conversion, an error is reported. This includes checking that each
-- relationship contains only valid entity names.
--
-- This preserves the ordering of the syntactic elements in the original
-- description.
toER :: GlobalOptions -> [AST] -> Either String ER
toER gopts = toER' (ER [] [] title)
  where title = gtoptions gopts `mergeOpts` defaultTitleOpts

        toER' :: ER -> [AST] -> Either String ER
        toER' er [] = Right (reversed er) >>= validRels
        toER' (ER { entities = [] }) (A a:_) =
          let name = show (field a)
           in Left $ printf "Attribute '%s' comes before first entity." name
        toER' er@(ER { entities = e':es }) (A a:xs) = do
          let e = e' { attribs = a:attribs e' }
          toER' (er { entities = e:es }) xs
        toER' er@(ER { entities = es }) (E e:xs) = do
          let opts = eoptions e
                     `mergeOpts` geoptions gopts
                     `mergeOpts` defaultEntityOpts
          let hopts = eoptions e
                      `mergeOpts` ghoptions gopts
                      `mergeOpts` defaultHeaderOpts
          toER' (er { entities = e { eoptions = opts, hoptions = hopts }:es}) xs
        toER' er@(ER { rels = rs }) (R r:xs) = do
          let opts = roptions r
                     `mergeOpts` groptions gopts
                     `mergeOpts` defaultRelOpts
          toER' (er { rels = r { roptions = opts }:rs }) xs

        reversed :: ER -> ER
        reversed er@(ER { entities = es, rels = rs }) =
          let es' = map (\e -> e { attribs = reverse (attribs e) }) es
          in  er { entities = reverse es', rels = reverse rs }

        validRels :: ER -> Either String ER
        validRels er = validRels' (rels er) er

        validRels' :: [Relation] -> ER -> Either String ER
        validRels' [] er = return er
        validRels' (r:_) er = do
          let r1 = find (\e -> name e == entity1 r) (entities er)
          let r2 = find (\e -> name e == entity2 r) (entities er)
          let err getter = Left
                             $ printf "Unknown entity '%s' in relationship."
                             $ unpack $ getter r
          when (isNothing r1) (err entity1)
          when (isNothing r2) (err entity2)
          return er