{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DuplicateRecordFields #-}

module Parser where

import           Control.Monad.Except
import           Control.Monad.State.Lazy
import           Data.ByteString               as BS
                                                ( readFile )
import           Data.ByteString.Lazy          as BSL
                                                ( writeFile )
import qualified Data.Csv                      as CSV
import           Data.Fixed                     ( mod' )
import qualified Data.HashMap.Lazy             as HM
import           Data.List
import           Data.List.Unique
import qualified Data.Map                      as Map
import           Data.Maybe
import           Debug.Trace                    ( traceShow
                                                , traceShowM
                                                )
import qualified Language.OpenSCAD             as LS
import qualified SCAD as SC
import           Shared
import           System.Directory
import           System.FilePath
import           System.IO.Unsafe
import           Walker
import           Data.Hashable                            ( hash )

import Debug.Trace (traceShowId)

data ExprRes = RNum Double | RString String | RBool Bool | RVec [ExprRes] | RUndef deriving (Show, Eq)
type Arg = (String, ExprRes)
data ObjectRes = RUnion [ObjectRes] | RTranslate [Arg] (Maybe ObjectRes)  | RRotate [Arg] (Maybe ObjectRes) | RPart {
        rp_name :: String,
        rp_model :: SCADModel,
        rp_printed :: Bool } deriving (Show, Eq)

-- [args] ... [body]
type ModuleDefContent = ([(LS.Ident, Maybe LS.Expr)], [LS.Object])
data Scope = Scope
    { vars       :: HM.HashMap String ExprRes
    , mods       :: HM.HashMap String ModuleDefContent
    , func       :: HM.HashMap String ([LS.Ident], LS.Expr)
    , children   :: Maybe ObjectRes
    , call_stack :: [String]
    }

type EvalM a = ExceptT String (State Scope) a

emptyScope :: Scope
emptyScope = Scope HM.empty HM.empty HM.empty Nothing []

getScopeVar :: String -> EvalM (Maybe ExprRes)
getScopeVar key = do
    lift $ gets (\s -> HM.lookup key $ vars s)

insertScopeVar :: String -> ExprRes -> EvalM ()
insertScopeVar key val = do
    lift $ modify (\s -> s { vars = HM.insert key val $ vars s })

getScopeModule :: String -> EvalM (Maybe ModuleDefContent)
getScopeModule key = do
    lift $ gets (\s -> HM.lookup key $ mods s)

insertScopeModule :: String -> ModuleDefContent -> EvalM ()
insertScopeModule k v = do
    lift $ modify (\s -> s { mods = HM.insert k v $ mods s })

getScopeFunc :: String -> EvalM (Maybe ([LS.Ident], LS.Expr))
getScopeFunc k = do
    lift $ gets (\s -> HM.lookup k $ func s)

insertScopeFunc :: String -> ([LS.Ident], LS.Expr) -> EvalM ()
insertScopeFunc k v = do
    lift $ modify (\s -> s { func = HM.insert k v $ func s })

getScopeChildren :: EvalM (Maybe ObjectRes)
getScopeChildren = do
    lift $ gets (\s -> children s)

insertScopeChildren :: ObjectRes -> EvalM ()
insertScopeChildren ch = do
    lift $ modify (\s -> s { children = Just ch })

pushStack :: String -> EvalM ()
pushStack msg = do
    lift $ modify (\s -> s { call_stack = call_stack s ++ [msg] })

popStack :: EvalM ()
popStack = do
    lift $ modify (\s -> s { call_stack = init $ call_stack s })

withCallStack :: String -> EvalM a -> EvalM a
withCallStack msg rec = do
    pushStack msg
    res <- rec
    popStack
    return res

printModuleScope :: EvalM ()
printModuleScope = do
    s <- lift $ gets (\s -> HM.keys $ mods s)
    traceShowM ("Scope: " ++ show s)

raiseError :: String -> EvalM a
raiseError msg = do
    cstack <- lift $ gets call_stack
    throwError
        (  "Call stack:\n"
        ++ intercalate "\n" ((" - " ++) <$> cstack)
        ++ "\n Error in evaluation:\n    "
        ++ msg
        )

loadScope :: [LS.TopLevel] -> EvalM ()
loadScope cmp = withCallStack "load_scope" $ do
    f cmp
    insertScopeVar "undef" RUndef
  where
    f :: [LS.TopLevel] -> EvalM ()
    f []       = return ()
    f (x : xs) = do
        case x of
            LS.TopLevelScope obj -> case obj of
                LS.ModuleDef (LS.Ident name) args body -> do
                    insertScopeModule name (args, body)
                LS.VarDef (LS.Ident name) expr -> do
                    e <- evalExpr expr
                    insertScopeVar name e
                LS.FuncDef (LS.Ident name) args body -> do
                    insertScopeFunc name (args, body)
                _ -> return ()
            _ -> return ()
        f xs

localScope :: EvalM a -> EvalM a
localScope sub = do
    s <- lift $ get
    let x = evalState (runExceptT sub) s
    case x of
        Left  err -> throwError err
        Right a   -> return a

exprResToLS :: ExprRes -> LS.Expr
exprResToLS v = case v of
    RNum    n -> LS.ENum n
    RString s -> LS.EString s
    RBool   b -> LS.EBool b
    RVec    n -> LS.EVec (exprResToLS <$> n)

evalUntilParts :: Filename -> LS.Object -> [LS.TopLevel] -> [SimplePart]
evalUntilParts root_file obj cmap = case res of
    Left  err   -> error err
    Right child -> extract child
  where
    res :: Either String ObjectRes
    res = evalState (runExceptT (evalScad root_file obj cmap)) emptyScope

    extract :: ObjectRes -> [SimplePart]
    extract (RUnion children      ) = concat $ extract <$> children
    extract (RTranslate _ mb_child) = maybe [] extract mb_child
    extract (RRotate    _ mb_child) = maybe [] extract mb_child
    extract (RPart name model _) =
        [ Part { part_name      = name
               , model          = model
               , part_weight    = Nothing
               , center_of_mass = Nothing
               }
        ]

evalExpr :: LS.Expr -> EvalM ExprRes
evalExpr e = withCallStack ("eval expr: " ++ show e) $ case e of
    LS.EVar (LS.Ident name) -> do
        val <- getScopeVar name
        case val of
            Just expr -> return expr
            Nothing   -> raiseError ("can't find variable in scope: " ++ name)
    LS.EIndex base index -> do
        ieval <- evalExpr index
        beval <- evalExpr base
        case ieval of
            RNum i -> case beval of
                RVec l -> return $ l !! (round i)
                _      -> raiseError "error"
            _ -> raiseError "e"
    LS.ENum val  -> return $ RNum val
    LS.EVec vals -> do
        e <- sequence $ evalExpr <$> vals
        return $ RVec e
    LS.ERange (LS.Range from to mb_step) -> do
        s <- step
        f <- from_v
        t <- to_v
        return $ RVec $ RNum <$> enumFromThenTo f s t
      where
        step :: EvalM Double
        step = (mapM evalExpr mb_step) >>= \case
            Just (RNum s) -> return s
            Just _        -> raiseError "step should be number"
            _             -> return 1
        from_v :: EvalM Double
        from_v = (evalExpr from) >>= \case
            RNum v -> return v
            _      -> raiseError "from should be number"
        to_v :: EvalM Double
        to_v = evalExpr to >>= \case
            RNum v -> return v
            _      -> raiseError "to should be number"
    LS.EString s                  -> return $ RString s
    LS.EBool   b                  -> return $ RBool b
    LS.EFunc (LS.Ident name) args -> eval_func name args
    LS.ENegate exp                -> do
        e <- evalExpr exp
        case e of
            RNum n -> return $ RNum (-n)
            _      -> raiseError ("can't negate: " ++ show exp)
    LS.EPlus      lh rh -> (eval_binary_num lh rh (+))
    LS.EMinus     lh rh -> (eval_binary_num lh rh (-))
    LS.EMult      lh rh -> (eval_binary_num lh rh (*))
    LS.EDiv       lh rh -> (eval_binary_num lh rh (/))
    LS.EMod       lh rh -> (eval_binary_num lh rh (mod'))
    LS.EEquals    lh rh -> (eval_binary_bool lh rh (==))
    LS.ENotEquals lh rh -> (eval_binary_bool lh rh (/=))
    LS.EGT        lh rh -> (eval_binary_num_bool lh rh (>))
    LS.EGE        lh rh -> (eval_binary_num_bool lh rh (>=))
    LS.ELT        lh rh -> (eval_binary_num_bool lh rh (<))
    LS.ELE        lh rh -> (eval_binary_num_bool lh rh (<=))
    LS.ENot exp         -> do
        e <- evalExpr exp
        case e of
            RBool b -> return $ RBool (not b)
            _       -> raiseError "can't negate nonbool"
    LS.EOr  lh rh          -> (eval_binary_bool lh rh (||))
    LS.EAnd lh rh          -> (eval_binary_bool lh rh (&&))
    LS.ETernary cond lh rh -> do
        e <- evalExpr cond
        case e of
            RBool b -> if b then evalExpr lh else evalExpr rh
            _       -> raiseError "nonbool in ternary condition"
    LS.EParen e -> evalExpr e
  where
    eval_func :: String -> [LS.Argument LS.Expr] -> EvalM ExprRes
    eval_func name args
        | name == "sqrt" = do
            ee <- e_args args
            case head ee of
                RNum n -> return $ RNum $ sqrt n
                _      -> raiseError ("arg to sqrt has to be num: " ++ show ee)
        | name == "pow" = do
            ee <- e_args args
            case (head ee, head $ tail ee) of
                (RNum b, RNum e) -> return $ RNum (b ** e)
                _ -> raiseError ("args to sqrt has to ne nums" ++ show ee)
        | name == "str" = do
            ee <- e_args args
            return $ RString $ intercalate "" (expr_to_str <$> ee)
        | otherwise = withCallStack ("eval_func: " ++ name ++ " " ++ show args)
        $ do
              val <- getScopeFunc name
              case val of
                  (Just (def_args, body)) -> do
                      args_to_scope_f args def_args
                      evalExpr body
                  Nothing -> raiseError ("can't find function: " ++ name)
      where
        expr_to_str :: ExprRes -> String
        expr_to_str a = case a of
            RNum    n -> show n
            RString s -> s
            RBool   b -> show b
            RVec    v -> "[" ++ intercalate ", " (expr_to_str <$> v) ++ "]"
            RUndef    -> "undef"

        e_args :: [LS.Argument LS.Expr] -> EvalM [ExprRes]
        e_args []                     = return []
        e_args ((LS.Argument e) : xs) = do
            ee  <- evalExpr e
            sub <- e_args xs
            return $ ee : sub

        args_to_scope_f :: [LS.Argument LS.Expr] -> [LS.Ident] -> EvalM ()
        args_to_scope_f [] [] = return ()
        args_to_scope_f [] xs = raiseError
            (  "function "
            ++ name
            ++ " undefined args: "
            ++ show xs
            ++ " src: "
            ++ show args
            )
        args_to_scope_f ((LS.Argument e) : as) ((LS.Ident key) : ks) = do
            ee <- evalExpr e
            insertScopeVar key ee
            args_to_scope_f as ks
        args_to_scope_f ((LS.NamedArgument (LS.Ident k) e) : as) keys = do
            ee <- evalExpr e
            insertScopeVar k ee
            args_to_scope_f as (filter (\(LS.Ident name) -> name /= k) keys)
    eval_binary_bool
        :: LS.Expr -> LS.Expr -> (Bool -> Bool -> Bool) -> EvalM ExprRes
    eval_binary_bool lh rh op = do
        lh_v <- evalExpr lh
        rh_v <- evalExpr rh
        case (lh_v, rh_v) of
            (RBool lh_val, RBool rh_val) -> return $ RBool (op lh_val rh_val)
            _ -> raiseError "use only bool in operators"

    eval_binary_num
        :: LS.Expr -> LS.Expr -> (Double -> Double -> Double) -> EvalM ExprRes
    eval_binary_num lh rh op = do
        lh_v <- evalExpr lh
        rh_v <- evalExpr rh
        return $ f lh_v rh_v
      where -- error checking wroooooong
        f :: ExprRes -> ExprRes -> ExprRes
        f (RNum lh_val) (RNum rh_val) = RNum (op lh_val rh_val)
        f (RVec lh_vec) (RVec rh_vec) = RVec $ zipWith f lh_vec rh_vec

    eval_binary_num_bool
        :: LS.Expr -> LS.Expr -> (Double -> Double -> Bool) -> EvalM ExprRes
    eval_binary_num_bool lh rh op = do
        lh_v <- evalExpr lh
        rh_v <- evalExpr rh
        case (lh_v, rh_v) of
            (RNum lh_val, RNum rh_val) -> return $ RBool (op lh_val rh_val)
            _ -> raiseError "use only numbers in operators"


evalScad :: Filename -> LS.Object -> [LS.TopLevel] -> EvalM ObjectRes
evalScad root_file obj cmap =
    withCallStack ("eval_scad: " ++ show obj ++ "\n    from: " ++ root_file)
        $ do
              loadScope cmap
              eval_object obj
  where
    find_user_module :: [LS.TopLevel] -> String -> Maybe LS.Object
    find_user_module []       _    = Nothing
    find_user_module (x : xs) name = case x of
        (LS.TopLevelScope (LS.ModuleDef (LS.Ident def_name) args body)) ->
            if def_name == name
                then Just $ LS.ModuleDef (LS.Ident def_name) args body
                else find_user_module xs name
        _ -> find_user_module xs name

    args_to_scope
        :: [LS.Argument LS.Expr] -> [(LS.Ident, Maybe LS.Expr)] -> EvalM ()
    args_to_scope ((LS.Argument expr) : call_args) (((LS.Ident name), _) : def_args)
        = do
            ee <- evalExpr expr
            insertScopeVar name ee
            args_to_scope call_args def_args
    args_to_scope ((LS.Argument x) : _) [] =
        raiseError ("too many unnamed args: " ++ show x)
    args_to_scope ((LS.NamedArgument (LS.Ident name) expr) : call_args) def_args
        = do
            let new_def_args =
                    filter (\((LS.Ident k), _) -> k /= name) def_args
            ee <- evalExpr expr
            insertScopeVar name ee
            args_to_scope call_args new_def_args
    args_to_scope [] ((x, Nothing) : _) =
        raiseError ("arg missing: " ++ show x)
    args_to_scope [] (((LS.Ident name), Just val) : def_args) = do
        ee <- evalExpr val
        insertScopeVar name ee
        args_to_scope [] def_args
    args_to_scope [] [] = return ()

    verify_call_args :: [LS.Argument LS.Expr] -> EvalM ()
    verify_call_args args = do
        let pairs = zip args (tail args)
        if any (\(x, y) -> f x y) pairs
            then raiseError "arguments has to be unnamend and than named"
            else return ()
      where
        f :: LS.Argument LS.Expr -> LS.Argument LS.Expr -> Bool
        f (LS.NamedArgument _ _) (LS.Argument _) = True
        f _                      _               = False

    eval_args :: [LS.Argument LS.Expr] -> [String] -> EvalM [Arg]
    eval_args args names = do
        verify_call_args args
        f args names
      where
        f :: [LS.Argument LS.Expr] -> [String] -> EvalM [Arg]
        f ((LS.Argument e) : sub_args) (n : sub_names) = do
            ev  <- evalExpr e
            rec <- f sub_args sub_names
            return $ (n, ev) : rec
        f ((LS.NamedArgument (LS.Ident k) e) : sub_args) sub_names = do
            ev  <- evalExpr e
            rec <- f sub_args sub_names
            return $ (k, ev) : rec
        f []      _  = return []
        f (x : _) [] = raiseError ("too many unnamed arguments: " ++ show x)

    eval_scad_args :: [LS.Argument LS.Expr] -> EvalM [LS.Argument LS.Expr]
    eval_scad_args []                     = return []
    eval_scad_args ((LS.Argument e) : xs) = do
        ev  <- evalExpr e
        rec <- eval_scad_args xs
        return $ (LS.Argument $ exprResToLS ev) : rec
    eval_scad_args ((LS.NamedArgument k e) : xs) = do
        ev  <- evalExpr e
        rec <- eval_scad_args xs
        return $ (LS.NamedArgument k $ exprResToLS ev) : rec

    eval_object :: LS.Object -> EvalM ObjectRes
    eval_object (LS.Module (LS.Ident name) args mb_child)
        | name == "union" = do
            sub <- sequence (eval_object <$> (maybeToList mb_child))
            return $ RUnion sub
        | name == "difference" = raiseError
            "can't handle difference in part parser"
        | name == "intersection" = raiseError
            "can't handle intersection in part parser"
        | name == "translate" = do
            eargs  <- eval_args args ["v"]
            echild <- mapM eval_object mb_child
            return $ RTranslate eargs echild
        | name == "rotate" = do
            eargs  <- eval_args args ["a", "v"]
            echild <- mapM eval_object mb_child
            return $ RRotate eargs echild
        | name == "children" = do
            x <- getScopeChildren
            case x of
                Just child -> return child
                Nothing    -> raiseError "parent module does not have children"
        | otherwise = withCallStack
                ("eval_object: " ++ name ++ " " ++ show args)
        $ do
              val <- getScopeModule name
              case val of
                  Just (m_args, m_body) -> if is_part m_body
                      then do
                          eargs <- eval_scad_args args
                          args_to_scope args m_args
                          pname <- part_name m_body
                          printed <- part_printed m_body
                          return
                              $ RPart {
                                    rp_name = (fromMaybe (pretty_name name eargs)
                                               pname
                                    ),
                              rp_model = SCADModel { module_name = name
                                          , args        = eargs
                                          , imports     = [root_file]
                                          },
                                rp_printed = printed
                                      }
                      else localScope $ do
                          case mb_child of
                              Just child -> do
                                  e <- eval_object child
                                  insertScopeChildren e
                              Nothing -> return ()
                          verify_call_args args
                          args_to_scope args m_args
                          mb_body <- sequence $ eval_object <$> m_body
                          return $ RUnion mb_body
                  Nothing ->
                      raiseError ("unknnwn module: " ++ name ++ "\n")
    eval_object (LS.ForLoop (LS.Ident name) expr child) = do
        ee <- evalExpr expr
        case ee of
            RVec vals -> do
                children <- sequence $ f <$> vals
                return $ RUnion children
            _ -> raiseError "For loop should iterate"
      where
        f :: ExprRes -> EvalM ObjectRes
        f expr = do
            insertScopeVar name expr
            eval_object child
    eval_object (LS.Objects children) = do
        evaled <- sequence $ eval_object <$> children
        return $ RUnion evaled
    eval_object (LS.If expr child mb_else_child) = do
        e <- evalExpr expr
        case e of
            RBool v -> if v
                then eval_object child
                else (maybe (return $ RUnion []) eval_object mb_else_child)
            _ -> raiseError "no bool in if"
    eval_object (LS.BackgroundMod _) =
        raiseError "backgorund modifier in scad not allowed"
    eval_object (LS.DebugMod _) =
        raiseError " debug modifier in scad not allowed "
    eval_object (LS.RootMod _) = raiseError "root modifier in scad not allowed"
    eval_object (LS.DisableMod _               ) = return $ RUnion []
    eval_object (LS.ModuleDef _ _ _            ) = raiseError "no moduledef !"
    eval_object (LS.VarDef (LS.Ident name) expr) = do -- I do not think this will work?
        ee <- evalExpr expr
        insertScopeVar name ee
        return $ RUnion []
    eval_object (LS.FuncDef _ _ _) = raiseError "no funcdef!" -- this should be fixed

    part_attr :: [LS.Object] -> String -> EvalM (Maybe ExprRes)
    part_attr (x : _) attrkey = case x of
        (LS.Module (LS.Ident ch_name) args _) ->
            if ch_name == "part" then attr_from_args args else return Nothing
        _ -> return Nothing
      where
        attr_from_args :: [LS.Argument LS.Expr] -> EvalM (Maybe ExprRes)
        attr_from_args [] = return Nothing
        attr_from_args ((LS.Argument _):xs) = attr_from_args xs
        attr_from_args ((LS.NamedArgument (LS.Ident key) expr ): xs) =
            if key == attrkey then do
                e <- evalExpr expr
                return $ Just e
            else attr_from_args xs

    part_printed :: [LS.Object] -> EvalM Bool
    part_printed m_body = do
        expr <- part_attr m_body "printed"
        case expr of
            Just x -> case x of
                (RBool b) -> return b
                _ -> raiseError "argument to printed should be bool"
            Nothing -> return False

    part_name :: [LS.Object] -> EvalM (Maybe String)
    part_name m_body = do
        expr <- part_attr m_body "part_name"
        case expr of
            Just x -> case x of
                (RString s) -> return $ Just s
                _ -> raiseError "argument to part_name should be string"
            Nothing -> return Nothing

    is_part :: [LS.Object] -> Bool
    is_part (x : _) = case x of
        (LS.Module (LS.Ident ch_name) _ _) -> ch_name == "part"
        _ -> False
    is_part [] = False

    pretty_name :: String -> [LS.Argument LS.Expr] -> String
    pretty_name name args =
        "SCAD: "
        ++ name
        ++ "("
        ++ intercalate ", " (pretty_show <$> args)
        ++ ")"
      where
        pretty_show :: LS.Argument LS.Expr -> String
        pretty_show (LS.Argument arg) = show arg
        pretty_show (LS.NamedArgument (LS.Ident key) arg) =
            key ++ "=" ++ pretty_arg arg

        pretty_arg :: LS.Expr -> String
        pretty_arg (LS.ENum v) = show v
        pretty_arg (LS.EVec x) =
            "[" ++ intercalate "," (pretty_arg <$> x) ++ "]"
        pretty_arg x = show x

extractParts
    :: Filename -> LS.Ident -> [LS.Argument LS.Expr] -> IO [SimplePart]
extractParts filename mod args = do
    abs_path <- canonicalizePath filename
    let root_dir = takeDirectory abs_path
    cmap <- build_codemap root_dir $ (takeFileName filename, Nothing) : []
    let root = LS.Module mod args Nothing
    return $ evalUntilParts filename root (concat $ catMaybes $ snd <$> cmap)
  where

    extract_code :: Filename -> IO [LS.TopLevel]
    extract_code fn = do
        bs <- BS.readFile fn
        case LS.parse bs of
            Left  s  -> fail ("Failed to parse file " ++ fn ++ ": " ++ s)
            Right xs -> return xs

    build_codemap
        :: Filename
        -> [(Filename, Maybe [LS.TopLevel])]
        -> IO [(Filename, Maybe [LS.TopLevel])]
    build_codemap root_dir cmap = do
        let mb_pair = find (\(_, v) -> isNothing v) cmap
        case mb_pair of
            Nothing        -> return cmap
            Just (file, _) -> do
                let abs_path = root_dir </> file
                let relative_folder =
                        makeRelative root_dir (takeDirectory abs_path)
                subcode <- extract_code abs_path
                build_codemap root_dir
                    $   (\(k, v) ->
                            if k == file then (k, Just subcode) else (k, v)
                        )
                    <$> (new_includes relative_folder subcode cmap ++ cmap)

    new_includes
        :: Filename
        -> [LS.TopLevel]
        -> [(Filename, Maybe [LS.TopLevel])]
        -> [(Filename, Maybe [LS.TopLevel])]
    new_includes _          []       cmap = []
    new_includes rel_prefix (x : xs) cmap = case x of
        LS.TopLevelScope _ -> new_includes rel_prefix xs cmap
        LS.UseDirective  _ -> new_includes rel_prefix xs cmap
        LS.IncludeDirective file ->
            let full_path = rel_prefix </> file
            in  if (any (\(k, _) -> k == full_path) cmap)
                    then new_includes rel_prefix xs cmap
                    else (full_path, Nothing) : new_includes rel_prefix xs cmap

getWalkerParts :: ExtendedWalker -> PackageConfig -> [(String, [SimplePart])]
getWalkerParts Walker {body=ExtendedBody {urdf_name, base_body},legs} PackageConfig {src_dir} = 
        (urdf_name, (ass_to_parts $ body_ass base_body))
            : concatMap
                  (\Leg { root_joint } -> mapLinks map_link root_joint)
                  legs
  where
    ass_to_parts :: ExtendedAssembly -> [SimplePart]
    ass_to_parts Assembly { amodel = ExtendedSCADModel { smodel } } =
        unsafePerformIO $ extractParts (src_dir </> (head $ imports smodel))
                                       (LS.Ident $ module_name smodel)
                                       (args smodel)

    map_link :: ExtendedLink -> (String, [SimplePart])
    map_link ExtendedLink { link = Link { assembly }, urdf_name } =
        (urdf_name, maybe [] ass_to_parts assembly)

generatePrint :: ExtendedWalker -> PackageConfig -> IO ()
generatePrint walker pconf = mapM_ part_to_scad walker_parts
  where
    walker_parts :: [SimplePart]
    walker_parts = uniq $ sort $ concatMap snd $ getWalkerParts walker pconf
    
    use_directive :: String -> LS.TopLevel
    use_directive file = LS.UseDirective $ src_dir pconf </> file

    part_to_scad ::  SimplePart -> IO ()
    part_to_scad Part{part_name, model} = SC.renderSCAD (filename ++ ".scad") scad
      where
          filename :: String
          filename = "out/print/" ++ module_name model ++ "_" ++ (show $ hash part_name `mod` 9068 ) 

          scad :: [LS.TopLevel]
          scad = ( use_directive <$> imports model) ++ [LS.TopLevelScope $ LS.Module (LS.Ident $ module_name model) (args model) Nothing]

generateBOM :: ExtendedWalker -> PackageConfig -> IO ()
generateBOM walker pconf = do
    mapM_ write_f walker_parts
    write_sum (concatMap snd walker_parts)
  where
    walker_parts :: [(String, [SimplePart])]
    walker_parts = getWalkerParts walker pconf

    write_f :: (String, [SimplePart]) -> IO ()
    write_f (filebase, p) = do
        let filename = "out/bom/" ++ filebase ++ ".csv"
        createDirectoryIfMissing True $ takeDirectory filename
        BSL.writeFile filename (CSV.encode $ parts_to_CSV p)

    write_sum :: [SimplePart] -> IO ()
    write_sum parts = do
        let filename = "out/bom/summary.csv"
        createDirectoryIfMissing True $ takeDirectory filename
        BSL.writeFile filename (CSV.encode $ parts_to_CSV parts)

    parts_to_CSV :: [SimplePart] -> [(Int, String)]
    parts_to_CSV iparts =
        (\x -> (length x, head x)) <$> (group $ sort (part_name <$> iparts))
