{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

module Data.SVD.IO
  ( parseSVD
  , parseSVDOptions
  , SVDOptions(..)
  ) where

import Data.Default.Class (Default(def))
import Data.Hashable (Hashable)
import Data.SVD.Types (Device)
import GHC.Generics (Generic)
import Text.XML.HXT.Core (readString, runX, (>>>))

import qualified Data.Bool
import qualified Data.ByteString.Char8
import qualified Data.Hashable
import qualified Data.Serialize
import qualified Data.SVD.Dim
import qualified Data.SVD.Parse
import qualified Data.SVD.Util
import qualified System.Directory

data SVDSort
  = SVDSort_DontSort
  | SVDSort_SortByNames
  | SVDSort_SortByAddresses
  deriving (SVDSort -> SVDSort -> Bool
(SVDSort -> SVDSort -> Bool)
-> (SVDSort -> SVDSort -> Bool) -> Eq SVDSort
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SVDSort -> SVDSort -> Bool
== :: SVDSort -> SVDSort -> Bool
$c/= :: SVDSort -> SVDSort -> Bool
/= :: SVDSort -> SVDSort -> Bool
Eq, Eq SVDSort
Eq SVDSort =>
(SVDSort -> SVDSort -> Ordering)
-> (SVDSort -> SVDSort -> Bool)
-> (SVDSort -> SVDSort -> Bool)
-> (SVDSort -> SVDSort -> Bool)
-> (SVDSort -> SVDSort -> Bool)
-> (SVDSort -> SVDSort -> SVDSort)
-> (SVDSort -> SVDSort -> SVDSort)
-> Ord SVDSort
SVDSort -> SVDSort -> Bool
SVDSort -> SVDSort -> Ordering
SVDSort -> SVDSort -> SVDSort
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SVDSort -> SVDSort -> Ordering
compare :: SVDSort -> SVDSort -> Ordering
$c< :: SVDSort -> SVDSort -> Bool
< :: SVDSort -> SVDSort -> Bool
$c<= :: SVDSort -> SVDSort -> Bool
<= :: SVDSort -> SVDSort -> Bool
$c> :: SVDSort -> SVDSort -> Bool
> :: SVDSort -> SVDSort -> Bool
$c>= :: SVDSort -> SVDSort -> Bool
>= :: SVDSort -> SVDSort -> Bool
$cmax :: SVDSort -> SVDSort -> SVDSort
max :: SVDSort -> SVDSort -> SVDSort
$cmin :: SVDSort -> SVDSort -> SVDSort
min :: SVDSort -> SVDSort -> SVDSort
Ord, (forall x. SVDSort -> Rep SVDSort x)
-> (forall x. Rep SVDSort x -> SVDSort) -> Generic SVDSort
forall x. Rep SVDSort x -> SVDSort
forall x. SVDSort -> Rep SVDSort x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SVDSort -> Rep SVDSort x
from :: forall x. SVDSort -> Rep SVDSort x
$cto :: forall x. Rep SVDSort x -> SVDSort
to :: forall x. Rep SVDSort x -> SVDSort
Generic, Int -> SVDSort -> ShowS
[SVDSort] -> ShowS
SVDSort -> String
(Int -> SVDSort -> ShowS)
-> (SVDSort -> String) -> ([SVDSort] -> ShowS) -> Show SVDSort
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SVDSort -> ShowS
showsPrec :: Int -> SVDSort -> ShowS
$cshow :: SVDSort -> String
show :: SVDSort -> String
$cshowList :: [SVDSort] -> ShowS
showList :: [SVDSort] -> ShowS
Show)

instance Hashable SVDSort

data SVDOptions = SVDOptions
  { SVDOptions -> Bool
svdOptionsAddReservedFields :: Bool
  -- ^ Fill in dummy reserved fields where
  -- holes would be in registers
  , SVDOptions -> Bool
svdOptionsCache :: Bool
  -- ^ Cache parsed SVD in /tmp
  -- based on a hash of the input svd file
  , SVDOptions -> Bool
svdOptionsCheckContinuity :: Bool
  -- ^ Check register continuity
  , SVDOptions -> Bool
svdOptionsExpand :: Bool
  -- ^ Expand dimensions and clusters
  , SVDOptions -> SVDSort
svdOptionsSort :: SVDSort
  -- ^ Sorting
  } deriving (SVDOptions -> SVDOptions -> Bool
(SVDOptions -> SVDOptions -> Bool)
-> (SVDOptions -> SVDOptions -> Bool) -> Eq SVDOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SVDOptions -> SVDOptions -> Bool
== :: SVDOptions -> SVDOptions -> Bool
$c/= :: SVDOptions -> SVDOptions -> Bool
/= :: SVDOptions -> SVDOptions -> Bool
Eq, Eq SVDOptions
Eq SVDOptions =>
(SVDOptions -> SVDOptions -> Ordering)
-> (SVDOptions -> SVDOptions -> Bool)
-> (SVDOptions -> SVDOptions -> Bool)
-> (SVDOptions -> SVDOptions -> Bool)
-> (SVDOptions -> SVDOptions -> Bool)
-> (SVDOptions -> SVDOptions -> SVDOptions)
-> (SVDOptions -> SVDOptions -> SVDOptions)
-> Ord SVDOptions
SVDOptions -> SVDOptions -> Bool
SVDOptions -> SVDOptions -> Ordering
SVDOptions -> SVDOptions -> SVDOptions
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SVDOptions -> SVDOptions -> Ordering
compare :: SVDOptions -> SVDOptions -> Ordering
$c< :: SVDOptions -> SVDOptions -> Bool
< :: SVDOptions -> SVDOptions -> Bool
$c<= :: SVDOptions -> SVDOptions -> Bool
<= :: SVDOptions -> SVDOptions -> Bool
$c> :: SVDOptions -> SVDOptions -> Bool
> :: SVDOptions -> SVDOptions -> Bool
$c>= :: SVDOptions -> SVDOptions -> Bool
>= :: SVDOptions -> SVDOptions -> Bool
$cmax :: SVDOptions -> SVDOptions -> SVDOptions
max :: SVDOptions -> SVDOptions -> SVDOptions
$cmin :: SVDOptions -> SVDOptions -> SVDOptions
min :: SVDOptions -> SVDOptions -> SVDOptions
Ord, (forall x. SVDOptions -> Rep SVDOptions x)
-> (forall x. Rep SVDOptions x -> SVDOptions) -> Generic SVDOptions
forall x. Rep SVDOptions x -> SVDOptions
forall x. SVDOptions -> Rep SVDOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SVDOptions -> Rep SVDOptions x
from :: forall x. SVDOptions -> Rep SVDOptions x
$cto :: forall x. Rep SVDOptions x -> SVDOptions
to :: forall x. Rep SVDOptions x -> SVDOptions
Generic, Int -> SVDOptions -> ShowS
[SVDOptions] -> ShowS
SVDOptions -> String
(Int -> SVDOptions -> ShowS)
-> (SVDOptions -> String)
-> ([SVDOptions] -> ShowS)
-> Show SVDOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SVDOptions -> ShowS
showsPrec :: Int -> SVDOptions -> ShowS
$cshow :: SVDOptions -> String
show :: SVDOptions -> String
$cshowList :: [SVDOptions] -> ShowS
showList :: [SVDOptions] -> ShowS
Show)

instance Default SVDOptions where
  def :: SVDOptions
def = SVDOptions
    { svdOptionsAddReservedFields :: Bool
svdOptionsAddReservedFields = Bool
True
    , svdOptionsCache :: Bool
svdOptionsCache = Bool
True
    , svdOptionsCheckContinuity :: Bool
svdOptionsCheckContinuity = Bool
True
    , svdOptionsExpand :: Bool
svdOptionsExpand = Bool
True
    , svdOptionsSort :: SVDSort
svdOptionsSort = SVDSort
SVDSort_SortByAddresses
    }

instance Hashable SVDOptions

parseSVDOptions
  :: SVDOptions
  -> String
  -> IO (Either String Device)
parseSVDOptions :: SVDOptions -> String -> IO (Either String Device)
parseSVDOptions opts :: SVDOptions
opts@SVDOptions{Bool
SVDSort
svdOptionsAddReservedFields :: SVDOptions -> Bool
svdOptionsCache :: SVDOptions -> Bool
svdOptionsCheckContinuity :: SVDOptions -> Bool
svdOptionsExpand :: SVDOptions -> Bool
svdOptionsSort :: SVDOptions -> SVDSort
svdOptionsAddReservedFields :: Bool
svdOptionsCache :: Bool
svdOptionsCheckContinuity :: Bool
svdOptionsExpand :: Bool
svdOptionsSort :: SVDSort
..} String
f = do
  String
s <- String -> IO String
readFile String
f
  -- If caching is enabled we hash the input
  -- string + options and try to load
  -- serialized binary from cache if it exists
  -- or create one if not for further invocations
  let fHash :: Int
fHash = String -> Int
forall a. Hashable a => a -> Int
Data.Hashable.hash String
s
      optsHash :: Int
optsHash = SVDOptions -> Int
forall a. Hashable a => a -> Int
Data.Hashable.hash SVDOptions
opts
      caFile :: String
caFile =
        String
"/tmp/svdCache-"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
fHash
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
optsHash

  if Bool -> Bool
not Bool
svdOptionsCache
  then SVDOptions -> String -> IO (Either String Device)
parseSVDFromString SVDOptions
opts String
s
  else do
    Bool
hasCached <- String -> IO Bool
System.Directory.doesFileExist String
caFile
    if Bool
hasCached
    then
      ByteString -> Either String (Either String Device)
forall a. Serialize a => ByteString -> Either String a
Data.Serialize.decode
      (ByteString -> Either String (Either String Device))
-> IO ByteString -> IO (Either String (Either String Device))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
Data.ByteString.Char8.readFile String
caFile
      IO (Either String (Either String Device))
-> (Either String (Either String Device)
    -> IO (Either String Device))
-> IO (Either String Device)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left String
e ->
          String -> IO (Either String Device)
forall a. HasCallStack => String -> a
error
            (String -> IO (Either String Device))
-> String -> IO (Either String Device)
forall a b. (a -> b) -> a -> b
$ String
"Can't decode cached svd from "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
caFile
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" error was "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e
        Right Either String Device
x -> Either String Device -> IO (Either String Device)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String Device
x
    else do
      Either String Device
res <- SVDOptions -> String -> IO (Either String Device)
parseSVDFromString SVDOptions
opts String
s
      String -> ByteString -> IO ()
Data.ByteString.Char8.writeFile
        String
caFile
        (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Either String Device -> ByteString
forall a. Serialize a => a -> ByteString
Data.Serialize.encode Either String Device
res
      Either String Device -> IO (Either String Device)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String Device
res

parseSVDFromString
  :: SVDOptions
  -> String
  -> IO (Either String Device)
parseSVDFromString :: SVDOptions -> String -> IO (Either String Device)
parseSVDFromString SVDOptions{Bool
SVDSort
svdOptionsAddReservedFields :: SVDOptions -> Bool
svdOptionsCache :: SVDOptions -> Bool
svdOptionsCheckContinuity :: SVDOptions -> Bool
svdOptionsExpand :: SVDOptions -> Bool
svdOptionsSort :: SVDOptions -> SVDSort
svdOptionsAddReservedFields :: Bool
svdOptionsCache :: Bool
svdOptionsCheckContinuity :: Bool
svdOptionsExpand :: Bool
svdOptionsSort :: SVDSort
..} String
s = do
  [Device]
res <- IOSArrow XmlTree Device -> IO [Device]
forall c. IOSArrow XmlTree c -> IO [c]
runX (SysConfigList -> String -> IOStateArrow () XmlTree XmlTree
forall s b. SysConfigList -> String -> IOStateArrow s b XmlTree
readString [] String
s IOStateArrow () XmlTree XmlTree
-> IOSArrow XmlTree Device -> IOSArrow XmlTree Device
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> IOSArrow XmlTree Device
forall (cat :: * -> * -> *). ArrowXml cat => cat XmlTree Device
Data.SVD.Parse.svd)
  case [Device]
res of
    [] -> Either String Device -> IO (Either String Device)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Device -> IO (Either String Device))
-> Either String Device -> IO (Either String Device)
forall a b. (a -> b) -> a -> b
$ String -> Either String Device
forall a b. a -> Either a b
Left String
"No device parsed"
    [Device
x] ->
          Either String Device -> IO (Either String Device)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Either String Device -> IO (Either String Device))
-> (Device -> Either String Device)
-> Device
-> IO (Either String Device)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Device -> Either String Device)
-> (Device -> Either String Device)
-> Bool
-> Device
-> Either String Device
forall a. a -> a -> Bool -> a
Data.Bool.bool
            Device -> Either String Device
forall a b. b -> Either a b
Right
            Device -> Either String Device
Data.SVD.Util.checkDeviceRegisterContinuity
            Bool
svdOptionsCheckContinuity
        (Device -> Either String Device)
-> (Device -> Device) -> Device -> Either String Device
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case SVDSort
svdOptionsSort of
            SVDSort
SVDSort_DontSort -> Device -> Device
forall a. a -> a
id
            SVDSort
SVDSort_SortByAddresses -> Device -> Device
Data.SVD.Util.sortDeviceByAddresses
            SVDSort
SVDSort_SortByNames -> Device -> Device
Data.SVD.Util.sortDeviceByNames
        (Device -> Device) -> (Device -> Device) -> Device -> Device
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Device -> Device)
-> (Device -> Device) -> Bool -> Device -> Device
forall a. a -> a -> Bool -> a
Data.Bool.bool
            Device -> Device
forall a. a -> a
id
            Device -> Device
Data.SVD.Util.addReservedFields
            Bool
svdOptionsAddReservedFields
        (Device -> Device) -> (Device -> Device) -> Device -> Device
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Device -> Device)
-> (Device -> Device) -> Bool -> Device -> Device
forall a. a -> a -> Bool -> a
Data.Bool.bool
            Device -> Device
forall a. a -> a
id
            Device -> Device
Data.SVD.Dim.expandDevice
            Bool
svdOptionsExpand
        (Device -> IO (Either String Device))
-> Device -> IO (Either String Device)
forall a b. (a -> b) -> a -> b
$ Device
x
    [Device]
_ -> Either String Device -> IO (Either String Device)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Device -> IO (Either String Device))
-> Either String Device -> IO (Either String Device)
forall a b. (a -> b) -> a -> b
$ String -> Either String Device
forall a b. a -> Either a b
Left String
"Multiple devices parsed"

parseSVD
  :: String
  -> IO (Either String Device)
parseSVD :: String -> IO (Either String Device)
parseSVD = SVDOptions -> String -> IO (Either String Device)
parseSVDOptions SVDOptions
forall a. Default a => a
def