gl-0.4: Parser.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE Arrows #-}
{-# OPTIONS_GHC -Wall #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2014 Edward Kmett and Gabríel Arthúr Pétursson
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
----------------------------------------------------------------------------
module Parser
  ( parseFile
  ) where

import Registry
import Text.XML.HXT.Core

#ifdef HLINT
{-# ANN module "HLint: ignore Reduce duplication" #-}
#endif

to :: ArrowXml a => String -> a XmlTree XmlTree
to name = hasName name <<< isElem <<< getChildren

perhaps :: ArrowIf a => a b c -> a b (Maybe c)
perhaps x = (arr Just <<< x) `orElse` constA Nothing

parseCommand :: ArrowXml a => a XmlTree Command
parseCommand = proc x -> do
  command <- to "command" -< x
  name <- getText <<< getChildren <<< to "name" <<< to "proto" -< command
  typ <- parseType <<< to "proto" -< command
  params <- listA parseParameter -< command
  veceq   <- perhaps (getAttrValue0 "name" <<< to "vecequiv") -< command
  alias   <- perhaps (getAttrValue0 "name" <<< to "alias") -< command
  returnA -< Command name typ params veceq alias

parseParameter :: ArrowXml a => a XmlTree Parameter
parseParameter = proc x -> do
  param <- to "param" -< x
  typ   <- parseType -< param
  name  <- getText <<< getChildren <<< to "name" -< param
  grp   <- perhaps (getAttrValue0 "group") -< param
  len   <- perhaps (getAttrValue0 "len") -< param
  returnA -< Parameter name typ grp len

parseEnum :: ArrowXml a => a XmlTree Enumeratee
parseEnum = proc x -> do
  enum <- to "enum" -< x
  name <- getAttrValue0 "name" -< enum
  value <- getAttrValue0 "value" -< enum
  returnA -< Enumeratee name value

parseExtension :: ArrowXml a => a XmlTree Extension
parseExtension = proc x -> do
  extension <- to "extension" -< x
  name <- getAttrValue0 "name" -< extension
  supported <- getAttrValue "supported" -< extension
  require <- listA $ parseRequire <<< to "require" -< extension
  returnA -< Extension name supported require

parseFeature :: ArrowXml a => a XmlTree Feature
parseFeature = proc x -> do
  name <- getAttrValue0 "name" -< x
  require <- listA $ parseRequire <<< to "require" -< x
  remove <- listA $ parseRemove <<< to "remove" -< x
  returnA -< Feature name require remove

parseGroup :: ArrowXml a => a XmlTree Group
parseGroup = proc x -> do
  group <- to "group" -< x
  name <- getAttrValue0 "name" -< group
  enum <- listA $ getAttrValue0 "name" <<< to "enum" -< group
  returnA -< Group name enum

parseRemove :: ArrowXml a => a XmlTree Remove
parseRemove = proc x -> do
  profile <- getAttrValue "profile" -< x
  comment <- getAttrValue "comment" -< x
  enums <- listA $ getAttrValue0 "name" <<< to "enum" -< x
  commands <- listA $ getAttrValue0 "name" <<< to "command" -< x
  returnA -< Remove profile comment enums commands

parseRequire :: ArrowXml a => a XmlTree Require
parseRequire = proc x -> do
  comment <- getAttrValue "comment" -< x
  enums <- listA $ getAttrValue0 "name" <<< to "enum" -< x
  commands <- listA $ getAttrValue0 "name" <<< to "command" -< x
  profile <- getAttrValue "profile" -< x
  returnA -< Require enums commands comment profile

parseType :: ArrowXml a => a XmlTree Type
parseType = proc x -> do
  ptype <- perhaps $ getText <<< getChildren <<< to "ptype" -< x
  pointer <- (getText <<< getChildren) >. length . filter (== '*') . concat -< x
  returnA -< Type
    { typeName = ptype
    , typePointer = pointer
    }

parse :: IOSLA (XIOState ()) XmlTree Registry
parse = proc x -> do
  registry <- to "registry" -< x
  groups <- listA $ parseGroup <<< to "groups" -< registry
  enums <- listA $ parseEnum <<< to "enums" -< registry
  extensions <- listA $ parseExtension <<< to "extensions" -< registry
  commands <- listA $ parseCommand <<< to "commands" -< registry
  features <- listA $ parseFeature <<< to "feature" -< registry
  returnA -< Registry
    { registryCommands = commands
    , registryEnums = enums
    , registryExtensions = extensions
    , registryFeatures = features
    , registryGroups = groups
    }

parseFile :: String -> IO Registry
parseFile file = return . head =<< runX (readDocument [withRemoveWS yes] file >>> parse)