{- |
Module      :  ./FreeCAD/Translator.hs
Description :  The main part of the module. Here the parsing, translation of the
               input xml is handled, as well as the I/O.
Copyright   :  (c) Robert Savu and Uni Bremen 2011
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Robert.Savu@dfki.de
Stability   :  experimental
Portability :  portable

Declaration of the abstract datatypes of FreeCAD terms
-}
module FreeCAD.Translator where

import Prelude
import FreeCAD.As
import Text.XML.Light
import Data.Maybe
import Data.Set as Set
import FreeCAD.Brep
import System.Directory
import System.IO
import System.Process
import System.FilePath
import FreeCAD.PrintAs ()
import Control.Monad.Reader (ReaderT (..))


getFreshTempDir :: IO FilePath
getFreshTempDir :: IO FilePath
getFreshTempDir = do
  FilePath
dir <- IO FilePath
getTemporaryDirectory
  (fp :: FilePath
fp, _) <- FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile FilePath
dir "hetsfc"
  FilePath -> IO ()
removeFile FilePath
fp
  FilePath -> IO ()
createDirectory FilePath
fp
  FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
fp

processFile :: FilePath -> IO Document
processFile :: FilePath -> IO Document
processFile fp :: FilePath
fp = do
  FilePath
tempDir <- IO FilePath
getFreshTempDir
  FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess "unzip" ["-o", FilePath
fp, "-d", FilePath
tempDir] []
  FilePath
xmlInput <- FilePath -> IO FilePath
readFile ([FilePath] -> FilePath
joinPath [FilePath
tempDir, "Document.xml"])
  let parsed :: Maybe Element
parsed = FilePath -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
parseXMLDoc FilePath
xmlInput
  Document
d <- ReaderT FilePath IO Document -> FilePath -> IO Document
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Element -> ReaderT FilePath IO Document
translate' (Element -> ReaderT FilePath IO Document)
-> Element -> ReaderT FilePath IO Document
forall a b. (a -> b) -> a -> b
$ Maybe Element -> Element
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Element
parsed) FilePath
tempDir
  FilePath -> IO ()
removeDirectoryRecursive FilePath
tempDir
  Document -> IO Document
forall (m :: * -> *) a. Monad m => a -> m a
return Document
d

-- constants used to find the appropriate subtree in the XML file:
objListQName :: QName
objListQName :: QName
objListQName = FilePath -> QName
unqual "ObjectData"

objQName :: QName
objQName :: QName
objQName = FilePath -> QName
unqual "Object"

objListEl :: Element -> Maybe Element
objListEl :: Element -> Maybe Element
objListEl = QName -> Element -> Maybe Element
findChild QName
objListQName

objList :: Element -> [Element]
objList :: Element -> [Element]
objList mbel :: Element
mbel = QName -> Element -> [Element]
findChildren QName
objQName (Maybe Element -> Element
forall a. HasCallStack => Maybe a -> a
fromJust (Element -> Maybe Element
objListEl Element
mbel))

firstThree :: String -> String
firstThree :: FilePath -> FilePath
firstThree = Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
Prelude.take 3

getName :: Element -> String
getName :: Element -> FilePath
getName el :: Element
el = Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust (QName -> Element -> Maybe FilePath
findAttr (FilePath -> QName
unqual "name") Element
el)
hasName :: String -> Element -> Bool
hasName :: FilePath -> Element -> Bool
hasName s :: FilePath
s el :: Element
el = Element -> FilePath
getName Element
el FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
s

childByName :: String -> Element -> Element
childByName :: FilePath -> Element -> Element
childByName s :: FilePath
s el :: Element
el = Maybe Element -> Element
forall a. HasCallStack => Maybe a -> a
fromJust (QName -> Element -> Maybe Element
findChild (FilePath -> QName
unqual FilePath
s) Element
el)
childByNameAttr :: String -> Element -> Element
childByNameAttr :: FilePath -> Element -> Element
childByNameAttr s :: FilePath
s el :: Element
el = Maybe Element -> Element
forall a. HasCallStack => Maybe a -> a
fromJust ((Element -> Bool) -> Element -> Maybe Element
filterChild (FilePath -> Element -> Bool
hasName FilePath
s) Element
el)

-- a Set constant -- TODO: find signature
setBaseObjs :: Set.Set String
setBaseObjs :: Set FilePath
setBaseObjs = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
fromList ["Box", "Sph", "Cyl", "Con", "Tor", "Cir", "Rec"]

isBaseObject :: Element -> Bool
isBaseObject :: Element -> Bool
isBaseObject el :: Element
el = FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
member (FilePath -> FilePath
firstThree (Element -> FilePath
getName Element
el)) Set FilePath
setBaseObjs
    {- identify (by its name) whether an object is simpe or extended
    returns true if it is a base object and false otherwise -}

getObject :: Element -> RIO NamedObject
getObject :: Element -> RIO NamedObject
getObject el :: Element
el | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Box" = BaseObject -> RIO NamedObject
mkBaseObject (BaseObject -> RIO NamedObject) -> BaseObject -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ Element -> BaseObject
getBox Element
elc
             | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Sph" = BaseObject -> RIO NamedObject
mkBaseObject (BaseObject -> RIO NamedObject) -> BaseObject -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ Element -> BaseObject
getSph Element
elc
             | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Cyl" = BaseObject -> RIO NamedObject
mkBaseObject (BaseObject -> RIO NamedObject) -> BaseObject -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ Element -> BaseObject
getCyl Element
elc
             | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Con" = BaseObject -> RIO NamedObject
mkBaseObject (BaseObject -> RIO NamedObject) -> BaseObject -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ Element -> BaseObject
getCon Element
elc
             | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Tor" = BaseObject -> RIO NamedObject
mkBaseObject (BaseObject -> RIO NamedObject) -> BaseObject -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ Element -> BaseObject
getTor Element
elc
             | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Cir" = BaseObject -> RIO NamedObject
mkBaseObject (BaseObject -> RIO NamedObject) -> BaseObject -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ Element -> BaseObject
getCir Element
elc
             | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Rec" = Element -> RIO NamedObject
mkRectangle Element
el
             | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Lin" = Element -> RIO NamedObject
mkLine Element
el -- TODO
             | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Cut" = Object -> RIO NamedObject
mkObject (Object -> RIO NamedObject) -> Object -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ Element -> Object
getCut Element
elc
             | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Com" = Object -> RIO NamedObject
mkObject (Object -> RIO NamedObject) -> Object -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ Element -> Object
getCom Element
elc
             | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Fus" = Object -> RIO NamedObject
mkObject (Object -> RIO NamedObject) -> Object -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ Element -> Object
getFus Element
elc
             | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Sec" = Object -> RIO NamedObject
mkObject (Object -> RIO NamedObject) -> Object -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ Element -> Object
getSec Element
elc
             | FilePath
tn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "Ext" = Object -> RIO NamedObject
mkObject (Object -> RIO NamedObject) -> Object -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ Element -> Object
getExt Element
elc
    where
      tn :: FilePath
tn = FilePath -> FilePath
firstThree (Element -> FilePath
getName Element
el)
      mkObject :: Object -> RIO NamedObject
mkObject = NamedObject -> RIO NamedObject
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedObject -> RIO NamedObject)
-> (Object -> NamedObject) -> Object -> RIO NamedObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> PlacedObject -> NamedObject
NamedObject (Element -> FilePath
getName Element
el)
                 (PlacedObject -> NamedObject)
-> (Object -> PlacedObject) -> Object -> NamedObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Placement -> Object -> PlacedObject
PlacedObject (Element -> Placement
findPlacement Element
elc)
      mkBaseObject :: BaseObject -> RIO NamedObject
mkBaseObject = Object -> RIO NamedObject
mkObject (Object -> RIO NamedObject)
-> (BaseObject -> Object) -> BaseObject -> RIO NamedObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseObject -> Object
BaseObject
      getBox :: Element -> BaseObject
getBox e :: Element
e = Double -> Double -> Double -> BaseObject
Box (FilePath -> Element -> Double
findFloat "Height" Element
e) (FilePath -> Element -> Double
findFloat "Width" Element
e)
                 (FilePath -> Element -> Double
findFloat "Length" Element
e)
      getSph :: Element -> BaseObject
getSph e :: Element
e = Double -> Double -> Double -> Double -> BaseObject
Sphere (FilePath -> Element -> Double
findFloat "Angle1" Element
e) (FilePath -> Element -> Double
findFloat "Angle2" Element
e)
                 (FilePath -> Element -> Double
findFloat "Angle3" Element
e) (FilePath -> Element -> Double
findFloat "Radius" Element
e)
      getCyl :: Element -> BaseObject
getCyl e :: Element
e = Double -> Double -> Double -> BaseObject
Cylinder (FilePath -> Element -> Double
findFloat "Angle" Element
e) (FilePath -> Element -> Double
findFloat "Height" Element
e)
                 (FilePath -> Element -> Double
findFloat "Radius" Element
e)
      getCon :: Element -> BaseObject
getCon e :: Element
e = Double -> Double -> Double -> Double -> BaseObject
Cone (FilePath -> Element -> Double
findFloat "Angle" Element
e) (FilePath -> Element -> Double
findFloat "Radius1" Element
e)
                 (FilePath -> Element -> Double
findFloat "Radius2" Element
elc) (FilePath -> Element -> Double
findFloat "Height" Element
e)
      getTor :: Element -> BaseObject
getTor e :: Element
e = Double -> Double -> Double -> Double -> Double -> BaseObject
Torus (FilePath -> Element -> Double
findFloat "Angle1" Element
e) (FilePath -> Element -> Double
findFloat "Angle2" Element
e)
                 (FilePath -> Element -> Double
findFloat "Angle3" Element
e) (FilePath -> Element -> Double
findFloat "Radius1" Element
e)
                 (FilePath -> Element -> Double
findFloat "Radius2" Element
e)
      getCir :: Element -> BaseObject
getCir e :: Element
e = Double -> Double -> Double -> BaseObject
Circle (FilePath -> Element -> Double
findFloat "StartAngle" Element
e) (FilePath -> Element -> Double
findFloat "EndAngle" Element
e)
                 (FilePath -> Element -> Double
findFloat "Radius" Element
e)
      getCut :: Element -> Object
getCut e :: Element
e = ExtendedObject -> ExtendedObject -> Object
Cut (FilePath -> Element -> ExtendedObject
findRef "Base" Element
e) (FilePath -> Element -> ExtendedObject
findRef "Tool" Element
e)
      getCom :: Element -> Object
getCom e :: Element
e = ExtendedObject -> ExtendedObject -> Object
Common (FilePath -> Element -> ExtendedObject
findRef "Base" Element
e) (FilePath -> Element -> ExtendedObject
findRef "Tool" Element
e)
      getSec :: Element -> Object
getSec e :: Element
e = ExtendedObject -> ExtendedObject -> Object
Section (FilePath -> Element -> ExtendedObject
findRef "Base" Element
e) (FilePath -> Element -> ExtendedObject
findRef "Tool" Element
e)
      getFus :: Element -> Object
getFus e :: Element
e = ExtendedObject -> ExtendedObject -> Object
Fusion (FilePath -> Element -> ExtendedObject
findRef "Base" Element
e) (FilePath -> Element -> ExtendedObject
findRef "Tool" Element
e)
      getExt :: Element -> Object
getExt e :: Element
e = ExtendedObject -> Vector3 -> Object
Extrusion (FilePath -> Element -> ExtendedObject
findRef "Base" Element
e) (FilePath -> Element -> Vector3
findPropVec "Dir" Element
e)
      elc :: Element
elc = Element -> Element
child Element
el
getObject _ = FilePath -> RIO NamedObject
forall a. HasCallStack => FilePath -> a
error "undefined object"


mkRectangle :: Element -> RIO NamedObject
mkRectangle :: Element -> RIO NamedObject
mkRectangle ef :: Element
ef = do
        let e :: Element
e = Element -> Element
child Element
ef
            el2 :: Element
el2 = FilePath -> Element -> Element
childByNameAttr "Shape" Element
e
            elx :: Element
elx = FilePath -> Element -> Element
childByName "Part" Element
el2
        (bo :: BaseObject
bo, place :: Placement
place) <- (FilePath, FilePath) -> RIO (BaseObject, Placement)
getBrep (FilePath -> Element -> FilePath
getVal "file" Element
elx, "rectangle")
        let obj :: Object
obj = BaseObject -> Object
BaseObject BaseObject
bo
            po :: PlacedObject
po = Placement -> Object -> PlacedObject
PlacedObject Placement
place Object
obj
        NamedObject -> RIO NamedObject
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedObject -> RIO NamedObject) -> NamedObject -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ FilePath -> PlacedObject -> NamedObject
NamedObject (FilePath -> Element -> FilePath
getVal "name" Element
ef) PlacedObject
po

mkLine :: Element -> RIO NamedObject
mkLine :: Element -> RIO NamedObject
mkLine ef :: Element
ef = do
        let e :: Element
e = Element -> Element
child Element
ef
            el2 :: Element
el2 = FilePath -> Element -> Element
childByNameAttr "Shape" Element
e
            elx :: Element
elx = FilePath -> Element -> Element
childByName "Part" Element
el2
        (bo :: BaseObject
bo, place :: Placement
place) <- (FilePath, FilePath) -> RIO (BaseObject, Placement)
getBrep (FilePath -> Element -> FilePath
getVal "file" Element
elx, "line")
        let obj :: Object
obj = BaseObject -> Object
BaseObject BaseObject
bo
            po :: PlacedObject
po = Placement -> Object -> PlacedObject
PlacedObject Placement
place Object
obj
        NamedObject -> RIO NamedObject
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedObject -> RIO NamedObject) -> NamedObject -> RIO NamedObject
forall a b. (a -> b) -> a -> b
$ FilePath -> PlacedObject -> NamedObject
NamedObject (FilePath -> Element -> FilePath
getVal "name" Element
ef) PlacedObject
po

getVal :: String -> Element -> String
getVal :: FilePath -> Element -> FilePath
getVal s :: FilePath
s el :: Element
el = Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust (QName -> Element -> Maybe FilePath
findAttr (FilePath -> QName
unqual FilePath
s) Element
el)

getFloatVal :: Element -> String
getFloatVal :: Element -> FilePath
getFloatVal el :: Element
el = FilePath -> Element -> FilePath
getVal "value" Element
el2
    where
        el2 :: Element
el2 = FilePath -> Element -> Element
childByName "Float" Element
el

getPlacementVals :: Element -> (String , String , String , String , String , String
                               , String)
getPlacementVals :: Element
-> (FilePath, FilePath, FilePath, FilePath, FilePath, FilePath,
    FilePath)
getPlacementVals el :: Element
el = (FilePath -> FilePath
m "Px", FilePath -> FilePath
m "Py", FilePath -> FilePath
m "Pz", FilePath -> FilePath
m "Q0", FilePath -> FilePath
m "Q1", FilePath -> FilePath
m "Q2", FilePath -> FilePath
m "Q3")
    where
        m :: FilePath -> FilePath
m s :: FilePath
s = FilePath -> Element -> FilePath
getVal FilePath
s Element
el2
        el2 :: Element
el2 = FilePath -> Element -> Element
childByName "PropertyPlacement" Element
el

getLinkVal :: Element -> String
getLinkVal :: Element -> FilePath
getLinkVal el :: Element
el = FilePath -> Element -> FilePath
getVal "value" Element
el2
    where
        el2 :: Element
el2 = FilePath -> Element -> Element
childByName "Link" Element
el

findFloat :: String -> Element -> Double
findFloat :: FilePath -> Element -> Double
findFloat s :: FilePath
s el :: Element
el = FilePath -> Double
forall a. Read a => FilePath -> a
read (Element -> FilePath
getFloatVal Element
el2)
    where
        el2 :: Element
el2 = FilePath -> Element -> Element
childByNameAttr FilePath
s Element
el

findPlacement :: Element -> FreeCAD.As.Placement
findPlacement :: Element -> Placement
findPlacement el :: Element
el = Vector3 -> Vector4 -> Placement
Placement (Double -> Double -> Double -> Vector3
Vector3 Double
a Double
b Double
c) (Double -> Double -> Double -> Double -> Vector4
Vector4 Double
d Double
e Double
f Double
g)
    where
        (sa :: FilePath
sa, sb :: FilePath
sb, sc :: FilePath
sc, sd :: FilePath
sd, se :: FilePath
se, sf :: FilePath
sf, sg :: FilePath
sg) = Element
-> (FilePath, FilePath, FilePath, FilePath, FilePath, FilePath,
    FilePath)
getPlacementVals Element
el2
        a :: Double
a = FilePath -> Double
forall a. Read a => FilePath -> a
read FilePath
sa
        b :: Double
b = FilePath -> Double
forall a. Read a => FilePath -> a
read FilePath
sb
        c :: Double
c = FilePath -> Double
forall a. Read a => FilePath -> a
read FilePath
sc
        d :: Double
d = FilePath -> Double
forall a. Read a => FilePath -> a
read FilePath
sd
        e :: Double
e = FilePath -> Double
forall a. Read a => FilePath -> a
read FilePath
se
        f :: Double
f = FilePath -> Double
forall a. Read a => FilePath -> a
read FilePath
sf
        g :: Double
g = FilePath -> Double
forall a. Read a => FilePath -> a
read FilePath
sg
        el2 :: Element
el2 = FilePath -> Element -> Element
childByNameAttr "Placement" Element
el

findRef :: String -> Element -> FreeCAD.As.ExtendedObject
findRef :: FilePath -> Element -> ExtendedObject
findRef s :: FilePath
s el :: Element
el = FilePath -> ExtendedObject
Ref (Element -> FilePath
getLinkVal Element
el2) where
    el2 :: Element
el2 = FilePath -> Element -> Element
childByNameAttr FilePath
s Element
el

findPropVec :: String -> Element -> FreeCAD.As.Vector3
findPropVec :: FilePath -> Element -> Vector3
findPropVec s :: FilePath
s el :: Element
el = Double -> Double -> Double -> Vector3
Vector3 Double
valueX Double
valueY Double
valueZ where
    el2 :: Element
el2 = FilePath -> Element -> Element
childByNameAttr FilePath
s Element
el
    propVec :: Element
propVec = Maybe Element -> Element
forall a. HasCallStack => Maybe a -> a
fromJust ( QName -> Element -> Maybe Element
findChild ( FilePath -> QName
unqual "PropertyVector" ) Element
el2)
    valueX :: Double
valueX = FilePath -> Double
forall a. Read a => FilePath -> a
read (FilePath -> Double) -> FilePath -> Double
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe FilePath
findAttr (FilePath -> QName
unqual "valueX") Element
propVec
    valueY :: Double
valueY = FilePath -> Double
forall a. Read a => FilePath -> a
read (FilePath -> Double) -> FilePath -> Double
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe FilePath
findAttr (FilePath -> QName
unqual "valueY") Element
propVec
    valueZ :: Double
valueZ = FilePath -> Double
forall a. Read a => FilePath -> a
read (FilePath -> Double) -> FilePath -> Double
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe FilePath
findAttr (FilePath -> QName
unqual "valueZ") Element
propVec

child :: Element -> Element
child :: Element -> Element
child el :: Element
el = [Element] -> Element
forall a. [a] -> a
head (Element -> [Element]
elChildren Element
el)

{- Facade function that translates the parsed XML document
into Haskell-FreeCAD datatype -}


translate' :: Element -> RIO Document
translate' :: Element -> ReaderT FilePath IO Document
translate' baseElement :: Element
baseElement = (Element -> RIO NamedObject)
-> [Element] -> ReaderT FilePath IO Document
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> RIO NamedObject
getObject ([Element] -> ReaderT FilePath IO Document)
-> [Element] -> ReaderT FilePath IO Document
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
objList Element
baseElement