Parse.hs

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

import           Erd.ER

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.Parsec.Erd.Parser (AST (..), GlobalOptions (..), document)
import           Text.Printf            (printf)

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 [] [] erTitle)
  where erTitle = gtoptions gopts `mergeOpts` defaultTitleOpts

        toER' :: ER -> [AST] -> Either String ER
        toER' er [] = Right (reversed er) >>= validRels
        toER' ER { entities = [] } (A a:_) =
          let fieldName = show (field a)
          in  Left $ printf "Attribute '%s' comes before first entity." fieldName
        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