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

module Parser where

import           Control.Monad.Except
import           Control.Monad.State.Lazy
import           Data.ByteString                   as BS (readFile)
import           Data.ByteString.Lazy              as BSL (unpack, writeFile)
import qualified Data.Csv                          as CSV
import           Data.Fixed                        (mod')
import           Data.Hashable                     (Hashable, hash,
                                                    hashWithSalt)
import qualified Data.HashMap.Lazy                 as HM
import           Data.List
import           Data.Foldable                     (toList)
import           Data.List.Unique                  (sortUniq)
import qualified Data.Map                          as Map
import           Data.Maybe
import           Debug.Trace                       (traceShow, traceShowId,
                                                    traceShowM)
import qualified Language.OpenSCAD                 as LS
import           Linear.V3                         (V3 (..))
import           Numeric.Units.Dimensional.Prelude ((*~), (/~))
import           Schpin.Package
import qualified Schpin.SCAD                       as SC
import           Schpin.Shared
import           Schpin.Walker
import           System.Directory
import           System.FilePath
import           System.IO.Unsafe
import           Text.JSON                         as TJ

data ExprRes = RNum Double | RString String | RBool Bool | RVec [ExprRes] | RUndef deriving (Show, Eq, Ord)
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 } |
    RAssemblyDir [Arg] [ObjectRes] |
    RAssembly { rp_aname :: String, rp_subitems :: [ObjectRes] }
  deriving (Show, Eq, Ord)

data EvalRes =
    EAssembly {
      ea_name  :: String,
      ea_pos   :: Pose,
      ea_items :: [EvalRes] } |
    EAssemblyDir {
      ead_dir   :: Axis,
      ead_pos   :: Pose,
      ead_items :: [EvalRes] } |
    EPart {
      ep_name              :: String,
      ep_pos               :: Pose,
      ep_model             :: SCADModel,
      ep_mb_print_filename :: Maybe Filename }
  deriving (Show, Eq, Ord)

instance Hashable EvalRes where
  hashWithSalt sal obj = case obj of
    EAssembly {ea_name, ea_pos, ea_items} -> sal `hashWithSalt` ea_name `hashWithSalt` ea_pos `hashWithSalt` ea_items
    EAssemblyDir {ead_dir, ead_pos, ead_items} -> sal `hashWithSalt` ead_dir `hashWithSalt` ead_pos `hashWithSalt` ead_items
    EPart {ep_name, ep_pos, ep_model, ep_mb_print_filename} -> sal `hashWithSalt` ep_name `hashWithSalt` ep_pos `hashWithSalt` ep_model `hashWithSalt` ep_mb_print_filename

mapParts :: (EvalRes -> a) -> EvalRes -> [a]
mapParts f obj = case obj of
                   EPart {}             -> [f obj]
                   EAssembly {ea_items} -> concat $ mapParts f <$> ea_items
                   EAssemblyDir {ead_items} -> concat $ mapParts f <$> ead_items

-- [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 = lift $ gets (\s -> HM.lookup key $ vars s)

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

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

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

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

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

getScopeChildren :: EvalM (Maybe ObjectRes)
getScopeChildren = lift $ gets children

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

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

popStack :: EvalM ()
popStack = 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 ->
          insertScopeModule name (args, body)
        LS.VarDef (LS.Ident name) expr -> do
          e <- evalExpr expr
          insertScopeVar name e
        LS.FuncDef (LS.Ident name) args body ->
          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)

partFilename :: SCADModel -> String -> String
partFilename model name = module_name model ++ "_" ++ show (hash name `mod` 9068)


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

  conv :: Pose -> ObjectRes -> [EvalRes]
  conv pos obj = case obj of
    RUnion objs -> concat $ conv pos <$> objs
    RTranslate args mb_sub -> concat $ catMaybes $ [conv (transform dir pos) <$> mb_sub]
      where
        dir :: Pose
        dir = Pose (pos_arg args) neutralQuat
    RRotate args mb_sub -> concat $ catMaybes $ [conv (transform dir pos) <$> mb_sub]
      where
        dir :: Pose
        dir = case args of
                [(_, RVec [RNum a, RNum b, RNum c])] -> Pose neutralPos $ eulerToQuat (V3 a b c)
                _ -> error ("Rotation should have vector of three numbers: " ++ show args)
    RPart {rp_name, rp_model, rp_printed} -> [EPart{ep_name = rp_name, ep_pos = pos, ep_model = rp_model, ep_mb_print_filename = if rp_printed then (Just $ partFilename rp_model rp_name) else Nothing}]
    RAssembly {rp_aname, rp_subitems} -> [EAssembly {ea_name = rp_aname, ea_pos=pos, ea_items = concat $ conv noOffset <$> rp_subitems}]
    RAssemblyDir args subs -> [EAssemblyDir {ead_dir = pos_arg args, ead_pos = pos, ead_items = concat $ conv noOffset <$> subs}]

  pos_arg :: [Arg] -> Position
  pos_arg args = case args of
                (_, RVec [RNum x, RNum y, RNum z]):_ -> V3 (x *~ mm) (y *~ mm) (z *~ mm)
                _ -> error ("Args should have vector of three numbers: " ++ show args)



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
    f lh_v rh_v
   where -- error checking wroooooong
    f :: ExprRes -> ExprRes -> EvalM ExprRes
    f (RNum lh_val) (RNum rh_val) = return $ RNum (op lh_val rh_val)
    f (RVec lh_vec) (RVec rh_vec) = do
        res <- mapM id $ zipWith f lh_vec rh_vec
        return $ RVec res
    f (RVec lh_vec) (RNum rh_val) = do
                                  res <- mapM (\x -> f x (RNum rh_val)) lh_vec
                                  return $ RVec res
    f x y = raiseError $ "use only vector or num in basic ops: " ++ show x ++ " , " ++ show y

  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 (uncurry f) 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_custom_module
    :: String
    -> [(LS.Ident, Maybe LS.Expr)]
    -> [LS.Object]
    -> [LS.Argument LS.Expr]
    -> Maybe LS.Object
    -> EvalM ObjectRes
  eval_custom_module name m_args m_body args mb_child
    | is_part m_body = do
      eargs <- eval_scad_args args
      args_to_scope args m_args
      pname   <- part_name (head m_body) (pretty_name name eargs)
      printed <- part_printed $ head m_body
      return $ RPart
        { rp_name    = pname
        , rp_model   = SCADModel { module_name = name
                                 , args        = eargs
                                 , imports     = [root_file]
                                 }
        , rp_printed = printed
        }
    | is_assembly m_body = do
      eargs <- eval_scad_args args
      args_to_scope args m_args
      aname <- assembly_name (head m_body) (pretty_name name eargs) 
      mb_subitems <- sequence $ eval_object <$> m_body
      return $ RAssembly aname mb_subitems
    | name == "assembly_direction" = do
      case mb_child of
        Just child -> do
          e <- eval_object child
          insertScopeChildren e
        Nothing -> raiseError "assembly_direction should have children"
      verify_call_args args
      eargs <- eval_args args ["dir","expansion"]
      args_to_scope args m_args
      mb_subitems <- sequence $ eval_object <$> m_body
      return $ RAssemblyDir eargs mb_subitems
    | otherwise = 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

  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) ->
            eval_custom_module name m_args m_body args mb_child
          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

  obj_attr :: LS.Object -> String -> String -> a -> (ExprRes -> EvalM a) -> EvalM a
  obj_attr lso obj_name obj_attr def f = case lso of
    (LS.Module (LS.Ident ch_name ) args _) ->
      if ch_name == obj_name then attr_from_args args else return def
    _ -> return def
   where
    attr_from_args []  = return def
    attr_from_args ((LS.Argument _): xs) = attr_from_args xs
    attr_from_args ((LS.NamedArgument (LS.Ident key) expr): xs ) = 
      if key == obj_attr then do
          e <- evalExpr expr
          v <- f e
          return v
      else attr_from_args xs
  
  part_printed :: LS.Object -> EvalM Bool
  part_printed obj = obj_attr obj "part" "printed" False f 
   where
     f :: ExprRes -> EvalM Bool
     f (RBool b) = return b
     f _ = raiseError "argument to printed should be bool"

  assembly_name :: LS.Object -> String -> EvalM String
  assembly_name obj def = obj_attr obj "assembly" "assembly_name" def f
   where
     f :: ExprRes -> EvalM String
     f (RString s) = return s
     f _ = raiseError "argument to assembly_name should be string"

  part_name :: LS.Object -> String -> EvalM String
  part_name obj def = obj_attr obj "part" "part_name" def f
   where
     f :: ExprRes -> EvalM String
     f (RString s) = return s
     f _ = raiseError "argument to part_name should be string"

  has_child_module :: [LS.Object] -> String -> Bool
  has_child_module (x : _) name = case x of
    (LS.Module (LS.Ident ch_name) _ _) -> ch_name == name
    _                                  -> False
  has_child_module [] _ = False

  is_part :: [LS.Object] -> Bool
  is_part objs = has_child_module objs "part"

  is_assembly :: [LS.Object] -> Bool
  is_assembly objs = has_child_module objs "assembly"

  pretty_name :: String -> [LS.Argument LS.Expr] -> String
  pretty_name name args =
    name ++ "(" ++ intercalate "," (pretty_show <$> args) ++ ")"
   where
    pretty_show :: LS.Argument LS.Expr -> String
    pretty_show (LS.Argument arg) = pretty_arg 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 (LS.EString s) = s
    pretty_arg x           = show x

extractEvalTree :: Filename -> LS.Ident -> [LS.Argument LS.Expr] -> IO [EvalRes]
extractEvalTree 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 $ evalUntilEvalTree 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

data WEvalNode = WEvalNode { we_name     :: String
                           , we_pose     :: Pose
                           , we_eval     :: EvalRes
                           , we_children :: [WEvalNode]
                           }

mapWalkerEvalTree :: (WEvalNode -> a) -> WEvalNode -> [a]
mapWalkerEvalTree f r = f r : concatMap (mapWalkerEvalTree f) (we_children r)

walkerEvalTreeToEval :: WEvalNode -> EvalRes
walkerEvalTreeToEval WEvalNode{we_eval, we_children, we_pose} = we_eval
          { ea_pos = transform (ea_pos we_eval) we_pose
          , ea_items = ea_items we_eval ++ (walkerEvalTreeToEval <$> we_children)
          }

getWalkerEvalTree :: ExtendedWalker -> PackageConfig -> WEvalNode
getWalkerEvalTree Walker { body = ExtendedBody { urdf_name, base_body }, legs } PackageConfig { src_dir }
  = WEvalNode { we_name = urdf_name
              , we_pose = noOffset
              , we_eval = ass_to_parts (body_name base_body) (body_ass base_body)
              , we_children = catMaybes $ (\Leg{root_joint} -> foldJoints fold_joint Nothing root_joint ) <$> legs
              }
 where
  ass_to_parts :: String -> ExtendedAssembly -> EvalRes
  ass_to_parts name Assembly { amodel = ExtendedSCADModel { smodel } } = EAssembly {
    ea_name = name,
    ea_pos = noOffset ,
    ea_items = unsafePerformIO $ extractEvalTree (src_dir </> head (imports smodel))
                                   (LS.Ident $ module_name smodel)
                                   (args smodel)
    }

  fold_joint :: ExtendedJoint -> Maybe WEvalNode -> Maybe WEvalNode
  fold_joint
    ExtendedJoint{ joint = Joint { sub_link = ExtendedLink { link = Link { link_name, assembly }, urdf_name }, offset }}
    mb_child = case assembly of
      Just asm -> Just WEvalNode { we_name = urdf_name
                                 , we_pose = offset
                                 , we_eval = ass_to_parts link_name asm
                                 , we_children = catMaybes [mb_child]}
      Nothing -> Nothing

data AssemblyId = AssemblyId [Int]

assemblyIdAdd :: AssemblyId -> Int -> AssemblyId
assemblyIdAdd (AssemblyId ints) x = AssemblyId (ints ++ [x])

instance Show AssemblyId where
  show (AssemblyId ints) = intercalate "." (show <$> ints)

type AHash = Int

data ManualFile = ManualFile {
      mf_fileprefix :: Filename,
      mf_name :: String,
      mf_eres :: EvalRes,
      mf_pose :: Pose
    }

data ManualStep = ManualStep {
      ms_name :: String,
      ms_pos :: [(String, Pose)]
    }

data Manual = Manual {
      m_filename :: String,
      m_files :: [ManualFile],
      m_steps :: [ManualStep]
    }

generateManuals :: ExtendedWalker -> PackageConfig -> IO ()
generateManuals walker pconf = do
  let manuals = record_to_manual <$> asms
  mapM_ write_manual manuals
  pairs <- mapM prepare_render_pairs $ concatMap m_files manuals
  SC.renderSCADFiles $ sortUniq pairs
 where
  prepare_render_pairs :: ManualFile -> IO (Filename, Filename)
  prepare_render_pairs ManualFile{mf_fileprefix, mf_eres} = do
    scad_file <- makeAbsolute $ mf_fileprefix ++ ".scad"
    stl_file <- makeAbsolute $ mf_fileprefix ++ ".stl"
    SC.renderSCAD scad_file (eres_to_scad mf_eres)
    return (scad_file, stl_file)

  eres_to_scad :: EvalRes -> [LS.TopLevel]
  eres_to_scad obj = (LS.UseDirective <$> imps obj) ++ [LS.TopLevelScope $ f obj]
    where
      imps :: EvalRes -> [String]
      imps obj = sortUniq $ concat $ mapParts (\EPart{ep_model=SCADModel{imports}} -> imports) obj

      f :: EvalRes -> LS.Object
      f EAssembly {ea_pos, ea_items} = SC.transform ea_pos $ SC.union $ f <$> ea_items
      f EAssemblyDir {ead_pos, ead_items} = SC.transform ead_pos $ SC.union $ f <$> ead_items
      f EPart {ep_pos, ep_model=SCADModel{module_name, args}} = SC.transform ep_pos $ LS.Module (LS.Ident module_name) args Nothing

  write_manual :: Manual -> IO ()
  write_manual m = do
    makeParentDirectories (m_filename m)
    writeFileIfChanged (m_filename m) $ TJ.encode $ manual_to_json m

  record_to_manual :: (AHash, AssemblyId, EvalRes) -> Manual
  record_to_manual (ahash, aid, EAssembly{ea_items, ea_name, ea_pos}) = Manual {
        m_filename = "out/manual/" ++ ea_name ++ "_" ++ show aid ++ ".json",
        m_files = concat $ ( part_descent e_to_f ea_pos) <$> ea_items,
        m_steps = concatMap steps ea_items
      }
    where
      part_descent :: (Pose -> EvalRes -> a) -> Pose -> EvalRes -> [a]
      part_descent f offset obj = case obj of
                           EAssembly {ea_name, ea_pos, ea_items} -> [f offset obj] 
                           EAssemblyDir {ead_items} -> concatMap (part_descent f offset) ead_items
                           EPart {} -> [f offset obj]

      e_to_f :: Pose -> EvalRes -> ManualFile
      e_to_f offset obj = case obj of
        EPart{ep_name, ep_model, ep_pos} -> ManualFile
          { mf_fileprefix = char_f <$> "out/manual/" ++ ea_name ++ "/" ++ ep_name
          , mf_name = ep_name
          , mf_eres = obj
          , mf_pose = transform ep_pos offset
          }
        EAssembly{ea_name=sea_name, ea_pos=sea_pos} -> ManualFile
          { mf_fileprefix = char_f <$> "out/manual/" ++ ea_name ++ "/" ++ sea_name
          , mf_name = sea_name
          , mf_eres = obj
          , mf_pose = sea_pos
          }

      char_f '=' = '_'
      char_f '(' = '_'
      char_f ')' = '_'
      char_f ' ' = '_'
      char_f ',' = '_'
      char_f x = x

      steps :: EvalRes -> [ManualStep]
      steps obj = case obj of
        EAssembly {} -> []
        EAssemblyDir {ead_dir, ead_pos, ead_items} -> ManualStep
          { ms_name = ""
          , ms_pos = concat $ mapParts p_to_step_pos <$> ead_items 
          } : concatMap steps ead_items
        EPart {} -> []

      p_to_step_pos :: EvalRes -> (String,Pose)
      p_to_step_pos EPart {ep_name} = (ep_name, noOffset)

  manual_to_json :: Manual -> TJ.JSValue
  manual_to_json Manual{m_files, m_steps} = TJ.makeObj
    [ ("files", TJ.JSArray $ file_to_json <$> m_files )
    , ("steps", TJ.JSArray $ step_to_json <$> m_steps )
    ]
   where
     file_to_json :: ManualFile -> TJ.JSValue
     file_to_json ManualFile{mf_fileprefix, mf_name, mf_pose} = TJ.makeObj
        [ ("file", JSString $ TJ.toJSString (mf_fileprefix ++ ".stl"))
        , ("name", JSString $ TJ.toJSString mf_name)
        , ("pose", pose_to_json mf_pose)
        ]

     step_to_json :: ManualStep -> TJ.JSValue
     step_to_json ManualStep{ms_name, ms_pos} = TJ.makeObj
        [ ("name", JSString $ TJ.toJSString ms_name)
        , ("positions", TJ.JSArray $ (step_pos_to_json <$> ms_pos))
        ]
     
     step_pos_to_json :: (String,Pose) -> TJ.JSValue
     step_pos_to_json (n, p) = TJ.makeObj
        [ ("name", JSString $ TJ.toJSString n)
        , ("position", pose_to_json p )
        ]
     
     pose_to_json :: Pose -> TJ.JSValue
     pose_to_json Pose{pos, ori} = TJ.makeObj
        [ ("position", showJSON $ toList $ (\x -> x /~ mm) <$> pos)
        , ("orientation", showJSON $ toList $ id <$> ori)
        ]


  asms :: [(AHash, AssemblyId, EvalRes)]
  asms = nubBy (\(x,_,_) (y,_,_) -> x == y) $ link_to_asms (AssemblyId [0]) walker_parts

  walker_parts :: EvalRes
  walker_parts = walkerEvalTreeToEval $ getWalkerEvalTree walker pconf

  link_to_asms :: AssemblyId -> EvalRes -> [(AHash, AssemblyId,EvalRes)]
  link_to_asms aid obj = case obj of
     EAssembly {ea_items} -> (hash obj, aid, obj) : concatMap (\(i, ch) -> link_to_asms ( assemblyIdAdd aid i) ch) pairs
        where
          pairs :: [(Int, EvalRes)]
          pairs = zip [0..] ea_items
     EAssemblyDir {ead_items} -> concatMap (link_to_asms aid) ead_items
     EPart {} -> []


generatePrint :: ExtendedWalker -> PackageConfig -> IO ()
generatePrint walker pconf = do
  mapM_ item_to_scad walker_parts
  abs_render_pairs <- mapM get_render_pair
                           (catMaybes $ ep_mb_print_filename <$> walker_parts)
  SC.renderSCADFiles $ sortUniq abs_render_pairs
 where

  walker_parts :: [EvalRes]
  walker_parts = sortUniq $ concat $ mapWalkerEvalTree (\WEvalNode{we_eval} -> mapParts id we_eval) $ getWalkerEvalTree walker pconf

  get_render_pair :: Filename -> IO (Filename, Filename)
  get_render_pair b = do
    a <- makeAbsolute $ "out/print/" ++ b ++ ".scad"
    b <- makeAbsolute $ "out/print/" ++ b ++ ".stl"
    return (a, b)

  item_to_scad :: EvalRes -> IO ()
  item_to_scad EPart { ep_name, ep_model, ep_mb_print_filename } =
    case ep_mb_print_filename of
      Just f  -> SC.renderSCAD ("out/print/" ++ f ++ ".scad") (modelToSCAD ep_model)
      Nothing -> return()

generateBOM :: ExtendedWalker -> PackageConfig -> IO ()
generateBOM walker pconf = do
  mapM_ write_f walker_parts
  write_sum (concatMap snd walker_parts)
 where
  walker_parts :: [(String, [EvalRes])]
  walker_parts = mapWalkerEvalTree (\WEvalNode{we_name, we_eval} -> (we_name, mapParts id we_eval)) $  getWalkerEvalTree walker pconf

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

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

  parts_to_CSV :: [EvalRes] -> [(Int, String, Maybe Filename)]
  parts_to_CSV iparts =
    (\((_, name, file) : xs) -> (length xs + 1, name, file)) <$> group raw
   where
    raw :: [(Int, String, Maybe Filename)]
    raw = sort $ conv <$> iparts

    conv :: EvalRes -> (Int, String, Maybe Filename)
    conv obj = case obj of
        EPart {ep_name, ep_mb_print_filename} -> (1, ep_name, (++ ".stl") <$> ep_mb_print_filename)
        _ -> undefined
