never executed always true always false

    1 -- All extensions should be enabled explicitly due to doctest in this module.
    2 {-# LANGUAGE Arrows #-}
    3 {-# LANGUAGE ImportQualifiedPost #-}
    4 {-# LANGUAGE NamedFieldPuns #-}
    5 {-# LANGUAGE OverloadedStrings #-}
    6 
    7 {- |
    8 Module      : NITTA.Frontends.XMILE.DocumentParser
    9 Description : Parses XMILE source file to internal tree structure
   10 Copyright   : (c) Artur Gogiyan, 2022
   11 License     : BSD3
   12 Maintainer  : artur.gogiyan@gmail.com
   13 Stability   : experimental
   14 -}
   15 module NITTA.Frontends.XMILE.DocumentParser (
   16     parseDocument,
   17     Content (..),
   18     Stock (..),
   19     Aux (..),
   20     Flow (..),
   21     SimSpec (..),
   22 ) where
   23 
   24 import Data.Text qualified as T
   25 import NITTA.Frontends.XMILE.MathParser
   26 import Text.XML.HXT.Arrow.ReadDocument
   27 import Text.XML.HXT.Core
   28 
   29 data Content = Content
   30     { xcSimSpecs :: SimSpec
   31     , xcFlows :: [Flow]
   32     , xcAuxs :: [Aux]
   33     , xcStocks :: [Stock]
   34     }
   35     deriving (Show, Eq)
   36 
   37 data SimSpec = SimSpec
   38     { xssStart :: Double
   39     , xssStop :: Double
   40     , xssDt :: Double
   41     }
   42     deriving (Show, Eq)
   43 
   44 newtype Model = Model
   45     {xmVariables :: Variables}
   46     deriving (Show, Eq)
   47 
   48 data Variables = Variables
   49     { xvFlows :: [Flow]
   50     , xvAuxs :: [Aux]
   51     , xvStocks :: [Stock]
   52     }
   53     deriving (Show, Eq)
   54 
   55 data Flow = Flow
   56     { xfName :: T.Text
   57     , xfEquation :: XMExpr
   58     }
   59     deriving (Show, Eq)
   60 
   61 data Aux = Aux
   62     { xaName :: T.Text
   63     , xaEquation :: XMExpr
   64     }
   65     deriving (Show, Eq)
   66 
   67 data Stock = Stock
   68     { xsName :: T.Text
   69     , xsEquation :: XMExpr
   70     , xsInflow :: Maybe T.Text
   71     , xsOutflow :: Maybe T.Text
   72     }
   73     deriving (Show, Eq)
   74 
   75 data AlgState v x = AlgState
   76     { xasSimSpec :: SimSpec
   77     , xasModel :: Model
   78     }
   79     deriving (Show, Eq)
   80 
   81 parseDocument src =
   82     head $
   83         runLA
   84             ( xreadDoc
   85                 >>> removeAllWhiteSpace
   86                 >>> proc st -> do
   87                     xcSimSpecs <- parseSimSpec -< st
   88                     xcFlows <- parseFlows -< st
   89                     xcAuxs <- parseAuxs -< st
   90                     xcStocks <- parseStocks -< st
   91                     returnA -< Content{xcSimSpecs, xcFlows, xcAuxs, xcStocks}
   92             )
   93             src
   94 
   95 parseSimSpec =
   96     atTag "sim_specs"
   97         >>> proc x -> do
   98             stop <- text <<< atTag "stop" -< x
   99             start <- text <<< atTag "start" -< x
  100             dt <- text <<< atTag "dt" -< x
  101             returnA -< SimSpec{xssStart = read start, xssStop = read stop, xssDt = read dt}
  102 
  103 parseFlows =
  104     atTag "variables"
  105         >>> listA
  106             ( atTag "flow"
  107                 >>> proc flow -> do
  108                     eqn <- text <<< atTag "eqn" -< flow
  109                     name <- atAttr "name" -< flow
  110                     returnA -< Flow{xfEquation = parseXmileEquation eqn, xfName = replaceSpaces $ T.pack name}
  111             )
  112 
  113 parseAuxs =
  114     atTag "variables"
  115         >>> listA
  116             ( atTag "aux"
  117                 >>> proc aux -> do
  118                     eqn <- text <<< atTag "eqn" -< aux
  119                     name <- atAttr "name" -< aux
  120                     returnA -< Aux{xaEquation = parseXmileEquation eqn, xaName = replaceSpaces $ T.pack name}
  121             )
  122 
  123 parseStocks =
  124     atTag "variables"
  125         >>> listA
  126             ( atTag "stock"
  127                 >>> proc stock -> do
  128                     eqn <- text <<< atTag "eqn" -< stock
  129                     outflow <- getTagOrNothing "outflow" -< stock
  130                     inflow <- getTagOrNothing "inflow" -< stock
  131                     name <- atAttr "name" -< stock
  132                     returnA
  133                         -<
  134                             Stock
  135                                 { xsEquation = parseXmileEquation eqn
  136                                 , xsName = replaceSpaces $ T.pack name
  137                                 , xsOutflow = replaceSpaces <$> outflow
  138                                 , xsInflow = replaceSpaces <$> inflow
  139                                 }
  140             )
  141     where
  142         getTagOrNothing name =
  143             (atTag name >>> text >>> arr (\x -> Just (T.pack x)))
  144                 `orElse` arr (const Nothing)
  145 
  146 replaceSpaces str = T.filter (/= '"') $ T.replace " " "_" str
  147 
  148 atTag tag = deep (isElem >>> hasName tag)
  149 atAttr attrName = deep (isElem >>> getAttrValue attrName)
  150 text = getChildren >>> getText