{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SVDSort -> SVDSort -> Bool
$c/= :: SVDSort -> SVDSort -> Bool
== :: SVDSort -> SVDSort -> Bool
$c== :: SVDSort -> SVDSort -> Bool
Eq, Eq 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
min :: SVDSort -> SVDSort -> SVDSort
$cmin :: SVDSort -> SVDSort -> SVDSort
max :: SVDSort -> SVDSort -> SVDSort
$cmax :: SVDSort -> SVDSort -> SVDSort
>= :: SVDSort -> SVDSort -> Bool
$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
compare :: SVDSort -> SVDSort -> Ordering
$ccompare :: SVDSort -> SVDSort -> Ordering
Ord, 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
$cto :: forall x. Rep SVDSort x -> SVDSort
$cfrom :: forall x. SVDSort -> Rep SVDSort x
Generic, Int -> SVDSort -> ShowS
[SVDSort] -> ShowS
SVDSort -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SVDSort] -> ShowS
$cshowList :: [SVDSort] -> ShowS
show :: SVDSort -> String
$cshow :: SVDSort -> String
showsPrec :: Int -> SVDSort -> ShowS
$cshowsPrec :: Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SVDOptions -> SVDOptions -> Bool
$c/= :: SVDOptions -> SVDOptions -> Bool
== :: SVDOptions -> SVDOptions -> Bool
$c== :: SVDOptions -> SVDOptions -> Bool
Eq, Eq 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
min :: SVDOptions -> SVDOptions -> SVDOptions
$cmin :: SVDOptions -> SVDOptions -> SVDOptions
max :: SVDOptions -> SVDOptions -> SVDOptions
$cmax :: SVDOptions -> SVDOptions -> SVDOptions
>= :: SVDOptions -> SVDOptions -> Bool
$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
compare :: SVDOptions -> SVDOptions -> Ordering
$ccompare :: SVDOptions -> SVDOptions -> Ordering
Ord, 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
$cto :: forall x. Rep SVDOptions x -> SVDOptions
$cfrom :: forall x. SVDOptions -> Rep SVDOptions x
Generic, Int -> SVDOptions -> ShowS
[SVDOptions] -> ShowS
SVDOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SVDOptions] -> ShowS
$cshowList :: [SVDOptions] -> ShowS
show :: SVDOptions -> String
$cshow :: SVDOptions -> String
showsPrec :: Int -> SVDOptions -> ShowS
$cshowsPrec :: Int -> 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
svdOptionsSort :: SVDSort
svdOptionsExpand :: Bool
svdOptionsCheckContinuity :: Bool
svdOptionsCache :: Bool
svdOptionsAddReservedFields :: Bool
svdOptionsSort :: SVDOptions -> SVDSort
svdOptionsExpand :: SVDOptions -> Bool
svdOptionsCheckContinuity :: SVDOptions -> Bool
svdOptionsCache :: SVDOptions -> Bool
svdOptionsAddReservedFields :: SVDOptions -> Bool
..} 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 = forall a. Hashable a => a -> Int
Data.Hashable.hash String
s
      optsHash :: Int
optsHash = forall a. Hashable a => a -> Int
Data.Hashable.hash SVDOptions
opts
      caFile :: String
caFile =
        String
"/tmp/svdCache-"
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
fHash
        forall a. Semigroup a => a -> a -> a
<> String
"-"
        forall a. Semigroup a => a -> a -> a
<> 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
      forall a. Serialize a => ByteString -> Either String a
Data.Serialize.decode
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
Data.ByteString.Char8.readFile String
caFile
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left String
e ->
          forall a. HasCallStack => String -> a
error
            forall a b. (a -> b) -> a -> b
$ String
"Can't decode cached svd from "
            forall a. Semigroup a => a -> a -> a
<> String
caFile
            forall a. Semigroup a => a -> a -> a
<> String
" error was "
            forall a. Semigroup a => a -> a -> a
<> String
e
        Right Either String Device
x -> 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
        forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => a -> ByteString
Data.Serialize.encode Either String Device
res
      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
svdOptionsSort :: SVDSort
svdOptionsExpand :: Bool
svdOptionsCheckContinuity :: Bool
svdOptionsCache :: Bool
svdOptionsAddReservedFields :: Bool
svdOptionsSort :: SVDOptions -> SVDSort
svdOptionsExpand :: SVDOptions -> Bool
svdOptionsCheckContinuity :: SVDOptions -> Bool
svdOptionsCache :: SVDOptions -> Bool
svdOptionsAddReservedFields :: SVDOptions -> Bool
..} String
s = do
  [Device]
res <- forall c. IOSArrow XmlTree c -> IO [c]
runX (forall s b. SysConfigList -> String -> IOStateArrow s b XmlTree
readString [] String
s forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (cat :: * -> * -> *). ArrowXml cat => cat XmlTree Device
Data.SVD.Parse.svd)
  case [Device]
res of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"No device parsed"
    [Device
x] ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a -> Bool -> a
Data.Bool.bool
            forall a b. b -> Either a b
Right
            Device -> Either String Device
Data.SVD.Util.checkDeviceRegisterContinuity
            Bool
svdOptionsCheckContinuity
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. case SVDSort
svdOptionsSort of
            SVDSort
SVDSort_DontSort -> forall a. a -> a
id
            SVDSort
SVDSort_SortByAddresses -> Device -> Device
Data.SVD.Util.sortDeviceByAddresses
            SVDSort
SVDSort_SortByNames -> Device -> Device
Data.SVD.Util.sortDeviceByNames
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a -> Bool -> a
Data.Bool.bool
            forall a. a -> a
id
            Device -> Device
Data.SVD.Util.addReservedFields
            Bool
svdOptionsAddReservedFields
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a -> Bool -> a
Data.Bool.bool
            forall a. a -> a
id
            Device -> Device
Data.SVD.Dim.expandDevice
            Bool
svdOptionsExpand
        forall a b. (a -> b) -> a -> b
$ Device
x
    [Device]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 forall a. Default a => a
def